--- url: /en/vbman.md --- ::::: tip HttpServer Memory Leak Fixed - Production Ready **v1.0.0.423** (2026.06.13) has completely fixed the cHttpServer memory leak issue. After four rounds of iteration, 12 bugs were fixed and 42 `As New` implicit references were converted, with stress test verification passed. See [Production Readiness Fix Report](./httpserver/v1.0.0.423). ::::: ::::: danger Historical Notice (Resolved) \~~The VBMAN web server object cHttpServer currently has a memory leak issue.~~ \~~Do not use in production yet. Please wait for the official release with the fix.~~ This issue has been fixed in v1.0.0.423, see the green notice above for details. ::::: ::::: tip 🎉 Big News: VBMAN is Now Open Source! **June 1, 2026** - After nine years of refinement, VBMAN is officially open sourced under the **[GPL v3](/en/vbman/LICENSE_GUIDE)** license! > From an idea in 2017 to today's open source project, VBMAN has always adhered to one belief: > **Make BASIC language still powerful in the network era.** * **Binaries Free Forever** — No usage restrictions on compiled DLL/OCX files * **Open Source** — Following [GPL v3 protocol](/en/vbman/LICENSE_GUIDE), welcome to Fork, contribute and build the ecosystem together * **Commercial Licensing Available** — [Contact us](/en/vbman/LICENSE_GUIDE) for closed-source commercial projects [**Visit Repository**](https://gitcode.com/woeoio/vbman) ::::: # 🌐 VBMan: Modern Web Development Framework for VB6 🚀 In today's rapidly evolving world of web technologies, many developers still prefer using the classic VB6 programming language. VBMan (Visual Basic Web Management) is a web framework tailored for VB6 developers. It perfectly combines the strengths of VB6 with modern web development needs, helping developers easily build powerful and stable web applications. Whether you're developing enterprise-level applications or seeking to implement real-time data interaction for IoT devices, VBMan provides strong support for you. ✨ ## 🔧 Multi-Protocol Support, Seamless Cross-Platform Communication 🌍 One of the highlights of VBMan is its powerful protocol support. You can easily implement real-time communication between clients and servers, handling various data streams. Here are the main protocols and technologies it supports: * 🕸️ **WebSocket**: Supports bidirectional real-time communication, greatly improving user experience. Suitable for chat applications, online games, and real-time data display. * 💬 **SSE (Server-Sent Events)**: Allows the server to actively push data to clients, ideal for applications requiring real-time updates such as stock quotes and news feeds. * 🔗 **Tenet**: An efficient protocol that makes communication between different systems more reliable and concise. * ⚙️ **Modbus**: A protocol commonly used in industrial control and device management, making VBMan a powerful tool in industrial automation. * 📡 **MQTT**: A lightweight messaging protocol, particularly suitable for data transmission between IoT devices. ## 🛠️ Rich Features, Comprehensive Toolset 📚 To help developers complete development tasks more efficiently, VBMan provides a rich set of tools: * 🗄️ **Built-in Database Support**: Through integrated database tools, you can quickly manage and operate data without additional configuration. * 🖥️ **Web Service Support**: Allows you to easily create RESTful APIs and web services, supporting multiple standards and protocols for easy integration with other systems. * 📊 **Logging and Error Tracking Tools**: The built-in logging system helps developers easily track application running status and debug information, quickly locating issues. * 🖌️ **Various Frontend Components**: Including common UI elements and data display tools, helping developers quickly build user-friendly web interfaces. ## ⭐ Framework Features * 📚 **Easy to Learn and Use**: Developers can leverage existing VB6 skills to get started easily. * ⚙️ **High Flexibility**: Whether for small projects or complex enterprise-level applications, VBMan can handle them with ease. * 🔗 **Highly Integrated**: Integrates various tools needed for development, reducing environment configuration time and making development more focused and efficient. ## 🌟 Real-world Application Cases 📈 * 🌐 **IoT Solutions**: Through MQTT and Modbus protocols, VBMan enables various smart devices to interact in real-time on web platforms, becoming the core of smart home and smart factory applications. * 📊 **Real-time Data Stream Applications**: Through WebSocket and SSE, VBMan can help you build efficient real-time data stream processing platforms, such as financial trading systems and real-time monitoring systems. * 🏢 **Enterprise Management Systems**: Leveraging VBMan's web service support, developers can quickly build internal management systems, supporting team collaboration, data processing, and business analysis. ## 🚀 Future Outlook VBMan is not just a framework; it is a bridge for VB6 developers to enter the web development field. Through multi-protocol support, a rich toolset, and a simple and easy-to-use development environment, VBMan provides developers with infinite possibilities. Whether you're a web development novice or a senior engineer, VBMan will be a powerful partner on your development journey. Let's build more modern and intelligent web applications on the foundation of VB6! ## 🤝 Community Support * 💬 **QQ Group**: 915520648 [Click here to join](http://qm.qq.com/cgi-bin/qm/qr?_wv=1027\&k=maQtC3a5Zxb3gMLvwpj6oE5fwmZGCOlY\&authKey=8%2FhBgSMLqADLatzXghFXO5BIBa%2BxSoHO%2FHFvtbZQk2kURUx%2FegxZukzAvhSPX6WJ\&noverify=0\&group_code=915520648) * 🎁 **Support the Project**: If this project helps you, donations are welcome to encourage continued development! [Click here to donate](/donate/) --- --- url: /zh/vbman.md --- :::: tip HttpServer 内存泄漏已修复 - 可生产使用 **v1.0.0.423**（2026.06.13）已彻底修复 cHttpServer 内存泄漏问题。经四轮迭代共修复 12 个 BUG、转换 42 处 `As New` 隐式引用，压测验证通过。详见 [生产可用性修复报告](./httpserver/v1.0.0.423)。 :::: :::: danger 历史提醒（已解决） \~~当前已知VBMAN的web服务器对象 cHttpServer 存在内存泄露问题。~~ \~~暂时不要生产使用，请等待正式版本解决问题发布。~~ 此问题已在 v1.0.0.423 修复，上方绿色提示框有详细说明。 :::: :::: tip 🎉 重磅消息：VBMAN 正式开源 **2026年6月1日**，历时九年打磨的 VBMAN 正式以 **[GPL v3](/vbman/LICENSE_GUIDE)** 协议开源！ > 从 2017 年的一个念头，到今天的开源项目，VBMAN 始终秉承一个信念： > **让 BASIC 语言在网络时代依然好用。** * **二进制永久免费** — 编译后的 DLL/OCX 无任何使用限制 * **源代码开放** — 遵循 [GPL v3 协议](/vbman/LICENSE_GUIDE)，欢迎 Fork、贡献、共建生态 * **商业授权可选** — 闭源商业项目可[联系获取授权](/vbman/LICENSE_GUIDE) [**访问代码仓库**](https://gitcode.com/woeoio/vbman) :::: # 🌐 VBMan：VB6的现代Web开发框架 🚀 在如今高速发展的Web技术世界里，许多开发者仍然习惯使用经典的VB6编程语言进行开发。VBMan（Visual Basic Web Management）是一个为VB6开发者量身打造的Web框架，它将VB6的优势与现代Web开发需求完美结合，帮助开发者轻松构建强大、稳定的Web应用程序。无论你是开发企业级应用，还是想要实现物联网设备的实时数据交互，VBMan都能为你提供强有力的支持。✨ ## 🔧 多协议支持，跨平台通讯无缝连接 🌍 VBMan最大的亮点之一就是它强大的协议支持。你可以轻松地在客户端与服务器之间实现实时通讯，处理各种数据流。以下是它支持的主要协议和技术： * 🕸️ **WebSocket**：支持双向实时通讯，极大提高用户体验，适用于聊天应用、在线游戏和实时数据展示。 * 💬 **SSE (服务器推送事件)**：让服务器主动向客户端推送数据，适合需要实时更新的应用，如股票行情、新闻推送等。 * 🔗 **Tenet**：一种高效的协议，可以让不同系统间的通信更加可靠和简洁。 * ⚙️ **Modbus**：常用于工业控制和设备管理的协议，使得VBMan在工业自动化领域得心应手。 * 📡 **MQTT**：轻量级的消息传输协议，特别适用于物联网设备间的数据传输。 ## 🛠️ 功能丰富，工具集应有尽有 📚 为了帮助开发者更高效地完成开发任务，VBMan提供了丰富的工具集： * 🗄️ **内置数据库支持**：通过集成的数据库工具，你可以快速管理和操作数据，无需额外配置。 * 🖥️ **Web服务支持**：让你轻松创建RESTful API和Web服务，支持多种标准和协议，便于与其他系统集成。 * 📊 **日志与错误追踪工具**：内置的日志系统帮助开发者轻松追踪应用的运行状态和调试信息，快速定位问题。 * 🖌️ **多种前端组件**：包括常见的UI元素和数据展示工具，帮助开发者快速构建用户友好的Web界面。 ## ⭐ 框架特点 * 📚 **易学易用**：开发者可以利用现有的VB6技能，轻松上手。 * ⚙️ **灵活性强**：无论是小型项目，还是复杂的企业级应用，VBMan都能够应对自如。 * 🔗 **高度集成**：整合了多种开发所需工具，减少了开发环境的配置时间，让开发更加专注和高效。 ## 🌟 实际应用案例 📈 * 🌐 **物联网解决方案**：通过MQTT和Modbus协议，VBMan能够让各种智能设备在Web平台上实时交互，成为智能家居、智能工厂等应用的核心。 * 📊 **实时数据流应用**：通过WebSocket和SSE，VBMan能够为你构建高效的实时数据流处理平台，比如金融交易系统、实时监控系统等。 * 🏢 **企业级管理系统**：利用VBMan的Web服务支持，开发者可以快速构建内部管理系统，支持团队协作、数据处理与业务分析。 ## 🚀 未来展望 VBMan不仅仅是一个框架，它是VB6开发者通往Web开发领域的桥梁。通过多协议支持、丰富的工具集、简单易用的开发环境，VBMan为开发者提供了无穷的可能性。无论你是Web开发新手，还是资深工程师，VBMan都将是你在开发路上得力的伙伴。让我们一起在VB6的基础上，构建更加现代、智能的Web应用！ ## 🤝 社区支持 * 💬 **QQ交流群**：915520648 [点击这里加群](http://qm.qq.com/cgi-bin/qm/qr?_wv=1027\&k=maQtC3a5Zxb3gMLvwpj6oE5fwmZGCOlY\&authKey=8%2FhBgSMLqADLatzXghFXO5BIBa%2BxSoHO%2FHFvtbZQk2kURUx%2FegxZukzAvhSPX6WJ\&noverify=0\&group_code=915520648) * 🎁 **项目支持**：如果本项目对你有帮助，欢迎捐赠，鼓励迭代发展！[点击这里捐赠](/donate/) --- --- url: /zh/vbman2.md --- # 🚀 VBMAN2 升级公告 > 📅 **公告日期：2026.06.01** :::: tip 🎉 重要通知：VBMAN2 战略升级 ## 关于 VBMAN2 的重大变更 VBMAN2 早期是基于 TwinBasic 的 WebView2 控件封装给 VB6/VBA 使用的纯 WebView2 控件库，编译产物是 OCX 控件文件。 **2026.05.25 重大更新**：我们将 TwinBasic WebView2 控件重写为 DLL 对象，通过渲染到任何有句柄的原生控件（如 `Form1.hWnd`、`Picture1.hWnd`）即可显示网页，**解决了 OCX 控件文件的烦恼**，并且为升级 VBMAN 打下了最好的基础。 ### 核心变更 | 项目 | 原 VBMAN2 | 新 VBMAN2 | |------|-----------|-----------| | 编译产物 | OCX 控件 | DLL 组件 | | 与 VBMAN 关系 | 独立库 | **VBMAN 的升级版** | | 开发状态 | 停止更新 | 持续开发中 | ### 升级建议 **原有的 `vbman.ocx` 控件将不再继续开发**，请所有用户在 **VBMAN2.DLL** 正式发布后及时升级。 VBMAN2 将成为 VBMAN 的最佳升级版，带来更多强大功能： * 🚀 高性能 IOCP 网络库 * 🌐 基于 IOCP 的 HTTP 服务器 * ⚡ 真正可调试的多线程池 * 🤖 真正可用的 AI 对象 * 🗄️ 集合各种数据库驱动 * ... 更多惊喜功能 :::: :::: warning ⏳ 敬请期待 **VBMAN2.DLL 正在紧张开发中，敬请期待！** 我们会在第一时间发布新版本，敬请关注： * 📢 官方网站： * 💬 QQ 交流群：915520648 [点击加群](http://qm.qq.com/cgi-bin/qm/qr?_wv=1027\&k=maQtC3a5Zxb3gMLvwpj6oE5fwmZGCOlY\&authKey=8%2FhBgSMLqADLatzXghFXO5BIBa%2BxSoHO%2FHFvtbZQk2kURUx%2FegxZukzAvhSPX6WJ\&noverify=0\&group_code=915520648) * 📦 代码仓库： > VBMAN2 没有开源计划，但同样的，**永久免费使用二进制 DLL**。 :::: *** ## VBMAN2 核心特性预览 ### 双向数据绑定 VBMAN2 提供类似 Vue 的双向数据绑定能力，实现 VB6/VBA 宿主与 WebView2 网页 UI 的无缝联动： | 方向 | API | 说明 | |------|-----|------| | UI → VB6/VBA | `BindUI` / `UnbindUI` | DOM 事件触发 → 回调宿主方法 | | VB6/VBA → UI | `BindData` / `SetData` | 宿主设值 → 自动更新 DOM 属性 | **核心设计**：显式组合而非隐式劫持。不同于 Vue 依赖 ES6 Proxy 的自动数据劫持，VBMAN2 采用 `BindUI` + `BindData` 显式组合，更适合跨进程 WebView2 场景，且完全兼容 VB6/VBA： ```vb ' 单向绑定：VB6/VBA → UI wv.BindData "username", "#user-name", "textContent" wv.SetData "username", "张三" ' UI 自动更新 ' 双向绑定：输入框 ↔ VB6/VBA wv.BindData "search", "#search-input", "value" ' 数据 → UI wv.BindUI Me, "OnSearch", "#search-input", EventName:="input" ' UI 事件 → VB6/VBA Public Sub OnSearch(ByVal EventName As String, ByVal Detail As String) wv.SetData "search", JsonParser.GetValue(Detail, "value") ' 回写数据 End Sub ``` **支持的 DOM 属性**：`textContent` / `innerHTML` / `value` / `checked` / `disabled` / `visible` / `className` / `src` / `href` / `style` 等，同时支持批量更新 `SetDataBatch` 减少 IPC 调用。 *** ## VBMAN 开源项目 VBMAN 已于 **2026年6月1日** 正式以 **GPL v3** 协议开源！ * 🔓 **二进制永久免费** — 编译后的 DLL/OCX 无任何使用限制 * 📖 **源代码开放** — 遵循 GPL v3 协议 * 💼 **商业授权可选** — 闭源商业项目可联系获取授权 [**访问 VBMAN 文档**](/vbman/)  |  [**查看代码仓库**](https://gitcode.com/woeoio/vbman) --- --- url: /en/vbman2.md --- # 🚀 VBMAN2 Upgrade Announcement > 📅 **Announcement Date: 2026.06.01** :::: tip 🎉 Important Notice: VBMAN2 Strategic Upgrade ## About VBMAN2 Major Changes VBMAN2 was originally a pure WebView2 control library for VB6/VBA based on TwinBasic's WebView2 control wrapper, with the compiled output being an OCX control file. **Major Update on 2026.05.25**: We rewrote the TwinBasic WebView2 control as a DLL component, which can render web pages to any native control with a handle (such as `Form1.hWnd`, `Picture1.hWnd`). This **solves the headache of OCX control files** and lays the best foundation for upgrading VBMAN. ### Core Changes | Item | Original VBMAN2 | New VBMAN2 | |------|-----------------|------------| | Output | OCX Control | DLL Component | | Relationship with VBMAN | Independent Library | **Upgrade Version of VBMAN** | | Development Status | Stopped | Active Development | ### Upgrade Recommendation **The original `vbman.ocx` control will no longer be developed**. Please upgrade in time after **VBMAN2.DLL** is officially released. VBMAN2 will become the best upgrade version of VBMAN, bringing more powerful features: * 🚀 High-performance IOCP network library * 🌐 IOCP-based HTTP server * ⚡ Truly debuggable multi-threading pool * 🤖 Truly usable AI object * 🗄️ Integrated database drivers * ... More surprises :::: :::: warning ⏳ Coming Soon **VBMAN2.DLL is under intensive development, stay tuned!** We will release the new version as soon as possible, please follow: * 📢 Official Website: * 💬 QQ Group: 915520648 [Join Group](http://qm.qq.com/cgi-bin/qm/qr?_wv=1027\&k=maQtC3a5Zxb3gMLvwpj6oE5fwmZGCOlY\&authKey=8%2FhBgSMLqADLatzXghFXO5BIBa%2BxSoHO%2FHFvtbZQk2kURUx%2FegxZukzAvhSPX6WJ\&noverify=0\&group_code=915520648) * 📦 Code Repository: > VBMAN2 has no open source plan, but likewise, **free forever to use the binary DLL**. :::: *** ## VBMAN2 Core Features Preview ### Two-way Data Binding VBMAN2 provides Vue-like two-way data binding capabilities, enabling seamless interaction between VB6/VBA host and WebView2 web UI: | Direction | API | Description | |-----------|-----|-------------| | UI → VB6/VBA | `BindUI` / `UnbindUI` | DOM event triggers → callback host method | | VB6/VBA → UI | `BindData` / `SetData` | Host sets value → automatically updates DOM property | **Core Design**: Explicit composition instead of implicit hijacking. Unlike Vue's automatic data hijacking relying on ES6 Proxy, VBMAN2 uses `BindUI` + `BindData` explicit composition, which is more suitable for cross-process WebView2 scenarios and fully compatible with VB6/VBA: ```vb ' One-way binding: VB6/VBA → UI wv.BindData "username", "#user-name", "textContent" wv.SetData "username", "John Doe" ' UI updates automatically ' Two-way binding: Input box ↔ VB6/VBA wv.BindData "search", "#search-input", "value" ' Data → UI wv.BindUI Me, "OnSearch", "#search-input", EventName:="input" ' UI event → VB6/VBA Public Sub OnSearch(ByVal EventName As String, ByVal Detail As String) wv.SetData "search", JsonParser.GetValue(Detail, "value") ' Write back data End Sub ``` **Supported DOM Properties**: `textContent` / `innerHTML` / `value` / `checked` / `disabled` / `visible` / `className` / `src` / `href` / `style`, etc., with batch update support via `SetDataBatch` to reduce IPC calls. *** ## VBMAN Open Source Project VBMAN was officially open-sourced under the **GPL v3** license on **June 1, 2026**! * 🔓 **Binary Free Forever** — Compiled DLL/OCX with no usage restrictions * 📖 **Open Source** — Under GPL v3 license * 💼 **Commercial License Available** — Contact us for closed-source commercial projects [**Visit VBMAN Documentation**](/vbman/)  |  [**View Code Repository**](https://gitcode.com/woeoio/vbman) --- --- url: /zh/vbman/httpserver/v1.0.0.423.md --- # 010. HttpServer 生产可用性修复 ## 概述 用户反馈 HTTP 服务器运行数天后出现崩溃、无响应等故障。经四轮迭代修复，共发现 **3 个致命级 + 5 个高危级 + 7 个中危级 = 15 个 BUG**，已修复 12 个（BUG-1~10、BUG-15），缓解 2 个（BUG-11、BUG-12），未修复 1 个（BUG-13），功能缺失 1 个（BUG-14）。 用户的核心诉求是"HTTP 连一次内存涨一点点，永远不会下降，最终程序崩溃"，四轮修复围绕该目标依次解决：致命崩溃→内存泄漏→空 Session 累积→As New 隐式引用→SSE 资源残留。 *** ## 问题总览 | 编号 | 级别 | 问题 | 根因 | 影响 | 状态 | | ------ | ---- | --------------------------- | ----------------------------------------- | ------------------------ | -------------------- | | BUG-1 | 致命 | 连接池索引漂移 | Collection.Remove 导致后续索引前移 | 数据发错客户端、GPF 崩溃 | **已修复** | | BUG-2 | 致命 | 僵尸连接无限累积 | 无空闲超时 + 循环引用链 | 内存持续增长 → OOM | **已修复** | | BUG-3 | 致命 | 请求体无大小限制 | 无 Content-Length 上限 | 恶意请求撑爆内存 | **已修复** | | BUG-4 | 高危 | recvBuffer 永不缩容 | 大请求后数组不释放 | 长连接隐性内存泄漏 | **已修复** | | BUG-5 | 高危 | 循环引用链 | cHttpServer↔cClientCallback↔Response 互引 | COM 对象永不释放 | **已修复** | | BUG-6 | 高危 | FindCRLFCRLF 返回 0 歧义 | 位置 0 与"未找到"混淆 | 特定请求永远无法解析 | **已修复** | | BUG-7 | 高危 | 无最大连接数限制 | 服务端无防护 | 资源耗尽 | **已修复** | | BUG-8 | 高危 | SendData 无错误处理 | 断开后发送抛异常 | 进程崩溃 | **已修复** | | BUG-9 | 中危 | SSE.Entry 失败不清理连接池 | CloseSck 触发但 m\_cConnPool 残留 | 连接池泄漏 | **已修复** | | BUG-10 | 中危 | SSE.Data 共享可变状态 | 重入时数据错乱 | 数据丢失 | **已修复** | | BUG-11 | 中危 | Session 清理概率 1% 过低 | 低流量时 Session 堆积 | 内存泄漏 | **已缓解**（cTimer） | | BUG-12 | 中危 | StopMe 销毁共享对象 | Router/SSE/Database 被设为 Nothing | 重启后配置丢失 | **已缓解** | | BUG-13 | 中危 | 不支持 chunked 传输编码 | 未实现分块传输解析 | 特定客户端挂起 | 未修复 | | BUG-14 | 中危 | 静态文件缓存不更新 | WebRoot 只在启动时扫描 | 运行时添加文件不可见 | 未修复 | | BUG-15 | 中危 | SSE CloseClient 不关 Socket | 仅清理字典但不关 Socket | 连接残留 | **已修复** | *** ## Round 1：致命/高危 BUG 修复 ### BUG-1: 连接池 Collection 索引漂移 **症状**: 运行一段时间后数据发错客户端，或访问已释放对象导致 GPF 崩溃。 **根因**: `m_cConnPool` 使用 `Collection` 存储连接，每个 `cClientCallback.Index` 记录自身在 Collection 中的位置。当某个连接断开执行 `m_cConnPool.Remove Index` 时，后续所有项的索引自动前移，但 `oCallback.Index` 仍是旧值。 ``` 连接池: [A(1), B(2), C(3), D(4)] B 断开 → Remove 2 连接池: [A(1), C(2), D(3)] ← C 和 D 的索引变了 但 C.Index 仍为 2，D.Index 仍为 3 如果 A 断开 Remove 1，C 从 2→1，D 从 3→2 但 C.Index=2, D.Index=3 → m_cConnPool(3) 越界或取到错误对象！ ``` **修复**: `Collection` → `Dictionary`，以 `hSocket` 为 Key。 ```vb ' 修复前 Private m_cConnPool As New Collection ' 顺序索引 oCallback.Index = m_cConnPool.Count m_cConnPool.Add oCallback m_cConnPool.Remove Index ' 修复后 Private m_cConnPool As Dictionary ' hSocket 为 Key m_cConnPool.Add hSocket, oCallback m_cConnPool.Remove hSocket ``` ### BUG-2: 僵尸连接无限累积 **症状**: HTTP 服务器运行几天后内存持续增长，最终 OOM 崩溃。 **根因**: 客户端异常断开不发送 TCP FIN，`Socket_CloseSck` 事件永远不触发。循环引用链使 COM 引用计数不归零： ``` cHttpServer ← m_cConnPool ← cClientCallback ← Parent ──→ cHttpServer cClientCallback ← Context ← Response ← fClient ──→ cClientCallback ``` **修复**: 1. 新增 `LastActivity` 字段，每次数据到达时更新 2. 新增 `IdleTimeoutSeconds` 属性（默认 120 秒） 3. 新增 `CleanupIdleConnections()` 方法，遍历连接池释放超时连接 4. 集成 `cTimer` 内置定时器，默认每 30 秒自动清理 ### BUG-3: 请求体无大小限制 **根因**: 服务器无脑接收数据，`AppendToBuffer` 不断 `ReDim Preserve` 扩大缓冲区。 **修复**: 1. 新增 `MaxRequestSize` 属性（默认 10MB） 2. `OnDataArrival` 中检查缓冲区 + 新数据是否超限 3. `ContainsCompleteRequest` 中检查 Content-Length 是否超限 4. 新增 `State413` 响应 ### BUG-4: recvBuffer 永不缩容 **根因**: 处理完大请求后 `recvBuffer()` 数组保持已扩展的大小。 **修复**: `RemoveFromBuffer` 中，缓冲区清空时 `Erase recvBuffer`；容量超 64KB 且使用率低于 1/4 时 `ReDim Preserve` 缩容。 ### BUG-5: 循环引用链 **修复**: `Release()` 中彻底释放所有引用、`Erase recvBuffer`、重置 `hSocket = 0`。`Class_Terminate` 调用 `StopMe`。 ### BUG-6: FindCRLFCRLF 返回 0 歧义 **根因**: CRLFCRLF 出现在位置 0 时返回 0，未找到也返回 0。 **修复**: 未找到时返回 `-1`，`ContainsCompleteRequest` 和 `ExtractOneRequest` 同步更新。 ### BUG-7: 无最大连接数限制 **修复**: 新增 `MaxConnections` 属性（默认 1000），超限 `Disconnect = True`。 ### BUG-8: SendData 无错误处理 **修复**: `SendBodyByte` 和 `SendHeader` 加 `On Error Resume Next`，新增 `m_HasSent` 防止重复发送。 *** ## Round 2：内存泄漏显式清理 ### 现象 Round 1 修复后，压测发现内存仍以 ~10MB/s 增长：10 连接、900 QPS，339 秒后内存涨到 1.8GB。 ### 根因 `ProcessHttpRequest` 每次请求创建约 18+ COM 对象，请求完毕后仅靠 COM 引用计数等待回收，高并发下来不及： 1. **Response.fClient → oCallback 循环引用**：`oCallback → Context → Response → fClient → oCallback` 2. **Request 内部大对象未及时清理**：5 个 Dictionary + PathInfoList + 字节数组 3. **VB6 引用计数高频下回收滞后**：900 QPS × 18 对象 = 16200 COM 对象/秒 ### 修复 | 文件 | 修改 | | ------------------------- | ------------------------------------------------------------------------------------------------------------------------- | | `cHttpServer.cls` | ProcessHttpRequest 所有退出点（State413、Options、正常出口、EH）前调用 `Context.ReleaseRequest` + `Request.ClearRequest` | | `cHttpServerContext.cls` | 新增 `ReleaseRequest()`：断开 Response.fClient 循环引用、清理 Request/Response/Cookies/Session，保留 SSE/UserData/TimeUse | | `cHttpServerRequest.cls` | 新增 `ClearRequest()`：RemoveAll 所有 Dictionary、Erase 字节数组；Class\_Terminate 保险清理 | | `cHttpServerResponse.cls` | 新增 Class\_Terminate：Set Client = Nothing、Header.RemoveAll、释放 JsonInst | ### 清理链路 ``` ProcessHttpRequest 请求处理完毕 │ ├─ Context.ReleaseRequest() │ ├─ Response.fClient = Nothing ← 断开循环引用 │ ├─ Request.ClearRequest() ← 清空大对象 │ ├─ Set Request = Nothing │ ├─ Set Response = Nothing │ ├─ Cookies.Clear + Set Cookies = Nothing │ ├─ Set Session = Nothing │ └─ UserData.RemoveAll │ └─ Set response = Nothing: Set Request = Nothing ``` *** ## Round 3：Session 累积 + 类级 As New 全量修复 ### 现象 Round 2 修复后内存泄漏约 5-10MB/s。 ### 根因分析 #### 根因 1: Session 自动生成 sessionID 导致空 Session 大量累积 `cHttpServerSession.sessionID` Property Get 在 `pvSessionID` 为空时**自动生成 GUID**。`ProcessHttpRequest` 用 `If Session.sessionID <> "" Then` 判断是否存储——每个无 Cookie 的请求都会触发生成、条件恒 True、空 Session 永久存入 `m_Sessions`。 900 QPS × 60 秒 × 20 分钟 = **1,080,000 个空 Session**，约 1-2GB。 #### 根因 2: 类级 `As New` 隐式创建阻止显式释放 VB6 的 `Dim X As New ClassName`：`Set X = Nothing` 后下次访问自动重建，对象永远无法真正销毁。影响范围： | 文件 | As New 字段数 | | ---------------------------- | ------------- | | `cHttpServer.cls` | 9 | | `cSSE.cls` | 7 | | `cHttpServerRouter.cls` | 8 | | `cHttpServerSvr.cls` | 4 | | `cHttpServerSession.cls` | 1 | | `cHttpServerRouteBefore.cls` | 1 | | `cHttpServerRouterAfter.cls` | 1 | ### 修复 #### 核心修复：Session 累积 | 文件 | 修改 | | ------------------------ | ------------------------------------------------------------------------------------------------------------------------------------------------------------ | | `cHttpServerSession.cls` | sessionID Property Get **不再自动生成 GUID**，仅返回 `pvSessionID`；新增 `HasID` 属性；Data 改延迟创建（EnsureData）；新增 `Release()`；新增 Class\_Terminate | | `cHttpServer.cls` | `If Session.HasID Then` 替代 `If Session.sessionID <> "" Then`；显式清理本地变量 | #### 类级 As New 全量转换 7 个文件全部改为 `As` + Class\_Initialize 显式 `Set = New` + Class\_Terminate 显式 `Set = Nothing`。 同时在 cSSE.cls 中修复 BUG-9（Entry 失败时清理已设置的 SSE 引用）。 ### 清理链路（更新） ``` ProcessHttpRequest 请求处理完毕 │ ├─ Context.ReleaseRequest() │ ├─ Response.fClient = Nothing │ ├─ Request.ClearRequest() │ ├─ Set Request = Nothing │ ├─ Set Response = Nothing │ ├─ Cookies.Clear + Set Cookies = Nothing │ ├─ Set Session = Nothing │ └─ UserData.RemoveAll │ ├─ Set Session = Nothing ← 不再等 Sub 退出 ├─ Set Cookies = Nothing └─ Set response = Nothing: Set Request = Nothing ``` **Session 新逻辑**：只有 `Session.HasID = True` 时才会存入 `m_Sessions`、写入 Cookie、持久化。 *** ## Round 4：方法级 As New + SSE BUG-15/BUG-10 ### 方法级 `As New` 局部变量全量转换 上一轮修复了类级字段，方法体内仍有 11 处 `Dim X As New`。`As New` 的自动重建机制在异常路径下可能阻止回收。 | 文件 | 修改数量 | 具体变更 | | ------------------------- | -------- | ----------------------------------------------------------- | | `cHttpServer.cls` | 4 处 | CI, keysToClose, keysToRemove, sess → 全部显式 | | `cHttpServerSession.cls` | 4 处 | Serialize/Deserialize 中 Json, SessionData, DataCopy → 显式 | | `cHttpServerResponse.cls` | 1 处 | Json 方法中 Dic → 显式 | | `cHttpServerCookies.cls` | 1 处 | Cookie Property Get 中 CK → 显式 | | `cHttpServerRouter.cls` | 1 处 | Add 方法中 item → 显式 | ### BUG-15: SSE CloseClient 不关闭 Socket **原实现问题**： * 通过 `hSocket` 参数调用时（最常见方式），仅检查是否存在然后 GoTo 退出——**不做任何清理** * 通过 `ToUser().CloseClient` 调用时（GoSub Start 路径），清理字典但不关 Socket **后果**：所有主动关闭的 SSE 客户端，Socket 永远不关闭，cClientCallback 永远不释放。 **修复**：重构为统一清理路径： 1. 触发 OnClose 用户事件 2. 清除 SSE 上下文引用 3. 从 Clients 字典移除（防重入） 4. 清理用户/分组映射 5. **`Client.Socket.CloseSck`** 关闭 Socket，触发 cClientCallback 完整清理流程 ### BUG-10: SSE.Data 共享可变状态重入 **原问题**：`Send` 方法使用类级共享 `Data` 字典，`SendData` 可能触发 Winsock 消息泵导致重入。 **修复**：`Send` 编码前将 `Data` 快照到局部 `SendData` Dictionary，然后立即 `Data.RemoveAll`，编码发送使用安全副本。 *** ## 修改文件汇总（全部四轮） | 文件 | R1 | R2 | R3 | R4 | 变更概要 | | ------------------------------------------- | :-: | :-: | :-: | :-: | --------------------------------------------------------------------------------------------------------------------------------- | | `src\Socket\cClientCallback.cls` | ● | | | | Index→hSocket；LastActivity；Release 彻底清理；recvBuffer 缩容 | | `src\HttpServer\cHttpServer.cls` | ● | ● | ● | ● | Collection→Dictionary；6 个安全属性；FindCRLFCRLF -1；cTimer 集成；ReleaseRequest/ClearRequest；Session.HasID；13 处 As New→显式 | | `src\HttpServer\cHttpServerResponse.cls` | ● | ● | | ● | SendData 错误保护；m\_HasSent；State413；Class\_Terminate；1 处 As New→显式 | | `src\HttpServer\cHttpServerContext.cls` | ● | ● | | | ReleaseRequest()；清理循环引用 | | `src\HttpServer\cHttpServerRequest.cls` | ● | ● | | | ClearRequest()；Class\_Terminate | | `src\HttpServer\cHttpServerCookies.cls` | ● | | | ● | 1 处 As New→显式 | | `src\HttpServer\cHttpServerSession.cls` | | | ● | ● | sessionID 不自动生成；HasID；EnsureData 延迟创建；Release()；Class\_Terminate；5 处 As New→显式 | | `src\HttpServer\cHttpServerSvr.cls` | | | ● | | 4 处 As New→显式；Class\_Initialize/Terminate | | `src\HttpServer\cHttpServerRouter.cls` | | | ● | ● | 8 处类级 + 1 处方法级 As New→显式；Class\_Initialize/Terminate | | `src\HttpServer\cHttpServerRouteBefore.cls` | | | ● | | 1 处 As New→显式；Class\_Initialize/Terminate | | `src\HttpServer\cHttpServerRouterAfter.cls` | | | ● | | 1 处 As New→显式；Class\_Initialize/Terminate | | `src\SSE\cSSE.cls` | | | ● | ● | 7 处类级 As New→显式；BUG-9 Entry 失败清理；BUG-15 CloseClient 重构+关 Socket；BUG-10 Send 快照防重入；Class\_Initialize/Terminate | **合计修改 12 个 .cls 文件** *** ## 新增公共 API 汇总（全部四轮） ### cHttpServer 属性/方法 | 属性/方法 | 类型 | 默认值 | 轮次 | 说明 | | -------------------------- | ---------------- | --------------- | :--: | ---------------------------------- | | `MaxConnections` | Long | 1000 | R1 | 最大并发连接数 | | `MaxRequestSize` | Long | 10485760 (10MB) | R1 | 最大请求体字节数，超限断开返回 413 | | `IdleTimeoutSeconds` | Long | 120 | R1 | 空闲连接超时秒数，超时自动关闭 | | `ConnectionCount` | Property Get | - | R1 | 当前活跃连接数（只读） | | `CleanupIdleConnections()` | Sub | - | R1 | 手动清理空闲连接 | | `CleanupExpiredSessions()` | Sub | - | R1 | 手动清理过期 Session | | `CleanupTimerInterval` | Property Get/Let | 30000 (30秒) | R1 | 内置清理定时器间隔（毫秒） | | `State413()` | Sub | - | R1 | 413 Payload Too Large 响应 | ### cHttpServerSession 属性/方法 | 属性/方法 | 类型 | 轮次 | 说明 | | ----------- | ---------------------- | :--: | ---------------------------------------- | | `HasID` | Property Get (Boolean) | R3 | 判断是否已有 sessionID（即有数据被写入） | | `Release()` | Friend Sub | R3 | 显式释放 Data Dictionary，清空 sessionID | ### cHttpServerContext 方法 | 方法 | 轮次 | 说明 | | ------------------ | :--: | --------------------------------------------------------------------- | | `ReleaseRequest()` | R2 | 断开 Response.fClient 循环引用，清理 Request/Response/Cookies/Session | ### cHttpServerRequest 方法 | 方法 | 轮次 | 说明 | | ---------------- | :--: | ----------------------------------------- | | `ClearRequest()` | R2 | RemoveAll 所有 Dictionary、Erase 字节数组 | *** ## 内置定时清理机制 服务器启动后自动创建 `cTimer` 定时器（依赖 `ToolsTimer.bas` 模块），默认每 30 秒触发一次： 1. `CleanupIdleConnections` — 清理超过 `IdleTimeoutSeconds` 的僵尸连接 2. `CleanupExpiredSessions` — 清理过期的 Session `CleanupTimerInterval` 可调整间隔，运行中修改自动重启生效。停止时定时器自动销毁。 *** ## As New 转换完整清单 此为四轮修复中规模最大的系统性改动，消除 VB6 `As New` 隐式自动重建导致对象永远无法真正释放的问题。 ### 类级字段（Round 3） | 文件 | 处数 | | ---------------------------- | ------ | | `cHttpServer.cls` | 9 | | `cSSE.cls` | 7 | | `cHttpServerRouter.cls` | 8 | | `cHttpServerSvr.cls` | 4 | | `cHttpServerSession.cls` | 1 | | `cHttpServerRouteBefore.cls` | 1 | | `cHttpServerRouterAfter.cls` | 1 | | **合计** | **31** | ### 方法级局部变量（Round 4） | 文件 | 处数 | | ------------------------- | ------ | | `cHttpServer.cls` | 4 | | `cHttpServerSession.cls` | 4 | | `cHttpServerResponse.cls` | 1 | | `cHttpServerCookies.cls` | 1 | | `cHttpServerRouter.cls` | 1 | | **合计** | **11** | ### 转换模式 ```vb ' 修复前 Private m_Sessions As New Dictionary Dim Dic As New Dictionary ' 修复后（类级） Private m_Sessions As Dictionary ' Class_Initialize 中 Set = New ' Class_Terminate 中 Set = Nothing ' 修复后（方法级） Dim Dic As Dictionary Set Dic = New Dictionary ``` ### 验证结果 四轮修复后，所有 HttpServer + SSE 共 15 个 .cls 文件中**无代码级 `As New` 残留**（仅注释中保留说明）。 *** ## 性能影响评估 | 修复项 | 性能影响 | 轮次 | | --------------------------- | --------------------------------------------------------- | :--: | | Collection → Dictionary | 查找 O(1)，比 Collection.Item(index) 更快 | R1 | | CleanupIdleConnections | 内置定时器每 30s + 手动，遍历 O(N) | R1 | | 缓冲区缩容 | 仅容量 > 64KB 且使用率 < 25% 时触发 | R1 | | MaxRequestSize 检查 | 每次数据到达一次 Long 比较 O(1) | R1 | | MaxConnections 检查 | Dictionary.Count 读取 O(1) | R1 | | SendData 错误保护 | On Error Resume Next 仅异常时有开销 | R1 | | ReleaseRequest/ClearRequest | 请求末尾显式释放，减少 COM 回收压力 | R2 | | Session.HasID 判断 | 布尔属性读取，O(1) | R3 | | SSE Send 快照 | 复制 Data 到局部 Dict，O(N)（N = Data 条目数，通常 < 10） | R4 | 整体性能影响可忽略不计。 *** ## 遗留问题 | 编号 | 问题 | 状态 | 说明 | | ------ | ------------------------------ | ------ | ----------------------------------------------------------------- | | BUG-11 | Session 清理概率 1% | 已缓解 | cTimer 定时器每 30s 调用 CleanupExpiredSessions，不再依赖随机概率 | | BUG-12 | StopMe 销毁共享对象 | 已缓解 | Round 1 修复 StopMe 不再销毁共享对象，但重启后状态恢复仍需注意 | | BUG-13 | 不支持 chunked 传输编码 | 未修复 | 需实现分块传输解析器，影响面较小 | | BUG-14 | 静态文件缓存不更新 | 未修复 | WebRoot 字典启动时扫描一次，运行时添加文件需重启 | | - | cWinSock.cls Collection.Exists | 未修复 | `m_cClients` 声明为 Collection 但调用 `.Exists()`，运行时必然报错 | *** ## 升级指南 **最低升级要求**: 替换以下 12 个 .cls 文件 ``` src\Socket\cClientCallback.cls src\HttpServer\cHttpServer.cls src\HttpServer\cHttpServerResponse.cls src\HttpServer\cHttpServerContext.cls src\HttpServer\cHttpServerRequest.cls src\HttpServer\cHttpServerCookies.cls src\HttpServer\cHttpServerSession.cls src\HttpServer\cHttpServerSvr.cls src\HttpServer\cHttpServerRouter.cls src\HttpServer\cHttpServerRouteBefore.cls src\HttpServer\cHttpServerRouterAfter.cls src\SSE\cSSE.cls ``` **项目依赖**: cTimer 集成需要 `ToolsTimer.bas` 模块已包含在项目中 **无需修改的部分**: 以下文件经审计无需修改 * `cHttpServerApp.cls` — 空类 * `cHttpServerRouteItem.cls` — 纯简单类型 * `cHttpServerCookieAttr.cls` — 纯简单类型 * `cHttpServerClientInfo.cls` — 纯简单类型 * `cSSEContext.cls` — 已有 Class\_Terminate，无 As New **配置建议**: ```vb ' 启动前配置（推荐生产环境值） Server.MaxConnections = 500 ' 根据内存调整 Server.MaxRequestSize = 5242880 ' 5MB Server.IdleTimeoutSeconds = 60 ' 1 分钟 Server.CleanupTimerInterval = 30000 ' 30 秒（默认值，可不动） ``` *** **修复日期**: 2026-06-13 **修复版本**: v1.0.0.423 **影响版本**: 所有使用 Collection 连接池的历史版本 *** ## 验证结果 **2026-06-13 用户压测验证通过**：四轮修复后，内存泄漏问题已全部消除，HttpServer 可正式用于生产环境。 ![测试泄露全部修复](/assets/1781364048020_d.DsddA1we.png) 定时回收器很健康了，，没有请求的时候，，内存被回收到 3.5MB，将近一半 ![定时回收器很健康了](/assets/recybin.s9Q3e8E5.png) *** ## 四轮修复总览 | 轮次 | 重点 | 修改文件数 | 修复 BUG 数 | | -------- | ----------------------------- | :---------: | :-----------------------------------------: | | Round 1 | 致命/高危 BUG 修复 | 6 | BUG-1~8 | | Round 2 | 内存泄漏显式清理 | 4 | ReleaseRequest/ClearRequest | | Round 3 | Session 累积 + 类级 As New | 7 | Session HasID + 31 处 As New + BUG-9 | | Round 4 | 方法级 As New + SSE BUG-15/10 | 6 | 11 处 As New + BUG-15 + BUG-10 | | **合计** | | **12 文件** | **BUG-1~10, 15（12 个 BUG）+ 42 处 As New** | --- --- url: /en/vbman/httpserver/v1.0.0.423.md --- # 010. HttpServer Production Readiness Fix ## Overview Users reported that the HTTP server crashed or became unresponsive after running for several days. After four rounds of iterative fixes, a total of **3 critical + 5 high + 7 medium = 15 BUGs** were identified. 12 were fixed (BUG-1~10, BUG-15), 2 were mitigated (BUG-11, BUG-12), 1 was not fixed (BUG-13), and 1 was a feature gap (BUG-14). The user's core concern was "HTTP connections cause memory to increase bit by bit, never decreasing, eventually crashing the program." The four rounds of fixes addressed this goal sequentially: fatal crashes → memory leaks → empty session accumulation → As New implicit references → SSE resource residuals. *** ## Problem Overview | ID | Level | Issue | Root Cause | Impact | Status | | ------ | -------- | ----------------------------------------------- | ------------------------------------------------------------ | ------------------------------------- | ---------------------- | | BUG-1 | Critical | Connection pool index drift | Collection.Remove causes subsequent indices to shift forward | Data sent to wrong client, GPF crash | **Fixed** | | BUG-2 | Critical | Zombie connection infinite accumulation | No idle timeout + circular reference chain | Memory continuously grows → OOM | **Fixed** | | BUG-3 | Critical | No request body size limit | No Content-Length cap | Malicious requests exhaust memory | **Fixed** | | BUG-4 | High | recvBuffer never shrinks | Array doesn't release after large request | Long connection hidden memory leak | **Fixed** | | BUG-5 | High | Circular reference chain | cHttpServer↔cClientCallback↔Response mutual references | COM objects never released | **Fixed** | | BUG-6 | High | FindCRLFCRLF returns 0 ambiguity | Position 0 confused with "not found" | Specific requests can never be parsed | **Fixed** | | BUG-7 | High | No maximum connection limit | No server-side protection | Resource exhaustion | **Fixed** | | BUG-8 | High | SendData has no error handling | Sending after disconnect throws exception | Process crash | **Fixed** | | BUG-9 | Medium | SSE.Entry failure doesn't clean connection pool | CloseSck triggered but m\_cConnPool residue remains | Connection pool leak | **Fixed** | | BUG-10 | Medium | SSE.Data shared mutable state | Data corruption on reentry | Data loss | **Fixed** | | BUG-11 | Medium | Session cleanup probability 1% too low | Session accumulation in low traffic | Memory leak | **Mitigated** (cTimer) | | BUG-12 | Medium | StopMe destroys shared objects | Router/SSE/Database set to Nothing | Configuration lost after restart | **Mitigated** | | BUG-13 | Medium | No chunked transfer encoding support | Chunked transfer parsing not implemented | Specific clients hang | Not fixed | | BUG-14 | Medium | Static file cache not updated | WebRoot only scanned at startup | Files added at runtime invisible | Not fixed | | BUG-15 | Medium | SSE CloseClient doesn't close Socket | Only cleans dictionary but doesn't close Socket | Connection residue | **Fixed** | *** ## Round 1: Critical/High BUG Fixes ### BUG-1: Connection Pool Collection Index Drift **Symptom**: After running for a while, data gets sent to the wrong client, or accessing released objects causes GPF crashes. **Root Cause**: `m_cConnPool` uses `Collection` to store connections, with each `cClientCallback.Index` recording its position. When a connection disconnects and `m_cConnPool.Remove Index` is called, all subsequent items' indices shift forward, but `oCallback.Index` retains the old value. ``` Connection pool: [A(1), B(2), C(3), D(4)] B disconnects → Remove 2 Connection pool: [A(1), C(2), D(3)] ← C and D indices changed But C.Index is still 2, D.Index is still 3 If A disconnects Remove 1, C from 2→1, D from 3→2 But C.Index=2, D.Index=3 → m_cConnPool(3) out of bounds or wrong object! ``` **Fix**: `Collection` → `Dictionary`, using `hSocket` as Key. ```vb ' Before fix Private m_cConnPool As New Collection ' Sequential index oCallback.Index = m_cConnPool.Count m_cConnPool.Add oCallback m_cConnPool.Remove Index ' After fix Private m_cConnPool As Dictionary ' hSocket as Key m_cConnPool.Add hSocket, oCallback m_cConnPool.Remove hSocket ``` ### BUG-2: Zombie Connection Infinite Accumulation **Symptom**: HTTP server memory continuously grows after running for days, eventually OOM crash. **Root Cause**: Client disconnects abnormally without sending TCP FIN, so `Socket_CloseSck` event never triggers. Circular reference chain prevents COM reference count from reaching zero: ``` cHttpServer ← m_cConnPool ← cClientCallback ← Parent ──→ cHttpServer cClientCallback ← Context ← Response ← fClient ──→ cClientCallback ``` **Fix**: 1. Added `LastActivity` field, updated on each data arrival 2. Added `IdleTimeoutSeconds` property (default 120 seconds) 3. Added `CleanupIdleConnections()` method, iterates connection pool to release timed-out connections 4. Integrated `cTimer` built-in timer, auto-cleanup every 30 seconds by default ### BUG-3: No Request Body Size Limit **Root Cause**: Server accepts data unconditionally, `AppendToBuffer` continuously `ReDim Preserve` expanding the buffer. **Fix**: 1. Added `MaxRequestSize` property (default 10MB) 2. Check buffer + new data against limit in `OnDataArrival` 3. Check Content-Length against limit in `ContainsCompleteRequest` 4. Added `State413` response ### BUG-4: recvBuffer Never Shrinks **Root Cause**: After processing a large request, `recvBuffer()` array retains its expanded size. **Fix**: In `RemoveFromBuffer`, `Erase recvBuffer` when buffer is empty; when capacity > 64KB and utilization < 1/4, `ReDim Preserve` to shrink. ### BUG-5: Circular Reference Chain **Fix**: `Release()` thoroughly releases all references, `Erase recvBuffer`, resets `hSocket = 0`. `Class_Terminate` calls `StopMe`. ### BUG-6: FindCRLFCRLF Returns 0 Ambiguity **Root Cause**: CRLFCRLF at position 0 returns 0, not found also returns 0. **Fix**: Return `-1` when not found, synchronize `ContainsCompleteRequest` and `ExtractOneRequest`. ### BUG-7: No Maximum Connection Limit **Fix**: Added `MaxConnections` property (default 1000), `Disconnect = True` when exceeded. ### BUG-8: SendData Has No Error Handling **Fix**: `SendBodyByte` and `SendHeader` with `On Error Resume Next`, added `m_HasSent` to prevent duplicate sends. *** ## Round 2: Memory Leak Explicit Cleanup ### Symptoms After Round 1 fixes, stress testing showed memory still growing at ~10MB/s: 10 connections, 900 QPS, memory reached 1.8GB in 339 seconds. ### Root Cause `ProcessHttpRequest` creates ~18+ COM objects per request. After the request completes, only COM reference counting waits for reclamation, which can't keep up at high concurrency: 1. **Response.fClient → oCallback circular reference**: `oCallback → Context → Response → fClient → oCallback` 2. **Request internal large objects not promptly cleaned**: 5 Dictionaries + PathInfoList + byte arrays 3. **VB6 reference count reclamation lags at high frequency**: 900 QPS × 18 objects = 16,200 COM objects/second ### Fix | File | Change | | ------------------------- | --------------------------------------------------------------------------------------------------------------------------------------------- | | `cHttpServer.cls` | Call `Context.ReleaseRequest` + `Request.ClearRequest` before all exit points in ProcessHttpRequest (State413, Options, normal exit, EH) | | `cHttpServerContext.cls` | Added `ReleaseRequest()`: breaks Response.fClient circular reference, cleans Request/Response/Cookies/Session, preserves SSE/UserData/TimeUse | | `cHttpServerRequest.cls` | Added `ClearRequest()`: RemoveAll all Dictionaries, Erase byte arrays; Class\_Terminate for insurance cleanup | | `cHttpServerResponse.cls` | Added Class\_Terminate: Set Client = Nothing, Header.RemoveAll, release JsonInst | ### Cleanup Chain ``` ProcessHttpRequest request processing complete │ ├─ Context.ReleaseRequest() │ ├─ Response.fClient = Nothing ← Break circular reference │ ├─ Request.ClearRequest() ← Clear large objects │ ├─ Set Request = Nothing │ ├─ Set Response = Nothing │ ├─ Cookies.Clear + Set Cookies = Nothing │ ├─ Set Session = Nothing │ └─ UserData.RemoveAll │ └─ Set response = Nothing: Set Request = Nothing ``` *** ## Round 3: Session Accumulation + Class-Level As New Full Fix ### Symptoms After Round 2 fixes, memory leak was approximately 5-10MB/s. ### Root Cause Analysis #### Root Cause 1: Session auto-generates sessionID causing empty session accumulation `cHttpServerSession.sessionID` Property Get auto-generates a GUID when `pvSessionID` is empty. `ProcessHttpRequest` uses `If Session.sessionID <> "" Then` to determine whether to store — every request without cookies triggers generation, the condition is always True, empty sessions are permanently stored in `m_Sessions`. 900 QPS × 60 seconds × 20 minutes = **1,080,000 empty sessions**, approximately 1-2GB. #### Root Cause 2: Class-level `As New` implicit creation prevents explicit release VB6's `Dim X As New ClassName`: `Set X = Nothing` auto-recreates on next access, objects can never be truly destroyed. Impact scope: | File | As New Field Count | | ---------------------------- | ------------------ | | `cHttpServer.cls` | 9 | | `cSSE.cls` | 7 | | `cHttpServerRouter.cls` | 8 | | `cHttpServerSvr.cls` | 4 | | `cHttpServerSession.cls` | 1 | | `cHttpServerRouteBefore.cls` | 1 | | `cHttpServerRouterAfter.cls` | 1 | ### Fix #### Core Fix: Session Accumulation | File | Change | | ------------------------ | -------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------- | | `cHttpServerSession.cls` | sessionID Property Get **no longer auto-generates GUID**, only returns `pvSessionID`; added `HasID` property; Data changed to lazy creation (EnsureData); added `Release()`; added Class\_Terminate | | `cHttpServer.cls` | `If Session.HasID Then` replaces `If Session.sessionID <> "" Then`; explicit cleanup of local variables | #### Class-Level As New Full Conversion All 7 files changed to `As` + Class\_Initialize explicit `Set = New` + Class\_Terminate explicit `Set = Nothing`. Also fixed BUG-9 in cSSE.cls (cleaning up SSE references set when Entry fails). ### Cleanup Chain (Updated) ``` ProcessHttpRequest request processing complete │ ├─ Context.ReleaseRequest() │ ├─ Response.fClient = Nothing │ ├─ Request.ClearRequest() │ ├─ Set Request = Nothing │ ├─ Set Response = Nothing │ ├─ Cookies.Clear + Set Cookies = Nothing │ ├─ Set Session = Nothing │ └─ UserData.RemoveAll │ ├─ Set Session = Nothing ← No longer waiting for Sub exit ├─ Set Cookies = Nothing └─ Set response = Nothing: Set Request = Nothing ``` **Session New Logic**: Only when `Session.HasID = True` will Session be stored in `m_Sessions`, have Cookie written, and be persisted. *** ## Round 4: Method-Level As New + SSE BUG-15/BUG-10 ### Method-Level `As New` Local Variable Full Conversion The previous round fixed class-level fields, but method bodies still had 11 `Dim X As New` instances. The `As New` auto-recreation mechanism can prevent reclamation in exception paths. | File | Count | Specific Changes | | ------------------------- | ----- | --------------------------------------------------------------- | | `cHttpServer.cls` | 4 | CI, keysToClose, keysToRemove, sess → all explicit | | `cHttpServerSession.cls` | 4 | Json, SessionData, DataCopy in Serialize/Deserialize → explicit | | `cHttpServerResponse.cls` | 1 | Dic in Json method → explicit | | `cHttpServerCookies.cls` | 1 | CK in Cookie Property Get → explicit | | `cHttpServerRouter.cls` | 1 | item in Add method → explicit | ### BUG-15: SSE CloseClient Doesn't Close Socket **Original Implementation Issues**: * When called via `hSocket` parameter (most common), only checks existence then GoTo exit — **no cleanup at all** * When called via `ToUser().CloseClient` (GoSub Start path), cleans dictionary but doesn't close Socket **Consequence**: All actively closed SSE clients have Sockets that never close, cClientCallback never releases. **Fix**: Refactored to unified cleanup path: 1. Trigger `OnClose` user event 2. Clear SSE context references 3. Remove from Clients dictionary (prevent reentry) 4. Clean up user/group mappings 5. **`Client.Socket.CloseSck`** closes Socket, triggering cClientCallback complete cleanup flow ### BUG-10: SSE.Data Shared Mutable State Reentry **Original Issue**: `Send` method uses class-level shared `Data` dictionary. `SendData` may trigger Winsock message pump causing reentry. **Fix**: `Send` snapshots `Data` to local `SendData` Dictionary before encoding, then immediately `Data.RemoveAll`. Encoding and sending use the safe copy. *** ## Modified Files Summary (All Four Rounds) | File | R1 | R2 | R3 | R4 | Change Summary | | ------------------------------------------- | :-: | :-: | :-: | :-: | ------------------------------------------------------------------------------------------------------------------------------------------------------------------ | | `src\Socket\cClientCallback.cls` | ● | | | | Index→hSocket; LastActivity; Release thorough cleanup; recvBuffer shrink | | `src\HttpServer\cHttpServer.cls` | ● | ● | ● | ● | Collection→Dictionary; 6 safety properties; FindCRLFCRLF -1; cTimer integration; ReleaseRequest/ClearRequest; Session.HasID; 13 As New→explicit | | `src\HttpServer\cHttpServerResponse.cls` | ● | ● | | ● | SendData error protection; m\_HasSent; State413; Class\_Terminate; 1 As New→explicit | | `src\HttpServer\cHttpServerContext.cls` | ● | ● | | | ReleaseRequest(); break circular references | | `src\HttpServer\cHttpServerRequest.cls` | ● | ● | | | ClearRequest(); Class\_Terminate | | `src\HttpServer\cHttpServerCookies.cls` | ● | | | ● | 1 As New→explicit | | `src\HttpServer\cHttpServerSession.cls` | | | ● | ● | sessionID no auto-generate; HasID; EnsureData lazy creation; Release(); Class\_Terminate; 5 As New→explicit | | `src\HttpServer\cHttpServerSvr.cls` | | | ● | | 4 As New→explicit; Class\_Initialize/Terminate | | `src\HttpServer\cHttpServerRouter.cls` | | | ● | ● | 8 class-level + 1 method-level As New→explicit; Class\_Initialize/Terminate | | `src\HttpServer\cHttpServerRouteBefore.cls` | | | ● | | 1 As New→explicit; Class\_Initialize/Terminate | | `src\HttpServer\cHttpServerRouterAfter.cls` | | | ● | | 1 As New→explicit; Class\_Initialize/Terminate | | `src\SSE\cSSE.cls` | | | ● | ● | 7 class-level As New→explicit; BUG-9 Entry failure cleanup; BUG-15 CloseClient refactor+close Socket; BUG-10 Send snapshot for reentry; Class\_Initialize/Terminate | **Total modified: 12 .cls files** *** ## New Public API Summary (All Four Rounds) ### cHttpServer Properties/Methods | Property/Method | Type | Default | Round | Description | | -------------------------- | ---------------- | --------------- | :---: | --------------------------------------------------------------- | | `MaxConnections` | Long | 1000 | R1 | Max concurrent connections | | `MaxRequestSize` | Long | 10485760 (10MB) | R1 | Max request body bytes, disconnect and return 413 when exceeded | | `IdleTimeoutSeconds` | Long | 120 | R1 | Idle connection timeout seconds, auto-close when exceeded | | `ConnectionCount` | Property Get | - | R1 | Current active connection count (read-only) | | `CleanupIdleConnections()` | Sub | - | R1 | Manually clean up idle connections | | `CleanupExpiredSessions()` | Sub | - | R1 | Manually clean up expired sessions | | `CleanupTimerInterval` | Property Get/Let | 30000 (30s) | R1 | Built-in cleanup timer interval (ms) | | `State413()` | Sub | - | R1 | 413 Payload Too Large response | ### cHttpServerSession Properties/Methods | Property/Method | Type | Round | Description | | --------------- | ---------------------- | :---: | ------------------------------------------------------- | | `HasID` | Property Get (Boolean) | R3 | Check if sessionID exists (i.e., data has been written) | | `Release()` | Friend Sub | R3 | Explicitly release Data Dictionary, clear sessionID | ### cHttpServerContext Methods | Method | Round | Description | | ------------------ | :---: | --------------------------------------------------------------------------------- | | `ReleaseRequest()` | R2 | Break Response.fClient circular reference, clean Request/Response/Cookies/Session | ### cHttpServerRequest Methods | Method | Round | Description | | ---------------- | :---: | --------------------------------------------- | | `ClearRequest()` | R2 | RemoveAll all Dictionaries, Erase byte arrays | *** ## Built-in Timer Cleanup Mechanism After the server starts, a `cTimer` timer is automatically created (depends on `ToolsTimer.bas` module), triggering every 30 seconds by default: 1. `CleanupIdleConnections` — Cleans zombie connections exceeding `IdleTimeoutSeconds` 2. `CleanupExpiredSessions` — Cleans expired sessions `CleanupTimerInterval` can adjust the interval, and changes while running automatically restart the timer. The timer is automatically destroyed on stop. *** ## As New Conversion Complete List This was the largest systematic change across the four rounds of fixes, eliminating the VB6 `As New` implicit auto-recreation that prevents objects from ever being truly released. ### Class-Level Fields (Round 3) | File | Count | | ---------------------------- | ------ | | `cHttpServer.cls` | 9 | | `cSSE.cls` | 7 | | `cHttpServerRouter.cls` | 8 | | `cHttpServerSvr.cls` | 4 | | `cHttpServerSession.cls` | 1 | | `cHttpServerRouteBefore.cls` | 1 | | `cHttpServerRouterAfter.cls` | 1 | | **Total** | **31** | ### Method-Level Local Variables (Round 4) | File | Count | | ------------------------- | ------ | | `cHttpServer.cls` | 4 | | `cHttpServerSession.cls` | 4 | | `cHttpServerResponse.cls` | 1 | | `cHttpServerCookies.cls` | 1 | | `cHttpServerRouter.cls` | 1 | | **Total** | **11** | ### Conversion Pattern ```vb ' Before fix Private m_Sessions As New Dictionary Dim Dic As New Dictionary ' After fix (class-level) Private m_Sessions As Dictionary ' Set = New in Class_Initialize ' Set = Nothing in Class_Terminate ' After fix (method-level) Dim Dic As Dictionary Set Dic = New Dictionary ``` ### Verification Results After four rounds of fixes, all 15 HttpServer + SSE .cls files have **no code-level `As New` remaining** (only preserved in comments for explanation). *** ## Performance Impact Assessment | Fix Item | Performance Impact | Round | | --------------------------- | ----------------------------------------------------------------- | :---: | | Collection → Dictionary | Lookup O(1), faster than Collection.Item(index) | R1 | | CleanupIdleConnections | Built-in timer every 30s + manual, iteration O(N) | R1 | | Buffer shrinking | Only triggers when capacity > 64KB and utilization < 25% | R1 | | MaxRequestSize check | One Long comparison per data arrival O(1) | R1 | | MaxConnections check | Dictionary.Count read O(1) | R1 | | SendData error protection | On Error Resume Next only has overhead on exceptions | R1 | | ReleaseRequest/ClearRequest | Explicit release at request end, reduces COM reclamation pressure | R2 | | Session.HasID check | Boolean property read, O(1) | R3 | | SSE Send snapshot | Copy Data to local Dict, O(N) (N = Data entries, typically < 10) | R4 | Overall performance impact is negligible. *** ## Remaining Issues | ID | Issue | Status | Description | | ------ | ------------------------------------ | --------- | ---------------------------------------------------------------------------------------------------------------- | | BUG-11 | Session cleanup probability 1% | Mitigated | cTimer calls CleanupExpiredSessions every 30s, no longer relies on random probability | | BUG-12 | StopMe destroys shared objects | Mitigated | Round 1 fix: StopMe no longer destroys shared objects, but state restoration after restart still needs attention | | BUG-13 | No chunked transfer encoding support | Not fixed | Need to implement chunked transfer parser, impact is small | | BUG-14 | Static file cache not updated | Not fixed | WebRoot dictionary scanned once at startup, files added at runtime require restart | | - | cWinSock.cls Collection.Exists | Not fixed | `m_cClients` declared as Collection but calls `.Exists()`, will error at runtime | *** ## Upgrade Guide **Minimum upgrade requirement**: Replace the following 12 .cls files ``` src\Socket\cClientCallback.cls src\HttpServer\cHttpServer.cls src\HttpServer\cHttpServerResponse.cls src\HttpServer\cHttpServerContext.cls src\HttpServer\cHttpServerRequest.cls src\HttpServer\cHttpServerCookies.cls src\HttpServer\cHttpServerSession.cls src\HttpServer\cHttpServerSvr.cls src\HttpServer\cHttpServerRouter.cls src\HttpServer\cHttpServerRouteBefore.cls src\HttpServer\cHttpServerRouterAfter.cls src\SSE\cSSE.cls ``` **Project dependency**: cTimer integration requires `ToolsTimer.bas` module to be included in the project **No modification needed**: The following files were audited and require no changes * `cHttpServerApp.cls` — Empty class * `cHttpServerRouteItem.cls` — Pure simple types * `cHttpServerCookieAttr.cls` — Pure simple types * `cHttpServerClientInfo.cls` — Pure simple types * `cSSEContext.cls` — Already has Class\_Terminate, no As New **Configuration recommendations**: ```vb ' Pre-startup configuration (recommended production values) Server.MaxConnections = 500 ' Adjust based on memory Server.MaxRequestSize = 5242880 ' 5MB Server.IdleTimeoutSeconds = 60 ' 1 minute Server.CleanupTimerInterval = 30000 ' 30 seconds (default, can leave unchanged) ``` *** **Fix Date**: 2026-06-13 **Fix Version**: v1.0.0.423 **Affected Versions**: All historical versions using Collection connection pool *** ## Verification Results **2026-06-13 User stress test verification passed**: After four rounds of fixes, all memory leak issues have been eliminated. HttpServer is now ready for production use. ![All leak tests fixed](/assets/1781364048020_d.DsddA1we.png) The timer recycler is healthy now. When there are no requests, memory is reclaimed to 3.5MB, nearly half. ![Timer recycler healthy](/assets/recybin.s9Q3e8E5.png) *** ## Four Rounds Fix Overview | Round | Focus | Files Modified | Bugs Fixed | | --------- | ----------------------------------------- | :------------: | :------------------------------------: | | Round 1 | Critical/High BUG fixes | 6 | BUG-1~8 | | Round 2 | Memory leak explicit cleanup | 4 | ReleaseRequest/ClearRequest | | Round 3 | Session accumulation + class-level As New | 7 | Session HasID + 31 As New + BUG-9 | | Round 4 | Method-level As New + SSE BUG-15/10 | 6 | 11 As New + BUG-15 + BUG-10 | | **Total** | | **12 files** | **BUG-1~10, 15 (12 BUGs) + 42 As New** | --- --- url: /zh/vbman/devlog/AI/2025-05-25-修复cAI.md --- # 2025-05-25 修复 cAI ## Bug 修复 1. **`WithEvents` 声明缺失**：`HttpClient` 和 `SSEClient` 都是 `Dim` 声明，事件处理函数永远不会被触发。改 `SSEClient` 为 `Private WithEvents`，`HttpClient` 改为同步请求中的局部变量。 2. **`ParseStreamChunk` JSON 解析逻辑完全错误**：SSE 返回 `{"choices":[...]}` 是对象格式，代码却检查 `RootIsArray`，导致流式响应永远无法解析。重写为 `ParseStreamJson`，正确从 `RootItem` → `Item("choices")` → 数组元素 → `("delta")` → `("content")` 逐层提取。 3. **系统提示词重复添加**：`BuildRequestBody` 每次调用都往 `m_Messages` 开头插入系统消息，多次 Chat 后系统提示词重复堆积。改用临时 `MsgList` 集合构建请求体，不修改 `m_Messages`。 4. **流式请求架构不可行**：`cHttpClient.Async(True).SendPost` 是假流式（WinHttp 全部接收完才触发事件），无法逐 chunk 回调。改用 `cSSEClient.ConnectPost`，真正逐条解析 SSE 事件。 5. **`SSEClient_OnClose` 双重触发**：`[DONE]` 标记和 `OnClose` 都会触发完成，导致 `OnComplete` 事件重复。改为只在 `m_IsStreaming=True` 时触发完成。 ## 功能增强 6. **新增 `IsStreaming` 属性**：外部可查询流式请求状态。 7. **防重入检查**：`Chat()` 检查 `m_IsStreaming`，防止同时发起多个流式请求。 8. **清理旧连接**：`SendStreamRequest` 先 `Disconnect` 旧 SSE 客户端再创建新的。 --- --- url: /zh/vbman/devlog/HttpClient/2025-05-25-修复cHttpClient.md --- # 2025-05-25 修复 cHttpClient ## Bug 修复 1. **异步 `OnError` 事件未触发**：`Inst_OnError` 只写 `LastError`，没有 `RaiseEvent`，导致上层（cSSEClient）永远收不到错误通知。新增 `Public Event OnError(ErrorNumber, ErrorDescription)` 并在事件中触发。 2. **异步模式无 HTTP 状态码检查**：4xx/5xx 响应在异步模式下静默通过，调用方无感知。现在 `Inst_OnResponseFinished` 中检查状态码，4xx/5xx 触发 `OnError` 而非 `OnResponseFinished`。 3. **`RequestTimeOut < 30` 会修改用户设置值**：原代码直接 `RequestTimeOut = 30`，改用局部变量 `WaitTimeout`，不污染用户设置。 4. **`ParseSetCookie` 用逗号分割错误**：Cookie 的 `Expires` 值含逗号（如 `Thu, 01 Jan 2026`），按逗号分割会误拆。改用 `vbCrLf` 分割（WinHttp 多个 Set-Cookie 用换行分隔）。 5. **`Fetch` 每次不清除上次响应状态**：请求开始时清除 `m_StatusCode`/`m_StatusText`。 ## 功能增强 6. **新增 `StatusCode`/`StatusText` 属性**：异步/同步均可用，不再需要直接访问 `Inst`。 7. **`SetCookies` 实现 Cookie 解析**：支持 `"name=value; name2=value2"` 格式自动解析到 `Cookies` 字典；新增 `BuildCookieHeader()` 从字典构建请求头；请求时自动带上已有 Cookie。 ## 清理 8. **移除废弃的 `RequestDataBody`**：删除声明、初始化（`CompareMode`）、清理（`RemoveAll`）。 --- --- url: /zh/vbman/devlog/SSEClient/2025-05-25-修复cSSEClient.md --- # 2025-05-25 修复 cSSEClient ## Bug 修复 1. **只支持 GET，不支持 POST**：AI 流式聊天等场景需要 POST 请求体。新增 `ConnectPost(Url, Body)` 方法，自动禁用重连。 ## 功能增强 2. **新增 `SetHeader()`/`ClearHeaders()`**：链式调用设置自定义请求头（如 Authorization、Content-Type），在 Connect/ConnectPost 时合并到 HttpClient。 3. **新增 `RequestTimeOut` 属性**：可配置请求超时（默认 60 秒），不再被 cHttpClient 的默认值覆盖。 4. **`Connect()` 改进**：清空 `LastEventData`/`LastEventType` 防止脏数据；合并自定义头；设置超时。 --- --- url: /zh/vbman/devlog/Winsock/2025-05-25-实现封包协议和心跳机制.md --- # 2025-05-25 cWinsock P0/P1 功能实现 ## 变更概述 按照 roadmap 开发计划，分步实现了 P0（封包协议、心跳机制）和 P1（GetData 增强方法）功能。 遵循职责分离原则，将新增功能拆分到独立类文件中。 ## 新增文件 ### cPacketProtocol.cls * 数据封包协议处理器，解决 TCP 分包/粘包问题 * 支持三种内置协议：字符分隔符（ppDelimiter）、定长（ppFixedLength）、长度头（ppLengthHeader） * 每个客户端对象持有独立协议实例，缓冲区相互隔离 * 提供 `Encode`（封包）和 `Decode`（解包）统一接口 * Decode 返回 Collection，支持一次解析出多条完整消息 * 内部自动缓存分片数据，数据完整后才返回 ### cHeartbeat.cls * TCP 智能心跳管理器 * 服务端：超时检测，轮询客户端 LastActivityTime，自动断开僵尸连接 * 客户端：周期性发送心跳包，智能跳过（有数据收发时跳过） * 内嵌 `cTimer` 自动驱动（10秒间隔），无需外部定时器或 PollHeartbeat() * 通过 `Tick` 事件通知 cWinsock 执行心跳逻辑 ## 修改文件 ### cWinSock.cls **新增事件**： * `MessageArrival(Client, bytesTotal)` - 协议解析后的完整消息到达（仅 PacketProtocol 设置时触发） * `ClientTimeout(Client)` - 服务端检测到客户端超时 * `HeartbeatSent(Client)` - 客户端心跳已发送 **新增成员**： * `m_oPacketProtocol As cPacketProtocol` - 协议处理器 * `m_oHeartbeat As cHeartbeat` - 心跳管理器（WithEvents，响应 Tick 事件） **新增属性**： * `PacketHandler` / `PacketProtocol` / `Delimiter` / `FixedLength` / `HeaderBytes` / `HeaderEndian` - 协议配置 * `AutoHeartbeat` / `HeartbeatTimeout` / `HeartbeatInterval` / `HeartbeatData` / `IdleSeconds` - 心跳配置 **新增方法**： * `GetDataText()` / `GetDataTextUTF8()` / `GetDataTextUnicode()` - 返回值型文本获取 * `GetDataHex()` - 返回值型十六进制获取 * `GetDataByteArray()` - 返回值型字节数组获取 * \~~`PollHeartbeat()`~~ → 已移除，改用 `m_oHeartbeat_Tick` 事件自动驱动 **修改方法**： * `SendData` - 当 PacketProtocol 设置时，自动调用 Encode 封包 * `m_oSocket_OnReceive` - 当 PacketProtocol 设置时，自动调用 Decode 解包，触发 MessageArrival 事件 * `m_oSocket_OnSend` - 重置心跳活动时间 * `m_oSocket_OnAccept` - 新客户端自动继承服务器的协议配置，创建独立协议实例 * `Close_` - 清理协议缓冲区和停止心跳 * `Class_Terminate` - 清理协议和心跳对象 ## 架构设计要点 1. **职责分离**：协议解析（cPacketProtocol）、心跳管理（cHeartbeat）独立成类，cWinsock 只负责组合调用 2. **独立实例**：每个 cWinsock 客户端持有独立的协议/心跳实例，多客户端互不干扰 3. **配置继承**：服务端 OnAccept 时新客户端自动继承协议和心跳配置 4. **向后兼容**：不设置协议时行为完全不变，DataArrival 事件照常触发 5. **双事件模型**：协议模式下同时触发 MessageArrival（完整消息）和 DataArrival（向后兼容） 6. **自动心跳**：cHeartbeat 内嵌 cTimer，Enabled=True 即自动运行，无需外部驱动 ## 待完成 * \[ ] P2：性能优化（批量发送、数据压缩、连接池） * \[ ] P3：高级功能（SSL/TLS、WebSocket、断线重连、限流控制） * \[ ] 更新 docs/winsock 文档反映新增 API --- --- url: /zh/vbman/devlog/Winsock/2026-01-26-解决cWinSock常量命名冲突.md --- # 2026-01-26-解决cWinSock常量命名冲突 ## Winsock/cWinSock.cls * `WinsockState` 枚举前缀: `sck` → `wck` * `EnumScpCodePage` 枚举前缀: `Scp` → `wcp` * 更新所有使用这些常量的地方 ## Websocket/cWebSocketServer.cls * `ScpUtf8` → `wcpUtf8` ## Websocket/cWebSocketClient.cls * `ScpUtf8` → `wcpUtf8` ## Redis/cRedisClient.cls * `sckTCPProtocol` → `wskTCPProtocol` * `sckConnected` → `wckConnected` ## 原因 `cWinSock` 的常量名与其他类冲突，修改前缀避免命名冲突。 --- --- url: /zh/vbman/devlog/Winsock/2026-01-26-修复VB6保留字冲突.md --- # 2026-01-26-修复VB6保留字冲突 ## Winsock/cWinSock.cls ### 新增枚举 新增 `WinSocketEventMaskEnum` 枚举,用于同步方法的参数: ```vb Public Enum WinSocketEventMaskEnum wskSfdRead = 2 ^ 0 wskSfdWrite = 2 ^ 1 wskSfdOob = 2 ^ 2 wskSfdAccept = 2 ^ 3 wskSfdConnect = 2 ^ 4 wskSfdClose = 2 ^ 5 wskSfdAll = 2 ^ 6 - 1 [_wskSfdResolve] = 2 ^ 15 [_wskSfdForceRead] = 2 ^ 14 End Enum ``` * 从 `cAsyncSocket` 的 `UcsAsyncSocketEventMaskEnum` 复制 * 枚举成员前缀: `ucsSfd` → `wskSfd` * 用于 `SyncWaitForEvent` 方法的 `EventMask` 参数 cAsyncSocket 已经通过条件编译 #If ImplSync Then 实现了完整的同步方法集: * SyncConnect - 同步连接,带超时 * SyncReceiveText/SyncReceiveArray/SyncReceive - 同步接收 * SyncSendText/SyncSendArray/SyncSend - 同步发送 * SyncWaitForEvent - 等待指定事件 * SyncCancelWait - 取消等待 * SyncProcessMsgQueue - 处理消息队列 这些方法通过底层的 PeekMessage/DispatchMessage 和消息泵机制,不会阻塞UI消息循环。 现在 cWinsock 同时支持异步事件驱动模式和同步阻塞模式,开发者可以根据场景灵活选择使用。 ```vb ' 同步客户端示例 Dim WithEvents ws As New cWinsock Sub TestSyncClient() ' 同步连接 If ws.SyncConnect("example.com", 80, 5000) Then Debug.Print "连接成功!" ' 同步发送请求 Dim sRequest As String sRequest = "GET / HTTP/1.1" & vbCrLf & vbCrLf If ws.SyncSendText(sRequest, 5000) Then Debug.Print "发送成功!" ' 同步接收响应 Dim sResponse As String sResponse = ws.SyncReceiveText(100, 5000, , , wcpUtf8) Debug.Print "收到: " & sResponse End If End If ws.Close_ End Sub ``` --- --- url: /zh/vbman/devlog/Redis/2026-02-19-完善cRedisClient单元测试.md --- # 2026-02-19-完善cRedisClient单元测试 ## src/Redis/cRedisClient.cls ### 问题修复 #### 1. ParamArray 嵌套数组处理 **问题**: DEL/EXISTS 等命令使用 ParamArray 时，Array() 包装导致参数被当作单个字符串传递，而非展开为多个参数。 **解决方案**: 新增 `FlattenArray()` 函数递归展平嵌套数组。 ```vb Private Function FlattenArray(ByVal vInput As Variant) As Variant() ' 递归展平嵌套数组 End Function ``` #### 2. UTF-8 编码支持 **问题**: BuildRedisCommand() 返回的字符串未正确处理 UTF-8 编码，导致中文字符乱码。 **解决方案**: 修改 `BuildRedisCommand()` 直接返回 UTF-8 编码的 Byte() 数组。 ```vb Private Function BuildRedisCommand(ByVal Command As Variant) As Byte() ' 使用 ToolsUtf8.Encode 编码字符串为 UTF-8 baPart = ToolsUtf8.Encode(sPart) End Function ``` #### 3. RESP 协议批量字符串解析 **问题**: ParseResp() 使用 RESP 协议的 UTF-8 字节长度通过 Mid() 截取字符串，但数据已被 ReceiveElement() 解码为 VB6 字符串，导致字符长度与字节长度不匹配。 **解决方案**: 修改 ParseResp() 中的批量字符串解析逻辑，通过查找下一个 \r\n 的位置确定字符串实际长度。 ```vb Case "$" ' 批量字符串 lCrLf = InStr(lPos, Buffer, vbCrLf) lLength = Val(Mid(Buffer, lPos, lCrLf - lPos)) lPos = lCrLf + 2 If lLength = -1 Then ParseResp = Null Else ' 查找下一个 \r\n 确定实际长度 Dim lActualCrLf As Long lActualCrLf = InStr(lPos, Buffer, vbCrLf) ParseResp = Mid(Buffer, lPos, lActualCrLf - lPos) lPos = lActualCrLf + 2 End If ``` ## src/Tools/Demo\_RedisTest.bas ### 新增功能 创建完整的 cRedisClient 单元测试，包含 14 个测试模块： 1. **连接测试** - Connect/Disconnect/PING 2. **基础命令测试** - SET/GET/DEL/EXISTS/KEYS/TTL 3. **String 操作测试** - INCR/DECR/MGET 4. **Hash 操作测试** - HSET/HGET/HMGET/HGETALL/HEXISTS/HDEL 5. **List 操作测试** - LPUSH/RPUSH/LLEN/LRANGE/LPOP/RPOP 6. **Set 操作测试** - SADD/SMEMBERS/SCARD/SISMEMBER/SREM 7. **Sorted Set 操作测试** - ZADD/ZRANGE/ZCARD/ZREM 8. **事务操作测试** - MULTI/EXEC/DISCARD 9. **服务器操作测试** - PING/INFO 10. **数据库切换测试** - SELECT/DbIndex 11. **属性测试** - Host/Port/Connected/Timeout 12. **错误处理测试** - 不存在的键处理 13. **清理测试数据** - 测试后清理 14. **断开连接** - 验证连接状态 ### 测试结果 ✅ 所有 14 个测试模块通过 ✅ 中文内容（张三、北京）正确存储和读取 ✅ Hash 操作（HMGET/HGETALL）正确返回数组 ✅ 所有数据结构操作正常 ✅ 事务、数据库切换等高级功能正常 ## 总结 * 修复了 ParamArray、UTF-8 编码、RESP 协议解析三个核心问题 * 完善了覆盖所有 Redis 数据结构和功能的单元测试 * 验证了 cRedisClient 对中文内容的完整支持 --- --- url: /zh/vbman/devlog/Winsock/2026-06-09-分包协议7项优化修复.md --- # 2026-06-09 分包协议 7 项优化修复 ## 变更概述 对 `cPacketProtocol` 和 `cWinSock` 的分包协议实现进行全面审查，修复 2 个 Bug、1 个安全风险、1 个逻辑缺陷、3 个设计问题。 ## 修复详情 ### 1. 心跳绕过协议编码（严重 Bug） **问题**：心跳数据通过 `m_oSocket.SendArray baHB` 直接发送原始字节，未经 `Encode` 编码。但接收端统一走 `Decode` 解码。若心跳帧恰好在正常消息碎片中间到达，会导致协议状态机混乱（如 `ppLengthHeader` 误将心跳字节当成长度头解析）。 **修复**：`cWinSock.cls` 心跳发送改为 `Me.SendData baHB`，确保心跳数据经过协议编码，收发两端一致。 ### 2. 2 字节长度头 Encode 溢出（严重 Bug） **问题**：VB6 的 `Integer` 是有符号的（-32768~32767），2 字节头实际能表示 0~65535。当 `lDataLen > 32767` 时，`CInt(lDataLen)` 抛出运行时错误。 **修复**：`cPacketProtocol.cls` Encode 方法： * 增加 `lDataLen > 65535` 校验，超限直接 `ERR.Raise` * `lDataLen > 32767` 时映射到 `lDataLen - 65536` 写入 Integer * 大端模式使用 `lDataLen`（Long）计算而非 `nLen`（Integer） ### 3. 大端 4 字节解析溢出（Bug） **问题**：`ParseLengthHeader` 中大端 4 字节解析 `m_baRecvBuffer(0) * &H1000000`，当首字节 >= 128 时结果符号位为 1，变成负数。 **修复**：改用 `(m_baRecvBuffer(0) And &H7F) * &H1000000` 取低 7 位，再用 `Or &H80000000` 恢复最高位。 ### 4. 缺少最大包/缓冲区限制（安全风险） **问题**：原实现中最大包限制 10MB 硬编码、不可配置，非法长度时静默丢弃缓冲区无通知，缓冲区累积无上限（攻击者可发大量不完整包耗尽内存）。 **修复**：`cPacketProtocol.cls` 新增： * `MaxPacketSize` 属性（默认 1MB）— 单包最大大小，超限报错丢弃 * `MaxBufferSize` 属性（默认 4MB）— 缓冲区累积上限，防内存耗尽 * `ExtractLengthHeaderMessages` 中用 `MaxPacketSize` 替代硬编码 10MB * `Decode` 合并缓冲区前检查 `MaxBufferSize` * 超限时抛出明确错误信息而非静默丢弃 `cWinSock.cls` 新增 `MaxPacketSize`/`MaxBufferSize` 代理属性，TCP/UDP 客户端自动继承。 ### 5. UDP 跳过分包协议（功能缺失） **问题**：UDP 模式下收到的数据完全不走 `cPacketProtocol.Decode`，用户设置了 `PacketProtocol` 也不会生效。 **修复**：`cWinSock.cls` `m_oSocket_OnReceive` 中 UDP 分支： * UDP 客户端创建时继承服务端的协议配置（含 MaxPacketSize/MaxBufferSize） * 收到数据报后检查客户端是否启用协议，若启用则 `Decode` 后触发 `MessageArrival` * 无协议时保持原有 `UserData` + `DataArrival` 路径 ### 6. FixedLength 静默截断（设计问题） **问题**：数据超长时直接截断，不报错也不通知，调用方无法知道数据被裁剪。 **修复**：数据超长时直接 `ERR.Raise` 报错，不再静默截断。 ### 7. MessageArrival + DataArrival 双触发（易用性问题） **问题**：分包模式下每条完整消息同时触发两个事件。如果用户同时监听两个事件并都调用 `GetData`，第二次调用会拿到空数据。 **修复**：协议模式下**只触发 `MessageArrival`**，移除了 `DataArrival` 的兼容触发。无协议模式下仍触发 `DataArrival`（向后兼容）。事件注释已更新说明。 ## 修改文件 ### cPacketProtocol.cls | 改动 | 位置 | |------|------| | 新增 `m_lMaxPacketSize` / `m_lMaxBufferSize` 成员变量 | 声明区 | | 新增 `MaxPacketSize` / `MaxBufferSize` 属性 | Properties 区 | | `Class_Initialize` 初始化默认值（1MB / 4MB） | Initialize | | Encode `ppLengthHeader` 增加溢出校验和 Integer 映射 | Encode 方法 | | Encode `ppFixedLength` 超长改为报错 | Encode 方法 | | `ParseLengthHeader` 大端 4 字节无符号解析 | ParseLengthHeader | | `ExtractLengthHeaderMessages` 用 MaxPacketSize 替代硬编码 + 报错 | ExtractLengthHeaderMessages | | `Decode` 合并缓冲区前检查 MaxBufferSize | Decode 方法 | ### cWinSock.cls | 改动 | 位置 | |------|------| | 新增 `MaxPacketSize` / `MaxBufferSize` 代理属性 | Properties 区 | | `MessageArrival` 事件注释更新 | 事件声明 | | 心跳发送改为 `Me.SendData baHB` | m\_oHeartbeat\_Tick | | TCP OnAccept 客户端继承 MaxPacketSize/MaxBufferSize | m\_oSocket\_OnAccept | | UDP 分支支持协议解码 + 继承配置 | m\_oSocket\_OnReceive | | 协议模式移除 DataArrival 双触发 | m\_oSocket\_OnReceive | ### 设计.md 新增"分包协议设计要点"章节，记录协议类型、安全限制属性、事件模型、心跳一致性、UDP 支持等设计决策。 --- --- url: /zh/vbman/devlog/HttpServer/2026-06-09-修复Session和Cookie设计缺陷.md --- # 2026-06-09 修复 Session 和 Cookie 设计缺陷 ## P0 严重问题修复 1. **内存模式 Session 不工作**：原代码每次请求 `Dim Session As New cHttpServerSession` 创建全新对象，无全局存储，请求间数据完全丢失。新增 `m_Sessions As Dictionary` 全局字典，内存模式直接引用存取。 2. **请求/响应 Cookie 混淆**：原 `Cookies.Decode()` 将请求 Cookie 存入 `Data`，`Encode()` 又把所有 Cookie（含请求带入的）回写为 `Set-Cookie`，导致每次请求重发所有 Cookie。拆分为 `m_RequestCookies`（只读，来自浏览器）和 `Data`（响应 Cookie，写回浏览器）。新增 `GetValue(Key)` 读取请求 Cookie，`Cookie(Key)` 仅用于设置响应 Cookie。 3. **首次写入 Session 数据丢失**：原代码仅 `SessionID <> ""` 时才保存，但 `SessionID` 是懒加载的——用户只写 `Session.Item("k")="v"` 而不读 `SessionID` 时，ID 未生成，数据丢失。现 `Item Let/Set` 时自动生成 SessionID。 ## P1 中等问题修复 4. **每次请求都持久化**：新增 `Dirty` 标记，`Item Let/Set`、`Remove`、`Clear`、`Abandon` 时置 True，仅 `Dirty=True` 时才执行文件 I/O 或数据库写入。 5. **Session 过期清理缺失**：新增 `CleanupExpiredSessions` 方法，支持内存/文件/数据库三种模式清理。加载 Session 时发现过期立即删除，同时 `SessionAutoCleanup=True` 时约 1% 概率自动触发清理。 6. **Cookie 删除功能缺失**：新增 `ExpireCookie(Key)` 方法，设置 `Expires = 昨天` 通知浏览器删除指定 Cookie。 ## P2 安全与优化 7. **SameSite 默认值**：Session Cookie 默认设置 `SameSite=Lax`，防止 CSRF。 8. **Session 序列化类型安全**：`Serialize()` 跳过 `IsObject` 类型的值，避免序列化对象引用报错。 9. **SessionID 去花括号**：`GenerateSessionID` 去掉 GUID 的 `{}`，Cookie 值更紧凑。 10. **Clear vs Abandon 语义**：`Clear()` 只清数据保留 SessionID（Cookie 不失效），`Abandon()` 才重新生成 ID 并标记 Dirty。 ## API 变更提示 * 读取请求 Cookie：`ctx.Cookies.GetValue("name")`（不创建响应 Cookie） * 设置响应 Cookie：`ctx.Cookies.Cookie("name").Value = "x"`（同前） * 删除浏览器 Cookie：`ctx.Cookies.ExpireCookie("name")` --- --- url: /zh/vbman/devlog/HttpServer/2026-06-09-增加默认文档支持.md --- # 2026-06-09 增加默认文档支持 + 路由流程重构 ## 路由流程重构：按扩展名分流 原问题：静态文件判断在路由之前，导致目录重定向和默认文档会跳过用户注册的路由（如 `/some/dir` 被重定向到 `/some/dir/`，路由永远匹配不到）。 **解决方案：按路径最后一段是否含点号分流** ``` 请求 /css/style.css → "style.css" 含点号 → 静态文件快速通道（跳过路由） 请求 /api/users → "users" 无点号 → 路由优先通道 请求 /some/dir → "dir" 无点号 → 路由优先通道 请求 / → "" 无点号 → 路由优先通道 ``` **路由优先通道流程：** 1. 前置中间件 2. 匹配用户路由（Dictionary O(1)） 3. 自动路由（CallByName） 4. 静态文件兜底（目录重定向 + 默认文档） 5. 404 **快速通道流程：** 1. IsStaticFile 判断 → 直接 Response.File 2. 不在索引中也尝试直接发送（深层子目录文件） 3. 无 WebRoot 则回退走路由 ## 默认文档功能 1. **默认文档查找**：请求目录路径时按顺序查找 `index.html`、`index.htm`、`default.html`、`default.htm` 2. **目录重定向**：无尾部斜杠的目录请求 302 到带 `/` 的路径 3. **根路径 `/` 支持**：`IsStaticFile("/")` 返回 True 4. **自定义默认文档**：`HttpSvr.AddDefaultDocument("home.html")` 5. **目录无默认文档返回 403** 6. **`Response.Redirect(Url)` 方法**：新增 302 重定向 ## 修改文件 | 文件 | 修改内容 | |------|----------| | `cHttpServerSvr.cls` | 新增 `m_DefaultDocuments`、`AddDefaultDocument`、`GetDefaultDocuments`、`IsStaticFile` 支持 `/` | | `cHttpServerResponse.cls` | `File` 方法增加目录判断+默认文档查找、新增 `Redirect` 方法 | | `cHttpServerRouter.cls` | 按扩展名分流重构整个路由流程 | --- --- url: /zh/vbman/devlog/Winsock/2026-06-09-TCP粘包分包问题与cPacketProtocol解决方案.md --- # 2026-06-09 TCP 粘包/分包问题与 cPacketProtocol 解决方案 ## 问题背景 来自用户反馈（群聊记录）： > "winsock 控件在现场发送大量数据的时候经常发送的不完整，要发好几次可能有一次完整的" > > "之字符格式发送，丢包更严重，后来发送前把字符转为字节再发送，好像效果好点" 这是 TCP 流式协议的典型问题：**TCP 没有消息边界**，数据是作为连续的字节流传输的，不保证一次 Send 对应一次 Receive。 ## 粘包与分包是一体两面 | 现象 | 术语 | 说明 | |------|------|------| | 一次 Send 的数据，分多次 Receive 到达 | **分包（拆包）** | 发了 1000 字节，先收到 300，再收到 700 | | 多次 Send 的数据，一次 Receive 全到 | **粘包** | 连续发了 3 条消息，一次收到拼接在一起的数据 | | 上面两种混合出现 | **最常见** | 收到的数据既不完整又混着下一条的开头 | 用户反馈的"不完整"——每次 `DataArrival` 拿到的数据都不是一条完整消息，**这正是分包问题**。而"要发好几次可能有一次完整的"——说明偶尔凑巧一次收全了，这意味着粘包和分包同时存在。 ### 现象图解 ``` 应用层发送：[Msg1][Msg2][Msg3] ↓ TCP 流式传输（无边界） 接收端可能收到： 情况1（分包）： [Msg1前半] [Msg1后半+Msg2前半] [Msg2后半+Msg3] 情况2（粘包）： [Msg1+Msg2] [Msg3] 情况3（混合）： [Msg1前半] [Msg1后半+Msg2] [Msg3前半] [Msg3后半] 理想情况（少见）：[Msg1] [Msg2] [Msg3] ``` ## cPacketProtocol 解决方案 `cPacketProtocol` 通过在数据中定义明确的边界，将无界的字节流还原为有界的消息： ``` 原始 TCP 字节流（无边界）： [Msg1前半][Msg1后半+Msg2前半][Msg2后半] ↓ cPacketProtocol.Decode() 完整消息： [Msg1 完整] → 触发 MessageArrival [Msg2 完整] → 触发 MessageArrival ``` ### 三种协议对比 | 协议类型 | 原理 | 分包处理 | 粘包处理 | 优缺点 | |----------|------|----------|----------|--------| | `ppLengthHeader` | 头部指明消息体长度 | 长度不够则缓存，等数据到齐再提取 | 长度够了就切一条，剩余继续解析 | **推荐**。不依赖数据内容，不限消息长度 | | `ppDelimiter` | 分隔符标记消息结尾 | 未找到分隔符则缓存 | 找到分隔符就切一条，剩余继续找 | 简单，但分隔符不能出现在消息体中 | | `ppFixedLength` | 每条消息固定长度 | 不足定长则缓存 | 凑够定长就切一条 | 仅适用于定长消息场景 | ### 推荐方案：ppLengthHeader（4 字节小端头） 不依赖数据内容中出现特殊字符（分隔符协议的硬伤），不限制单条消息长度（定长协议的硬伤），每条消息自带长度，接收端精确知道要读多少字节。 ### 使用示例 ```vb '--- 服务端设置 --- server.PacketProtocol = ppLengthHeader server.HeaderBytes = 4 ' 4字节长度头（支持最大4GB） server.HeaderEndian = eeLittleEndian ' 小端序 '--- 客户端设置 --- client.PacketProtocol = ppLengthHeader client.HeaderBytes = 4 client.HeaderEndian = eeLittleEndian '--- 发送：自动加长度头，无需手动处理 --- client.SendData myData '--- 接收：每次一定是完整包 --- Private Sub server_MessageArrival(Client As cWinsock, ByVal bytesTotal As Long) Dim data() As Byte data = Client.GetDataByteArray() ' 100% 是一条完整消息 End Sub ``` ### 安全机制 2026-06-09 同步修复的安全加固： * `MaxPacketSize`（默认 1MB）：单包最大大小，防止恶意超大包声明耗尽内存 * `MaxBufferSize`（默认 4MB）：缓冲区累积上限，防止大量不完整包慢慢吃内存 * 心跳数据也走协议编码，不会污染协议状态机 * UDP 客户端同样支持分包协议 ## 事件模型 | 模式 | 触发事件 | 说明 | |------|----------|------| | 无协议（`ppNone`） | `DataArrival` | 原始字节流，可能不完整或粘连 | | 有协议 | `MessageArrival` | 每次一定是完整的一条消息 | 协议模式下**只触发 `MessageArrival`**，不触发 `DataArrival`，避免同一数据被两个事件重复读取。 ## 总结 TCP 粘包/分包不是 Bug，而是 TCP 流式协议的特性。解决方式就是在应用层定义消息边界——这正是 `cPacketProtocol` 的设计目标。设置 `PacketProtocol` 后，开发者无需关心底层字节流的分合，`MessageArrival` 每次触发的都是一条完整消息。 --- --- url: /zh/vbman/devlog/HttpClient/2026-07-12-修复DLL编译崩溃.md --- # 2026-07-12 修复 cHttpClient 编译 DLL 后 SendPost/SendGet 崩溃 ## 问题现象 cHttpClient 在 VB6 IDE 中以项目引用（联调）方式运行完全正常，但编译为 VBMAN.dll 后，外部项目（csv3）调用 `SendPost`/`SendGet` 时**第一次成功，第二次崩溃**（进程直接终止，无 VB6 错误对话框）。 ## 排查过程 ### 1. 排除二进制兼容性 注册表中发现 VBMAN 类型库有 46 个残留版本（2.0 ~ e0.2），二进制兼容被反复破坏。清理注册表并重新注册后，崩溃依然存在——排除了接口版本不匹配的可能。 ### 2. 排除自定义 Dictionary 类本身 csv3 的 `Form_Load` 中 `Dim a As New Dictionary` + `For Each x In a` 跨 DLL 边界使用 Dictionary 类完全正常，证明 Dictionary 类的暴露和基本功能没有问题。 ### 3. 逐行日志定位 在 `Fetch` 函数中插入文件日志逐步缩小范围： * 崩溃发生在 `For Each x In RequestHeaders.Keys()` 这一行 * 第一次调用正常通过，第二次执行到 `For Each` 时进程崩溃 * 改为 `hdrKeys = .Keys()` + `For idx = 0 To UBound(hdrKeys)` 数组下标迭代后，多次调用均不再崩溃 ### 4. 对比 Scripting.Dictionary 找到根因 | | Scripting.Dictionary | 自定义 Dictionary | |---|---|---| | `Keys()` 返回类型 | `As Variant` | `As Variant()` | | `Items()` 返回类型 | `As Variant` | `As Variant()` | `As Variant` 在 COM 类型库中是 `VARIANT`，SAFEARRAY 包装在 VARIANT 内部，VB6 运行时对其跨 DLL 边界的生命周期管理完善。 `As Variant()` 在 COM 类型库中是 `SAFEARRAY(VARIANT)*`，VB6 把它当原始 SAFEARRAY 指针处理。当 `For Each` 枚举一个**函数返回的临时 SAFEARRAY** 时，VB6 编译后的运行时对该临时数组的引用计数管理存在缺陷——数组可能在枚举过程中被提前释放，导致访问已释放内存而崩溃。第一次碰巧内存尚未被覆盖所以正常，第二次则内存已被重用而崩溃。 ## 根因 **Dictionary.cls 的 `Keys()` 和 `Items()` 返回类型声明为 `As Variant()` 而非 `As Variant`**，与 Scripting.Dictionary 的 COM 签名不一致。 VB6 编译后跨 DLL 边界调用时，`For Each` 枚举 `As Variant()` 函数返回的临时 SAFEARRAY 会触发 VB6 运行时的生命周期管理 bug，导致二次调用崩溃。 IDE 模式下 VB6 运行时内存管理更保守（不释放临时数组），所以联调不会触发。 ## 修复方案 `Dictionary.cls` 中将 `Keys()` 和 `Items()` 的返回类型从 `As Variant()` 改为 `As Variant`，与 Scripting.Dictionary 签名完全一致： ```vb ' 修复前 Public Function Keys() As Variant() Public Function Items() As Variant() ' 修复后 Public Function Keys() As Variant Public Function Items() As Variant ``` cHttpClient.cls 通过 `git checkout` 恢复原版，无需任何改动。 ## 修改文件 | 文件 | 改动 | |------|------| | `src/Collection/Dictionary.cls` | `Keys()` 返回类型 `Variant()` → `Variant`；`Items()` 返回类型 `Variant()` → `Variant` | | `src/HttpClient/cHttpClient.cls` | 无改动（git checkout 恢复） | ## 经验总结 1. **VB6 COM 签名必须与被封装的对象一致**：封装 Scripting.Dictionary 时，公共方法的返回类型要严格匹配原版签名，尤其是涉及数组的返回值。`As Variant` 和 `As Variant()` 在 VB6 源码层面语义相同，但在 COM 类型库中的 marshalling 行为完全不同。 2. **IDE 正常 ≠ 编译正常**：VB6 IDE 的运行时对临时对象的内存管理比编译后更宽容。涉及跨 DLL 边界的 COM 调用，必须用编译后的 DLL 做实际测试。 3. **"第一次正常第二次崩溃"是典型的临时对象生命周期 bug 的特征**：如果遇到这种模式，优先检查函数返回的临时数组/对象是否在跨 DLL 边界时被错误释放。 --- --- url: /zh/emoji/0600-06FF.md --- # 阿拉伯文 (Arabic) 本页面展示了Unicode字符集中，位于U+0600到U+06FF范围的阿拉伯文字符。阿拉伯文是一种从右向左书写的书写系统，广泛用于阿拉伯语和其他使用阿拉伯字母的语言。 | 字符 | Unicode | VB函数值 | 名称 | |:---:|:---:|:---:|:---| | ؀ | U+0600 | ChrW(\&H0600) | 阿拉伯文号码符号 | | ؁ | U+0601 | ChrW(\&H0601) | 阿拉伯文标志SANAH | | ؂ | U+0602 | ChrW(\&H0602) | 阿拉伯文标志FOOTNOTE | | ؃ | U+0603 | ChrW(\&H0603) | 阿拉伯文标志SAFHA | | ؄ | U+0604 | ChrW(\&H0604) | 阿拉伯文标志SAMVAT | | ؅ | U+0605 | ChrW(\&H0605) | 阿拉伯文号码标记 | | ؆ | U+0606 | ChrW(\&H0606) | 阿拉伯文-印度式百分号 | | ؇ | U+0607 | ChrW(\&H0607) | 阿拉伯文-印度式分数分子记号 | | ؈ | U+0608 | ChrW(\&H0608) | 阿拉伯文RAY | | ؉ | U+0609 | ChrW(\&H0609) | 阿拉伯文-印度式每千分号 | --- --- url: /zh/emoji/0750-077F.md --- # 阿拉伯文补充 (Arabic Supplement) 本页面展示了Unicode字符集中，位于U+0750到U+077F范围的阿拉伯文补充字符。这些字符主要用于非阿拉伯语的其他使用阿拉伯字母的语言。 | 字符 | Unicode | VB函数值 | 名称 | |:---:|:---:|:---:|:---| | ݐ | U+0750 | ChrW(\&H0750) | 阿拉伯文字母BEH带三点横线下 | | ݑ | U+0751 | ChrW(\&H0751) | 阿拉伯文字母BEH带三点下和两点上 | | ݒ | U+0752 | ChrW(\&H0752) | 阿拉伯文字母BEH带三点上 | | ݓ | U+0753 | ChrW(\&H0753) | 阿拉伯文字母BEH带三点上和两点下 | | ݔ | U+0754 | ChrW(\&H0754) | 阿拉伯文字母BEH带两点下和点上 | | ݕ | U+0755 | ChrW(\&H0755) | 阿拉伯文字母BEH带倒V形上 | | ݖ | U+0756 | ChrW(\&H0756) | 阿拉伯文字母BEH带小V形 | | ݗ | U+0757 | ChrW(\&H0757) | 阿拉伯文字母HAH带两点上 | | ݘ | U+0758 | ChrW(\&H0758) | 阿拉伯文字母HAH带三点上 | | ݙ | U+0759 | ChrW(\&H0759) | 阿拉伯文字母DAL带垂直两点下 | --- --- url: /zh/emoji/0800-085F.md --- # 阿维斯塔语及巴列维语 (Avestan and Pahlavi) 本页面展示了Unicode字符集中，位于U+0800到U+085F范围的阿维斯塔语和巴列维语字符。阿维斯塔语是古代伊朗的祭祀语言，巴列维语是中古波斯语。 | 字符 | Unicode | VB函数值 | 名称 | |:---:|:---:|:---:|:---| | 𐃀 | U+0800 | ChrW(\&H0800) | 阿维斯塔字母A | | 𐃁 | U+0801 | ChrW(\&H0801) | 阿维斯塔字母AA | | 𐃂 | U+0802 | ChrW(\&H0802) | 阿维斯塔字母AO | | 𐃃 | U+0803 | ChrW(\&H0803) | 阿维斯塔字母AAO | | 𐃄 | U+0804 | ChrW(\&H0804) | 阿维斯塔字母AM | | 𐃅 | U+0805 | ChrW(\&H0805) | 阿维斯塔字母A长音 | | 𐃆 | U+0806 | ChrW(\&H0806) | 阿维斯塔字母E | | 𐃇 | U+0807 | ChrW(\&H0807) | 阿维斯塔字母EE | | 𐃈 | U+0808 | ChrW(\&H0808) | 阿维斯塔字母E长音 | | 𐃉 | U+0809 | ChrW(\&H0809) | 阿维斯塔字母O | --- --- url: /zh/emoji/1200-137F.md --- # 埃塞俄比亚语 (Ethiopic) 本页面展示了Unicode字符集中，位于U+1200到U+137F范围的埃塞俄比亚文字符。埃塞俄比亚文字是非洲之角地区使用的独特字母系统。 | 字符 | Unicode | VB函数值 | 名称 | |:---:|:---:|:---:|:---| | ሀ | U+1200 | ChrW(\&H1200) | 埃塞俄比亚音节文字HA | | ሁ | U+1201 | ChrW(\&H1201) | 埃塞俄比亚音节文字HU | | ሂ | U+1202 | ChrW(\&H1202) | 埃塞俄比亚音节文字HI | | ሃ | U+1203 | ChrW(\&H1203) | 埃塞俄比亚音节文字HAA | | ሄ | U+1204 | ChrW(\&H1204) | 埃塞俄比亚音节文字HEE | | ህ | U+1205 | ChrW(\&H1205) | 埃塞俄比亚音节文字HE | | ሆ | U+1206 | ChrW(\&H1206) | 埃塞俄比亚音节文字HO | | ለ | U+1208 | ChrW(\&H1208) | 埃塞俄比亚音节文字LA | | ሉ | U+1209 | ChrW(\&H1209) | 埃塞俄比亚音节文字LU | | ሊ | U+120A | ChrW(\&H120A) | 埃塞俄比亚音节文字LI | | ላ | U+120B | ChrW(\&H120B) | 埃塞俄比亚音节文字LAA | | ሌ | U+120C | ChrW(\&H120C) | 埃塞俄比亚音节文字LEE | | ል | U+120D | ChrW(\&H120D) | 埃塞俄比亚音节文字LE | | ሎ | U+120E | ChrW(\&H120E) | 埃塞俄比亚音节文字LO | | ሏ | U+120F | ChrW(\&H120F) | 埃塞俄比亚音节文字LWA | | ሐ | U+1210 | ChrW(\&H1210) | 埃塞俄比亚音节文字HHA | | ሑ | U+1211 | ChrW(\&H1211) | 埃塞俄比亚音节文字HHU | | ሒ | U+1212 | ChrW(\&H1212) | 埃塞俄比亚音节文字HHI | | ሓ | U+1213 | ChrW(\&H1213) | 埃塞俄比亚音节文字HHAA | | ሔ | U+1214 | ChrW(\&H1214) | 埃塞俄比亚音节文字HHEE | | ሕ | U+1215 | ChrW(\&H1215) | 埃塞俄比亚音节文字HHE | | ሖ | U+1216 | ChrW(\&H1216) | 埃塞俄比亚音节文字HHO | | ሗ | U+1217 | ChrW(\&H1217) | 埃塞俄比亚音节文字HHWA | --- --- url: /zh/emoji/1380-139F.md --- # 埃塞俄比亚语补充 (Ethiopic Supplement) 本页面展示了Unicode字符集中，位于U+1380到U+139F范围的埃塞俄比亚文补充字符。这些是对基本埃塞俄比亚文字符集的补充。 | 字符 | Unicode | VB函数值 | 名称 | |:---:|:---:|:---:|:---| | ᎀ | U+1380 | ChrW(\&H1380) | 埃塞俄比亚音节文字SEBATBEIT MWA | | ᎁ | U+1381 | ChrW(\&H1381) | 埃塞俄比亚音节文字MWI | | ᎂ | U+1382 | ChrW(\&H1382) | 埃塞俄比亚音节文字MWEE | | ᎃ | U+1383 | ChrW(\&H1383) | 埃塞俄比亚音节文字MWE | | ᎄ | U+1384 | ChrW(\&H1384) | 埃塞俄比亚音节文字SEBATBEIT BWA | | ᎅ | U+1385 | ChrW(\&H1385) | 埃塞俄比亚音节文字BWI | | ᎆ | U+1386 | ChrW(\&H1386) | 埃塞俄比亚音节文字BWEE | | ᎇ | U+1387 | ChrW(\&H1387) | 埃塞俄比亚音节文字BWE | | ᎈ | U+1388 | ChrW(\&H1388) | 埃塞俄比亚音节文字SEBATBEIT FWA | | ᎉ | U+1389 | ChrW(\&H1389) | 埃塞俄比亚音节文字FWI | | ᎊ | U+138A | ChrW(\&H138A) | 埃塞俄比亚音节文字FWEE | | ᎋ | U+138B | ChrW(\&H138B) | 埃塞俄比亚音节文字FWE | | ᎌ | U+138C | ChrW(\&H138C) | 埃塞俄比亚音节文字SEBATBEIT PWA | | ᎍ | U+138D | ChrW(\&H138D) | 埃塞俄比亚音节文字PWI | | ᎎ | U+138E | ChrW(\&H138E) | 埃塞俄比亚音节文字PWEE | | ᎏ | U+138F | ChrW(\&H138F) | 埃塞俄比亚音节文字PWE | | ᎐ | U+1390 | ChrW(\&H1390) | 埃塞俄比亚音节文字SEBATBEIT TSA | | ᎑ | U+1391 | ChrW(\&H1391) | 埃塞俄比亚音节文字TSU | | ᎒ | U+1392 | ChrW(\&H1392) | 埃塞俄比亚音节文字TSI | | ᎓ | U+1393 | ChrW(\&H1393) | 埃塞俄比亚音节文字TSAA | | ᎔ | U+1394 | ChrW(\&H1394) | 埃塞俄比亚音节文字TSEE | | ᎕ | U+1395 | ChrW(\&H1395) | 埃塞俄比亚音节文字TSE | | ᎖ | U+1396 | ChrW(\&H1396) | 埃塞俄比亚音节文字TSO | | ᎗ | U+1397 | ChrW(\&H1397) | 埃塞俄比亚音节文字TSWA | | ᎘ | U+1398 | ChrW(\&H1398) | 埃塞俄比亚音节文字TSWI | | ᎙ | U+1399 | ChrW(\&H1399) | 埃塞俄比亚音节文字TSWEE | | ᎚ | U+139A | ChrW(\&H139A) | 埃塞俄比亚音节文字TSWE | | ᎛ | U+139B | ChrW(\&H139B) | 埃塞俄比亚音节文字SEBATBEIT KYA | | ᎜ | U+139C | ChrW(\&H139C) | 埃塞俄比亚音节文字KYU | | ᎝ | U+139D | ChrW(\&H139D) | 埃塞俄比亚音节文字KYI | | ᎞ | U+139E | ChrW(\&H139E) | 埃塞俄比亚音节文字KYAA | | ᎟ | U+139F | ChrW(\&H139F) | 埃塞俄比亚音节文字KYEE | --- --- url: /zh/vbman/httpserver/security.md --- # 安全实践指南 ## 简介 本文介绍 HttpServer 开发中的安全最佳实践，包括输入验证、SQL 注入防护、XSS 防护、CSRF 防护等。 ## 输入验证 ### 参数校验中间件 ```vb ' cValidationMiddleware.cls Option Explicit Public Sub Entry(ctx As cHttpServerContext) Dim rules As Dictionary Set rules = GetValidationRules(ctx.Request.PathInfo) If Not rules Is Nothing Then Dim field As Variant Dim errors As String errors = "" For Each field In rules.Keys Dim value As String value = ctx.Request(field) ' 必填检查 If rules(field)("required") And value = "" Then errors = errors & field & " 不能为空; " End If ' 类型检查 If rules(field)("type") = "number" And value <> "" Then If Not IsNumeric(value) Then errors = errors & field & " 必须是数字; " End If End If ' 长度检查 If rules(field).Exists("maxLength") Then If Len(value) > rules(field)("maxLength") Then errors = errors & field & " 长度不能超过 " & rules(field)("maxLength") & "; " End If End If Next If errors <> "" Then ctx.Response.State400 "参数错误: " & errors ctx.fIsAbort = True End If End If End Sub Private Function GetValidationRules(path As String) As Dictionary Set GetValidationRules = Nothing Dim rules As New Dictionary Select Case path Case "/api/users/create" Dim userRules As New Dictionary userRules("required") = True userRules("type") = "string" userRules("maxLength") = 50 rules("username") = userRules Dim emailRules As New Dictionary emailRules("required") = True emailRules("type") = "email" rules("email") = emailRules Set GetValidationRules = rules End Select End Function ``` ## SQL 注入防护 ### ❌ 错误示例 ```vb ' 危险！直接拼接 SQL Dim sql As String sql = "SELECT * FROM users WHERE username='" & ctx.Request("username") & "'" ``` ### ✅ 正确做法：参数化查询 ```vb ' 安全：使用参数化查询 If ctx.Db.Sql("SELECT * FROM users WHERE username=?") _ .Param("username", ctx.Request("username"), adVarChar) _ .Fetch Then ' ... End If ``` ### 输入过滤辅助函数 ```vb ' 过滤危险字符 Public Function SqlSafe(input As String) As String Dim result As String result = input result = Replace(result, "'", "''") ' 转义单引号 result = Replace(result, ";", "") ' 移除分号 result = Replace(result, "--", "") ' 移除注释 SqlSafe = result End Function ``` ## XSS 防护 ### HTML 转义输出 ```vb ' cSecurityUtils.bas Public Function HtmlEncode(text As String) As String Dim result As String result = text result = Replace(result, "&", "&") result = Replace(result, "<", "<") result = Replace(result, ">", ">") result = Replace(result, """, """) result = Replace(result, "'", "'") HtmlEncode = result End Function ' 在控制器中使用 Public Sub Search(ctx As cHttpServerContext) Dim keyword As String keyword = ctx.Request.QueryString("q") ' 转义后输出 ctx.Response.Html "

搜索结果: " & HtmlEncode(keyword) & "

" End Sub ``` ### Cookie HttpOnly ```vb ' 设置安全的 Session Cookie With ctx.Cookies.Cookie("SESSIONID") .Value = ctx.Session.SessionID .HttpOnly = True ' 禁止 JavaScript 访问 .Secure = True ' 仅 HTTPS 传输 .SameSite = "Strict" End With ``` ## CSRF 防护 ### Token 验证 ```vb ' cCsrfMiddleware.cls Option Explicit Public Sub Entry(ctx As cHttpServerContext) ' 只验证修改数据的请求 If ctx.Request.Method <> ReqGet And _ ctx.Request.Method <> ReqOptions Then Dim token As String token = ctx.Request.Header("X-CSRF-Token") If token = "" Then token = ctx.Request.Form("_csrf") End If ' 验证 Token If token <> ctx.Session("csrf_token") Then ctx.Response.State403 "CSRF Token 无效" ctx.fIsAbort = True End If End If End Sub ``` ### Token 生成 ```vb ' 登录时生成 CSRF Token Public Sub Login(ctx As cHttpServerContext) ' ... 验证账号密码 ... ' 生成随机 Token ctx.Session("csrf_token") = GenerateRandomToken() ' 返回给客户端 Dim result As New Dictionary result("csrf_token") = ctx.Session("csrf_token") ctx.Response.Json result End Sub Private Function GenerateRandomToken() As String ' 使用 GUID 作为 Token GenerateRandomToken = Replace(ToolsStr.GetGUID(False), "-", "") End Function ``` ## 密码安全 ### 密码哈希 ```vb ' 使用 bcrypt 或类似算法 Public Function HashPassword(password As String) As String ' 实际项目中使用 bcrypt ' 这里演示基础哈希 + 盐 Dim salt As String salt = GenerateSalt() HashPassword = salt & "$" & SHA256(salt & password) End Function Public Function VerifyPassword(password As String, hashed As String) As Boolean Dim parts() As String parts = Split(hashed, "$") If UBound(parts) = 1 Then Dim salt As String salt = parts(0) VerifyPassword = (SHA256(salt & password) = parts(1)) End If End Function ``` ## 请求频率限制 ```vb ' cRateLimitMiddleware.cls (完整版) Option Explicit Dim RequestLog As Dictionary ' IP -> 请求记录 Dim BlockList As Dictionary ' IP -> 解封时间 Private Sub Class_Initialize() Set RequestLog = New Dictionary Set BlockList = New Dictionary End Sub Public Sub Entry(ctx As cHttpServerContext) Dim ip As String ip = ctx.ClientInfo.IP ' 检查是否在黑名单 If BlockList.Exists(ip) Then If Now < BlockList(ip) Then ctx.Response.State403 "IP 已被封禁，请 " & DateDiff("n", Now, BlockList(ip)) & " 分钟后重试" ctx.fIsAbort = True Exit Sub Else BlockList.Remove ip End If End If ' 获取/创建请求记录 If Not RequestLog.Exists(ip) Then Dim record As New Dictionary record("count") = 0 record("startTime") = Now record("urls") = New Dictionary Set RequestLog(ip) = record End If Dim rec As Dictionary Set rec = RequestLog(ip) ' 超过1分钟重置 If DateDiff("n", rec("startTime"), Now) >= 1 Then rec("count") = 0 rec("startTime") = Now Set rec("urls") = New Dictionary End If ' 统计 rec("count") = rec("count") + 1 Dim urls As Dictionary Set urls = rec("urls") urls(ctx.Request.PathInfo) = urls.Exists(ctx.Request.PathInfo) + 1 ' 检查限制 If rec("count") > 100 Then ' 每分钟100次 BlockList(ip) = DateAdd("n", 10, Now) ' 封禁10分钟 ctx.Response.State429 "请求过于频繁，IP 已被封禁" ctx.fIsAbort = True Exit Sub End If ' 单 URL 频率检查 If urls(ctx.Request.PathInfo) > 30 Then ' 单 URL 每分钟30次 BlockList(ip) = DateAdd("n", 5, Now) ctx.Response.State429 "该接口请求过于频繁" ctx.fIsAbort = True End If End Sub ``` ## 安全头部 ```vb ' cSecurityHeadersMiddleware.cls Option Explicit Public Sub Entry(ctx As cHttpServerContext) ' HSTS (强制 HTTPS) ctx.Response.Header("Strict-Transport-Security") = "max-age=31536000; includeSubDomains" ' 防止点击劫持 ctx.Response.Header("X-Frame-Options") = "DENY" ' XSS 防护 ctx.Response.Header("X-Content-Type-Options") = "nosniff" ctx.Response.Header("X-XSS-Protection") = "1; mode=block" ' 内容安全策略 ctx.Response.Header("Content-Security-Policy") = _ "default-src 'self'; " & _ "script-src 'self' 'unsafe-inline'; " & _ "style-src 'self' 'unsafe-inline';" ' 引用策略 ctx.Response.Header("Referrer-Policy") = "strict-origin-when-cross-origin" End Sub ``` ## 日志安全 ```vb ' cSecurityLogMiddleware.cls Option Explicit Public Sub Entry(ctx As cHttpServerContext) ' 记录敏感操作 If IsSensitiveOperation(ctx.Request.PathInfo) Then Dim log As String log = Now & " | " & _ ctx.ClientInfo.IP & " | " & _ ctx.Request.MethodName & " | " & _ ctx.Request.PathInfo & " | " & _ ctx.Session("user_id") Call WriteSecurityLog(log) End If End Sub Private Function IsSensitiveOperation(path As String) As Boolean IsSensitiveOperation = (InStr(path, "/login") > 0 Or _ InStr(path, "/password") > 0 Or _ InStr(path, "/delete") > 0 Or _ InStr(path, "/admin") > 0) End Function Private Sub WriteSecurityLog(msg As String) Dim f As Integer f = FreeFile Open "C:\Logs\security.log" For Append As #f Print #f, msg Close #f End Sub ``` ## 请求体大小限制 ### MaxRequestSize 配置 防止恶意客户端发送超大请求体导致服务器 OOM 崩溃。 ```vb ' 启动前配置 Server.MaxRequestSize = 5242880 ' 5MB ' 超限时自动断开连接并记录日志 ' 客户端收到 413 Payload Too Large 响应 ``` **说明**: 默认 10MB。建议根据业务需要调整： * 纯 API 服务：1-5MB * 支持文件上传：根据最大文件大小设置 ### 最大连接数限制 ```vb Server.MaxConnections = 500 ' 最多同时 500 个连接 ``` **说明**: 默认 1000。超限时新连接被拒绝，触发 `OnLogs` 事件记录 WARN 日志。 *** ## 安全配置检查清单 | 检查项 | 状态 | 说明 | | ---------------- | ---- | ------------------------------------------------------------------- | | HTTPS 强制 | ☐ | 生产环境必须使用 HTTPS | | 参数化查询 | ☐ | 所有数据库操作使用参数化 | | XSS 过滤 | ☐ | 输出内容进行 HTML 编码 | | CSRF Token | ☐ | 修改操作验证 CSRF Token | | HttpOnly Cookie | ☐ | Session Cookie 设置 HttpOnly | | Secure Cookie | ☐ | HTTPS 环境下设置 Secure | | 密码哈希 | ☐ | 使用 bcrypt 等安全算法 | | 频率限制 | ☐ | 限制接口请求频率 | | 安全头部 | ☐ | 添加 X-Frame-Options 等 | | 日志记录 | ☐ | 记录敏感操作和安全事件 | | 请求体大小限制 | ☐ | 配置 MaxRequestSize 防止 OOM | | 连接数限制 | ☐ | 配置 MaxConnections 防止资源耗尽 | | 空闲连接超时 | ☐ | 配置 IdleTimeoutSeconds 清理僵尸连接 | | Session 自动清理 | ☐ | 内置定时器自动清理过期 Session，也可手动调用 CleanupExpiredSessions | | SSE 客户端释放 | ☐ | CloseClient 自动关闭 Socket 并清理所有引用，防止资源泄漏 | *** **最后更新**: 2026-06-13 --- --- url: /zh/emoji/0B00-0B7F.md --- # 奥里亚文 (Oriya) 本页面展示了Unicode字符集中，位于U+0B00到U+0B7F范围的奥里亚文字符。奥里亚文是印度奥里萨邦的官方文字，用于书写奥里亚语。 | 字符 | Unicode | VB函数值 | 名称 | |:---:|:---:|:---:|:---| | ଁ | U+0B01 | ChrW(\&H0B01) | 奥里亚文标记CANDRABINDU | | ং | U+0B02 | ChrW(\&H0B02) | 奥里亚文标记ANUSVARA | | ଃ | U+0B03 | ChrW(\&H0B03) | 奥里亚文标记VISARGA | | ଅ | U+0B05 | ChrW(\&H0B05) | 奥里亚文字母A | | ଆ | U+0B06 | ChrW(\&H0B06) | 奥里亚文字母AA | | ଇ | U+0B07 | ChrW(\&H0B07) | 奥里亚文字母I | | ଈ | U+0B08 | ChrW(\&H0B08) | 奥里亚文字母II | | ଉ | U+0B09 | ChrW(\&H0B09) | 奥里亚文字母U | | ଊ | U+0B0A | ChrW(\&H0B0A) | 奥里亚文字母UU | | ଋ | U+0B0B | ChrW(\&H0B0B) | 奥里亚文字母VOCALIC R | --- --- url: /zh/vbman/database/parameterized.md --- # 参数化查询 本文档详细介绍 cDataBase 类的参数化查询功能，这是防止 SQL 注入攻击的重要安全特性。 *** ## ? 目录 * [参数化查询概述](#参数化查询概述) * [Param 方法](#param-方法) * [ExecParam 方法](#execparam-方法) * [QueryParam 方法](#queryparam-方法) * [FetchParam 方法](#fetchparam-方法) * [ClearParam 方法](#clearparam-方法) * [数据类型](#数据类型) * [安全优势](#安全优势) * [使用示例](#使用示例) * [最佳实践](#最佳实践) *** ## 参数化查询概述 ### 什么是参数化查询 参数化查询是将 SQL 语句和参数值分开处理的技术，参数值通过占位符（通常是 `?`）传递。 ### 为什么使用参数化查询 1. **防止 SQL 注入** - 参数值会被转义，无法执行恶意 SQL 代码 2. **性能优化** - 数据库可以缓存执行计划 3. **类型安全** - 自动处理数据类型转换 4. **代码清晰** - SQL 语句和参数值分离，易于维护 ### SQL 注入示例 ```vb ' ? 危险：直接拼接 SQL（容易 SQL 注入） Dim sName As String sName = "'; DROP TABLE users; --" db.Sql("SELECT * FROM users WHERE name = '" & sName & "'").Query ' 实际执行的 SQL: SELECT * FROM users WHERE name = ''; DROP TABLE users; --' ' 结果：users 表被删除！ ' ? 安全：使用参数化查询 db.Sql("SELECT * FROM users WHERE name = ?") _ .Param("name", sName, adVarWChar) _ .QueryParam ' 参数值会被安全处理，无法执行恶意代码 ``` *** ## Param 方法 ### 语法 ```vb Function Param(ByVal ParamName As String, _ ByVal ParamValue As Variant, _ Optional ByVal ParamType As DataTypeEnum = adVarChar) As cDataBase ``` ### 参数说明 | 参数 | 类型 | 说明 | | ------------ | -------------- | ----------------------------------------- | | `ParamName` | `String` | 参数名称（用于标识，实际使用 `?` 占位符） | | `ParamValue` | `Variant` | 参数值（必需） | | `ParamType` | `DataTypeEnum` | 参数数据类型（可选，默认 `adVarChar`） | ### 返回值 返回 `cDataBase` 对象，支持链式调用。 ### 示例 ```vb ' 添加单个参数 db.Sql("SELECT * FROM users WHERE id = ?") _ .Param("id", 1, adInteger) ' 添加多个参数（链式调用） db.Sql("SELECT * FROM users WHERE name = ? AND age > ?") _ .Param("name", "张三", adVarWChar) _ .Param("age", 18, adInteger) ``` *** ## ExecParam 方法 ### 语法 `ExecParam` 方法执行带参数的 INSERT、UPDATE、DELETE 操作。 ```vb Function ExecParam(Optional RecordsAffected) As Boolean ``` ### 参数说明 | 参数 | 类型 | 说明 | | ----------------- | --------- | ------------------------ | | `RecordsAffected` | `Variant` | 返回受影响的行数（可选） | ### 返回值 * `True` - 执行成功 * `False` - 执行失败（可通过 `LastErr` 查看错误信息） ### 示例 ```vb ' 插入数据 If db.Sql("INSERT INTO users (name, age, email) VALUES (?, ?, ?)") _ .Param("name", "张三", adVarWChar) _ .Param("age", 25, adInteger) _ .Param("email", "zhangsan@example.com", adVarWChar) _ .ExecParam Then Debug.Print "插入成功，ID: " & db.LastInsertId End If ' 更新数据 If db.Sql("UPDATE users SET age = ?, email = ? WHERE id = ?") _ .Param("age", 26, adInteger) _ .Param("email", "newemail@example.com", adVarWChar) _ .Param("id", 1, adInteger) _ .ExecParam Then Debug.Print "更新成功" End If ' 删除数据 If db.Sql("DELETE FROM users WHERE id = ?") _ .Param("id", 1, adInteger) _ .ExecParam Then Debug.Print "删除成功" End If ``` *** ## QueryParam 方法 ### 语法 `QueryParam` 方法执行带参数的 SELECT 查询，结果存储在 `db.Rs` 中。 ```vb Function QueryParam(Optional CurType As CursorTypeEnum = adOpenKeyset, _ Optional LockType As LockTypeEnum = adLockOptimistic) As Boolean ``` ### 参数说明 | 参数 | 类型 | 说明 | | ---------- | ---------------- | ----------------------------------------- | | `CurType` | `CursorTypeEnum` | 游标类型（可选，默认 `adOpenKeyset`） | | `LockType` | `LockTypeEnum` | 锁定类型（可选，默认 `adLockOptimistic`） | ### 返回值 * `True` - 查询成功，结果存储在 `db.Rs` 中 * `False` - 查询失败（可通过 `LastErr` 查看错误信息） **重要**：`QueryParam` 方法返回的是布尔值，不是 Recordset。查询结果需要通过 `db.Rs` 属性访问。 ### 示例 ```vb ' 查询单条记录（使用 db.Rs 访问结果） If db.Sql("SELECT * FROM users WHERE id = ?") _ .Param("id", 1, adInteger) _ .QueryParam Then ' 使用 db.Rs 访问 Recordset If Not db.Rs.EOF Then Debug.Print db.Rs("name") End If db.Rs.Close End If ``` *** ## FetchParam 方法 ### 语法 `FetchParam` 方法执行带参数的 SELECT 查询，并自动将结果转换为 `db.Rows`（cCollection）和 `db.Row`（Dictionary）。**这是参数化查询的主要场景，配合 JSON 输出使用**。 ```vb Function FetchParam(Optional CurType As CursorTypeEnum = adOpenKeyset, _ Optional LockType As LockTypeEnum = adLockOptimistic) As Boolean ``` ### 参数说明 | 参数 | 类型 | 说明 | | ---------- | ---------------- | ----------------------------------------- | | `CurType` | `CursorTypeEnum` | 游标类型（可选，默认 `adOpenKeyset`） | | `LockType` | `LockTypeEnum` | 锁定类型（可选，默认 `adLockOptimistic`） | ### 返回值 * `True` - 查询成功，结果自动转换为 `db.Rows` 和 `db.Row` * `False` - 查询失败（可通过 `LastErr` 查看错误信息） ### 功能 * 内部先调用 `QueryParam` 执行参数化查询 * 然后将 `db.Rs` 自动转换为 `db.Rows`（cCollection）和 `db.Row`（Dictionary） * **可直接用于 JSON 序列化**，配合 `cJson` 和 `cHttpServerResponse` 使用 * 执行完毕后自动清理参数（调用 `ClearParam`） ### 示例 ```vb ' 参数化查询 + 自动转换为 Rows/Row（推荐方式） If db.Sql("SELECT * FROM users WHERE age > ? AND status = ?") _ .Param("age", 18, adInteger) _ .Param("status", "active", adVarWChar) _ .FetchParam Then ' 直接访问 Rows 集合 Dim i As Long For i = 1 To db.Rows.Count Debug.Print db.Rows(i)("name") Next ' 或直接用于 JSON 输出 ctx.Response.Json db.Rows End If ' 查询单条记录 If db.Sql("SELECT * FROM users WHERE id = ?") _ .Param("id", 1, adInteger) _ .FetchParam Then If db.Rows.Count > 0 Then Debug.Print db.Row("name") End If End If ``` *** ## ClearParam 方法 ### 语法 `ClearParam` 方法清理参数化查询的参数和 Command 对象。 ```vb Sub ClearParam() ``` ### 功能 * 清除所有已添加的参数 * 释放 Command 对象 * `ExecParam`、`QueryParam`、`FetchParam` 执行后会**自动调用** `ClearParam` ### 使用场景 ```vb ' 场景 1：手动清理（只调用了 Param 但未执行） db.Sql("SELECT * FROM users WHERE id = ?").Param("id", 1, adInteger) ' 决定不执行此查询，需要手动清理 db.ClearParam ' 场景 2：正常执行后无需手动清理（自动完成） If db.Sql("INSERT INTO users (name) VALUES (?)") _ .Param("name", "张三", adVarWChar) _ .ExecParam Then ' ExecParam 已自动清理参数，无需手动调用 ClearParam End If ``` *** ## 数据类型 ### AdoDataType 枚举 cDataBase 类定义了 `AdoDataType` 枚举，引用 VBMAN 后这些枚举值**全局可用，无需 `VBMAN.` 前缀**（直接写 `adVarWChar` 即可）。这些值与 ADO 的 `DataTypeEnum` 完全一致。 #### 完整枚举定义 ```vb Public Enum AdoDataType adEmpty = 0 ' 空 adTinyInt = 16 ' 8 位有符号整数 adSmallInt = 2 ' 16 位有符号整数 adInteger = 3 ' 32 位有符号整数 adBigInt = 20 ' 64 位有符号整数 adUnsignedTinyInt = 17 ' 8 位无符号整数 adUnsignedSmallInt = 18 ' 16 位无符号整数 adUnsignedInt = 19 ' 32 位无符号整数 adUnsignedBigInt = 21 ' 64 位无符号整数 adSingle = 4 ' 单精度浮点数 adDouble = 5 ' 双精度浮点数 adCurrency = 6 ' 货币类型 adDecimal = 14 ' 精确数值 adBoolean = 11 ' 布尔值 adDate = 7 ' 日期时间 adDBDate = 133 ' 日期（数据库格式） adDBTime = 134 ' 时间（数据库格式） adDBTimeStamp = 135 ' 时间戳（数据库格式） adVarChar = 200 ' ANSI 可变长度字符串 adLongVarChar = 201 ' ANSI 长可变长度字符串 adVarWChar = 202 ' Unicode 可变长度字符串 adLongVarWChar = 203 ' Unicode 长可变长度字符串 adBinary = 128 ' 二进制数据 adVarBinary = 204 ' 可变长度二进制数据 adLongVarBinary = 205 ' 长可变长度二进制数据 adGUID = 72 ' GUID End Enum ``` #### 常用数据类型 | 类型 | 值 | 说明 | 示例 | | ------------ | --- | -------------- | ---------- | | `adVarChar` | 200 | 可变长度字符串 | "张三" | | `adVarWChar` | 202 | Unicode 字符串 | "张三" | | `adInteger` | 3 | 32 位整数 | 25 | | `adBigInt` | 20 | 64 位整数 | 1234567890 | | `adDouble` | 5 | 双精度浮点数 | 3.14 | | `adDate` | 7 | 日期时间 | Now | | `adBoolean` | 11 | 布尔值 | True | | `adDecimal` | 14 | 精确数值 | 99.99 | ### 数据类型选择 ```vb ' 字符串 db.Param("name", "张三", adVarWChar) ' Unicode 字符串（推荐） db.Param("name", "张三", adVarChar) ' ANSI 字符串 ' 整数 db.Param("age", 25, adInteger) ' 32 位整数 db.Param("id", 1234567890, adBigInt) ' 64 位整数 ' 浮点数 db.Param("price", 99.99, adDouble) ' 双精度 db.Param("amount", 99.99, adDecimal) ' 精确数值 ' 日期时间 db.Param("created", Now, adDate) ' 日期时间 ' 布尔值 db.Param("active", True, adBoolean) ' 布尔值 ``` *** ## 安全优势 ### SQL 注入防护 ```vb ' ? 危险：直接拼接 Dim sInput As String sInput = "'; DROP TABLE users; --" db.Sql("SELECT * FROM users WHERE name = '" & sInput & "'").Query ' 结果：users 表被删除 ' ? 安全：参数化查询 db.Sql("SELECT * FROM users WHERE name = ?") _ .Param("name", sInput, adVarWChar) _ .QueryParam ' 参数值被安全处理，无法执行恶意代码 ``` ### 特殊字符处理 ```vb ' ? 危险：特殊字符可能导致错误 Dim sName As String sName = "O'Brien" db.Sql("SELECT * FROM users WHERE name = '" & sName & "'").Query ' SQL: SELECT * FROM users WHERE name = 'O'Brien' ' 错误：单引号未转义 ' ? 安全：参数化查询自动处理 db.Sql("SELECT * FROM users WHERE name = ?") _ .Param("name", sName, adVarWChar) _ .QueryParam ' 特殊字符被自动转义 ``` *** ## 使用示例 ### 示例 1：用户登录 ```vb Function UserLogin(sUsername As String, sPassword As String) As Boolean ' 使用参数化查询防止 SQL 注入 If db.Sql("SELECT * FROM users WHERE username = ? AND password = ?") _ .Param("username", sUsername, adVarWChar) _ .Param("password", sPassword, adVarWChar) _ .QueryParam Then If db.Rows.Count > 0 Then UserLogin = True Else UserLogin = False End If Else UserLogin = False End If End Function ``` ### 示例 2：搜索功能 ```vb Function SearchUsers(sKeyword As String) As Collection Set SearchUsers = New Collection ' 使用 LIKE 和参数化查询 Dim sSql As String sSql = "SELECT * FROM users WHERE name LIKE ? OR email LIKE ?" If db.Sql(sSql) _ .Param("name", "%" & sKeyword & "%", adVarWChar) _ .Param("email", "%" & sKeyword & "%", adVarWChar) _ .QueryParam Then Set SearchUsers = db.Rows End If End Function ``` ### 示例 3：批量插入 ```vb Sub BatchInsertUsers(colUsers As Collection) db.TransBegin Dim i As Long For i = 1 To colUsers.Count Dim dictUser As Dictionary Set dictUser = colUsers(i) If Not db.Sql("INSERT INTO users (name, age, email) VALUES (?, ?, ?)") _ .Param("name", dictUser("name"), adVarWChar) _ .Param("age", dictUser("age"), adInteger) _ .Param("email", dictUser("email"), adVarWChar) _ .ExecParam Then db.TransRollback Exit Sub End If Next db.TransCommit End Sub ``` ### 示例 4：动态查询 ```vb Function GetUsers(Optional sName As String = "", _ Optional lMinAge As Long = 0, _ Optional sStatus As String = "") As Collection Set GetUsers = New Collection Dim sSql As String sSql = "SELECT * FROM users WHERE 1=1" ' 动态构建 SQL 和参数 If sName <> "" Then sSql = sSql & " AND name LIKE ?" End If If lMinAge > 0 Then sSql = sSql & " AND age >= ?" End If If sStatus <> "" Then sSql = sSql & " AND status = ?" End If ' 设置 SQL db.Sql(sSql) ' 添加参数 If sName <> "" Then db.Param("name", "%" & sName & "%", adVarWChar) End If If lMinAge > 0 Then db.Param("age", lMinAge, adInteger) End If If sStatus <> "" Then db.Param("status", sStatus, adVarWChar) End If ' 执行查询 If db.QueryParam Then Set GetUsers = db.Rows End If End Function ``` *** ## 最佳实践 ### 1. 始终使用参数化查询处理用户输入 ```vb ' ? 推荐：使用参数化查询 db.Sql("SELECT * FROM users WHERE name = ?") _ .Param("name", txtName.Text, adVarWChar) _ .QueryParam ' ? 不推荐：直接拼接用户输入 db.Sql("SELECT * FROM users WHERE name = '" & txtName.Text & "'").Query ``` ### 2. 选择正确的数据类型 ```vb ' ? 推荐：明确指定数据类型 db.Param("age", 25, adInteger) db.Param("name", "张三", adVarWChar) db.Param("price", 99.99, adDecimal) ' ? 不推荐：使用默认类型（可能类型不匹配） db.Param("age", 25) ' 默认 adVarChar，可能出错 ``` ### 3. 使用 Unicode 字符串类型 ```vb ' ? 推荐：使用 adVarWChar 支持中文 db.Param("name", "张三", adVarWChar) ' ? 不推荐：使用 adVarChar（可能中文乱码） db.Param("name", "张三", adVarChar) ``` ### 4. 参数顺序要与 SQL 中的占位符顺序一致 ```vb ' ? 正确：参数顺序与 ? 顺序一致 db.Sql("SELECT * FROM users WHERE name = ? AND age > ?") _ .Param("name", "张三", adVarWChar) _ .Param("age", 18, adInteger) ' ? 错误：参数顺序错误 db.Sql("SELECT * FROM users WHERE name = ? AND age > ?") _ .Param("age", 18, adInteger) _ .Param("name", "张三", adVarWChar) ``` ### 5. 清理参数 ```vb ' 注意：ExecParam、QueryParam、FetchParam 会自动清理参数（调用 ClearParam） ' 如果只调用 Param 而不执行，需要手动调用 ClearParam 清理： db.ClearParam ``` *** ## 常见问题 ### Q1: 参数化查询比直接拼接慢吗？ **回答**: 不会，参数化查询通常更快，因为： * 数据库可以缓存执行计划 * 减少了 SQL 解析时间 * 避免了字符串拼接开销 ### Q2: 如何在 LIKE 查询中使用参数？ ```vb ' ? 正确：在参数值中包含通配符 db.Sql("SELECT * FROM users WHERE name LIKE ?") _ .Param("name", "%" & sKeyword & "%", adVarWChar) _ .QueryParam ' ? 错误：在 SQL 中使用通配符 db.Sql("SELECT * FROM users WHERE name LIKE '%?%'") _ .Param("name", sKeyword, adVarWChar) _ .QueryParam ``` ### Q3: 如何处理 NULL 值？ ```vb ' 使用 Null 值 db.Sql("SELECT * FROM users WHERE email = ?") _ .Param("email", Null, adVarWChar) _ .QueryParam ' 或者使用 IS NULL db.Sql("SELECT * FROM users WHERE email IS NULL").Query ``` ### Q4: 参数化查询支持 IN 子句吗？ ```vb ' 注意：ADO 参数化查询对 IN 子句支持有限 ' 建议：使用多个 OR 条件或动态构建 SQL ' 方法 1：使用多个 OR db.Sql("SELECT * FROM users WHERE id = ? OR id = ? OR id = ?") _ .Param("id1", 1, adInteger) _ .Param("id2", 2, adInteger) _ .Param("id3", 3, adInteger) _ .QueryParam ' 方法 2：动态构建（需要验证输入） Dim sIds As String sIds = "1,2,3" ' 需要验证格式 db.Sql("SELECT * FROM users WHERE id IN (" & sIds & ")").Query ``` *** **最后更新**: 2026-01-21 --- --- url: /zh/vbman/httpserver/route-params.md --- # 参数路由与路径段解析 ## 简介 从 v1.0.0.420 起，HttpServer 新增了两个重要特性： * **参数路由** — 在 URL 路径中使用 `{param}` 语法定义动态参数段，类似 Laravel、Express 等现代框架 * **PathInfoList** — 将 URL 路径按 `/` 分割为可按索引/按键访问的集合对象 两者配合使用，可以轻松构建 RESTful 风格的 API。 *** ## 一、参数路由 ### 1.1 基本用法 在路由注册时，使用 `{参数名}` 标记动态段： ```vb ' 单参数路由 Call Server.Router.Add("/api/user/{id}", "UserController@Show", OnlyGet) ' 多参数路由 Call Server.Router.Add("/api/user/{userId}/post/{postId}", "PostController@Show", OnlyGet) ' 嵌套资源路由 Call Server.Router.Add("/api/group/{groupId}/user/{userId}", "GroupCtrl@Detail", OnlyGet) ``` ### 1.2 控制器中获取参数 通过 `ctx.Request.RouteParams` 字典获取匹配到的参数值： ```vb ' 单参数示例：GET /api/user/123 Public Sub Show(ctx As cHttpServerContext) Dim userId As String userId = ctx.Request.RouteParams("id") ' 值为 "123" ctx.Response.Json Array("userId" & userId) End Sub ' 多参数示例：GET /api/user/456/post/789 Public Sub ShowPost(ctx As cHttpServerContext) Dim userId As String, postId As String userId = ctx.Request.RouteParams("userId") ' 值为 "456" postId = ctx.Request.RouteParams("postId") ' 值为 "789" ctx.Response.Json Array(userId, postId) End Sub ``` ### 1.3 RouteParams 属性 ```vb Public RouteParams As New Dictionary ``` | 操作 | 用法 | 说明 | | -------- | -------------------------------------- | -------------------- | | 获取参数 | `ctx.Request.RouteParams("id")` | 返回参数值字符串 | | 检查存在 | `ctx.Request.RouteParams.Exists("id")` | 返回 Boolean | | 参数数量 | `ctx.Request.RouteParams.Count` | 未匹配参数路由时为 0 | | 遍历参数 | `For Each k In RouteParams.Keys` | 遍历所有参数名 | > 注意：如果没有匹配参数路由，`RouteParams` 为空字典（Count = 0）。 ### 1.4 匹配规则 | 规则 | 说明 | 示例 | | --------------- | -------------------------- | ---------------------------------------------------------- | | 参数段 `{name}` | 匹配任意非空字符串 | `/api/user/{id}` 匹配 `/api/user/123` | | 固定段 | 必须精确匹配（忽略大小写） | `/api/user/{id}` 中 `api` 和 `user` 是固定段 | | 段数一致 | 路径段数必须与模式段数相同 | `/api/user/{id}` 是3段，不匹配 `/api/user/123/edit`（4段） | | 参数非空 | 参数段不能匹配空值 | `/api/user/` 不匹配 `/api/user/{id}` | **匹配示例**： | 路由模式 | 请求路径 | 匹配结果 | RouteParams | | ---------------------------------- | ------------------------ | --------------- | ------------------------------------ | | `/api/user/{id}` | `/api/user/123` | ✅ | `{"id": "123"}` | | `/api/user/{id}` | `/api/user/abc` | ✅ | `{"id": "abc"}` | | `/api/user/{id}` | `/api/user/` | ❌ 段数不一致 | — | | `/api/user/{id}` | `/api/users/123` | ❌ 固定段不匹配 | — | | `/api/user/{userId}/post/{postId}` | `/api/user/456/post/789` | ✅ | `{"userId": "456", "postId": "789"}` | ### 1.5 匹配优先级 路由匹配按以下优先级执行： 1. **精确匹配** — O(1) 字典查找，性能最高。如 `/api/users` 直接命中 2. **ANY 精确匹配** — 在 ANY 方法字典中查找 3. **参数路由匹配** — 遍历含 `{param}` 的路由项，逐段模式匹配 > 精确路由永远优先于参数路由，不会因为参数通配而误匹配。 ```vb ' 同时注册精确路由和参数路由 Call Server.Router.Add("/api/user/me", "User@Me", OnlyGet) ' 精确匹配优先 Call Server.Router.Add("/api/user/{id}", "User@Show", OnlyGet) ' 参数路由次之 ' GET /api/user/me → 命中精确路由，调用 User@Me ' GET /api/user/123 → 命中参数路由，RouteParams("id") = "123" ``` ### 1.6 参数路由 vs 查询参数 | 对比项 | 参数路由 | 查询参数 | | ------------ | ------------------------------- | ------------------------------- | | URL 格式 | `/api/user/123` | `/api/user?id=123` | | 获取方式 | `ctx.Request.RouteParams("id")` | `ctx.Request.QueryString("id")` | | RESTful 风格 | ✅ 符合 | ❌ 不符合 | | SEO 友好 | ✅ 更友好 | 一般 | | 可选参数 | 段数必须一致 | 天然可选 | | 适用场景 | 资源标识、层级路径 | 筛选、分页、排序 | 两者可以组合使用： ```vb ' GET /api/user/123/posts?page=2&limit=10 Call Server.Router.Add("/api/user/{id}/posts", "Post@List", OnlyGet) Public Sub List(ctx As cHttpServerContext) Dim userId As String: userId = ctx.Request.RouteParams("id") Dim page As String: page = ctx.Request.QueryString("page") Dim limit As String: limit = ctx.Request.QueryString("limit") End Sub ``` ### 1.7 完整 RESTful API 示例 ```vb ' 注册控制器 Call Server.Router.Reg("Product", New cProductController) ' 列表：GET /products Call Server.Router.Add("/products", "Product@List", OnlyGet) ' 详情：GET /products/123 Call Server.Router.Add("/products/{id}", "Product@Detail", OnlyGet) ' 创建：POST /products Call Server.Router.Add("/products", "Product@Create", OnlyPost) ' 更新：PUT /products/123 Call Server.Router.Add("/products/{id}", "Product@Update", OnlyPut) ' 删除：DELETE /products/123 Call Server.Router.Add("/products/{id}", "Product@Delete", OnlyDelete) ' 子资源：GET /products/123/reviews Call Server.Router.Add("/products/{id}/reviews", "Product@Reviews", OnlyGet) ' 子资源详情：GET /products/123/reviews/456 Call Server.Router.Add("/products/{productId}/reviews/{reviewId}", "Product@ReviewDetail", OnlyGet) ``` ### 1.8 内部实现 参数路由由 `cHttpServerRouteItem` 类实现，核心机制： 1. **注册时**：调用 `Init` 方法，将路由模式拆分为路径段数组，提取 `{param}` 参数名 2. **匹配时**：调用 `Match` 方法，逐段比对——固定段忽略大小写精确匹配，参数段匹配任意非空值 3. **参数提取**：匹配成功后，参数名和值写入 `Request.RouteParams` 字典 ``` 路由模式: /api/user/{id}/post/{postId} ↓ Init() 拆分 段数组: ["api", "user", "{id}", "post", "{postId}"] 参数名: ["id", "postId"] 请求路径: /api/user/123/post/456 ↓ Match() 逐段匹配 "api" = "api" ✅ 固定段匹配 "user" = "user" ✅ 固定段匹配 "{id}" = "123" ✅ 参数段 → RouteParams("id") = "123" "post" = "post" ✅ 固定段匹配 "{postId}" = "456" ✅ 参数段 → RouteParams("postId") = "456" ``` *** ## 二、PathInfoList 路径段集合 ### 2.1 简介 `PathInfoList` 是 `cCollection` 类型的集合对象，在请求解析时自动将 URL 路径按 `/` 分割，每一段存入集合，**键和值都是段名**，支持按索引和按键访问。 ```vb Public PathInfoList As New cCollection ``` ### 2.2 使用示例 ```vb ' 请求：GET /api/user/list?page=1 ' ── 按索引访问（1-based） ── MsgBox ctx.Request.PathInfoList(1) ' → "api" MsgBox ctx.Request.PathInfoList(2) ' → "user" MsgBox ctx.Request.PathInfoList(3) ' → "list" ' ── 获取路径段数 ── MsgBox ctx.Request.PathInfoList.Count ' → 3 ' ── 按键访问（键=值=段名） ── MsgBox ctx.Request.PathInfoList("api") ' → "api" ' ── 判断路径中是否包含某段 ── If ctx.Request.PathInfoList.Exists("api") Then Debug.Print "路径包含 api 段" End If ' ── 遍历所有路径段 ── Dim i As Long For i = 1 To ctx.Request.PathInfoList.Count Debug.Print "段" & i & ": " & ctx.Request.PathInfoList(i) Next i ``` ### 2.3 常见路径的 PathInfoList | 请求路径 | PathInfoList.Count | PathInfoList(1) | PathInfoList(2) | PathInfoList(3) | | ---------------- | ------------------ | --------------- | --------------- | --------------- | | `/` | 0 | — | — | — | | `/api` | 1 | `"api"` | — | — | | `/api/user` | 2 | `"api"` | `"user"` | — | | `/api/user/list` | 3 | `"api"` | `"user"` | `"list"` | | `/api/user/123` | 3 | `"api"` | `"user"` | `"123"` | ### 2.4 典型应用场景 ```vb ' 判断是否是 API 请求 If ctx.Request.PathInfoList.Count > 0 Then If ctx.Request.PathInfoList(1) = "api" Then ' 处理 API 请求 End If End If ' 获取路径中的资源 ID（配合参数路由更佳） If ctx.Request.PathInfoList.Count >= 3 Then If ctx.Request.PathInfoList(2) = "user" Then Dim userId As String userId = ctx.Request.PathInfoList(3) ' 如 "123" End If End If ' 建议优先使用参数路由获取 ID： ' userId = ctx.Request.RouteParams("id") ``` > **提示**：对于获取路径中的动态参数（如用户ID），建议优先使用参数路由的 `RouteParams`，语义更清晰且类型安全。 *** ## 三、新增文件清单 | 文件 | 类型 | 说明 | | -------------------------- | ---- | ---------------------------------------------------------------- | | `cHttpServerRouteItem.cls` | 新增 | 路由项类：解析 `{param}` 模式、匹配路径、提取参数 | | `cHttpServerRouter.cls` | 修改 | 路由匹配逻辑：精确匹配优先，参数路由次之 | | `cHttpServerRequest.cls` | 修改 | 新增 `RouteParams`（Dictionary）和 `PathInfoList`（cCollection） | > 100% 向后兼容——已有的精确路由注册和匹配不受任何影响。 *** **最后更新**: 2026-06-11 --- --- url: /zh/vbman/database/query.md --- # 查询操作 本文档详细介绍 cDataBase 类的查询功能，包括基本查询、结果集处理等。 *** ## ? 目录 * [基本查询](#基本查询) * [查询方法](#查询方法) * [结果集处理](#结果集处理) * [查询选项](#查询选项) * [常见查询场景](#常见查询场景) * [参数化查询方法](#参数化查询方法) *** ## 基本查询 ### Sql 方法 `Sql` 方法用于设置 SQL 查询语句。 #### 语法 ```vb Function Sql(ByVal RawSqlString As String) As cDataBase ``` #### 示例 ```vb ' 设置 SQL 语句 db.Sql("SELECT * FROM users WHERE age > 18") ``` ### Query 方法 `Query` 方法执行查询并返回布尔值。**查询结果存储在 `db.Rs` 属性中，而不是作为返回值**。 #### 语法 ```vb Function Query(Optional CurType As CursorTypeEnum = adOpenKeyset, _ Optional LockType As LockTypeEnum = adLockOptimistic, _ Optional Options As Long = -1) As Boolean ``` #### 参数说明 | 参数 | 类型 | 说明 | | ---------- | ---------------- | ----------------------------------------- | | `CurType` | `CursorTypeEnum` | 游标类型（可选，默认 `adOpenKeyset`） | | `LockType` | `LockTypeEnum` | 锁定类型（可选，默认 `adLockOptimistic`） | | `Options` | `Long` | 查询选项（可选，默认 -1） | #### 返回值 * `True` - 查询成功，结果存储在 `db.Rs` 中 * `False` - 查询失败（可通过 `LastErr` 查看错误信息） **重要**：`Query` 方法返回的是布尔值，不是 Recordset。查询结果需要通过 `db.Rs` 属性访问。 #### 示例 ```vb ' 基本查询 If db.Sql("SELECT * FROM users").Query Then ' 查询成功，使用 db.Rs 访问 Recordset（不是返回值） Do Until db.Rs.EOF Debug.Print db.Rs("name") db.Rs.MoveNext Loop ' 使用完毕后关闭 Recordset db.Rs.Close End If ' ? 错误示例：不要将 Query 的返回值赋给 Recordset 变量 ' Dim Rs As ADODB.Recordset ' Set Rs = db.Query("SELECT * FROM users") ' 错误！Query 返回布尔值 ' ? 正确示例：使用 db.Rs 访问结果 If db.Sql("SELECT * FROM users").Query Then ' 使用 db.Rs 访问结果 Do Until db.Rs.EOF Debug.Print db.Rs("name") db.Rs.MoveNext Loop db.Rs.Close End If ``` ### Fetch 方法 `Fetch` 方法执行查询并自动转换为 Dictionary 集合。**主要场景是用于 JSON 输出和数据交换**，特别适合与 `cHttpServer` 等组件配合使用。 #### 语法 ```vb Function Fetch(Optional CurType As CursorTypeEnum = adOpenKeyset, _ Optional LockType As LockTypeEnum = adLockOptimistic, _ Optional Options As Long = -1) As Boolean ``` #### 功能 * 执行查询 * 自动将 Recordset 转换为 Collection（存储在 `Rows` 属性中） * 自动设置第一行到 `Row` 属性 * **可直接用于 JSON 序列化**，配合 `cJson` 和 `cHttpServerResponse` 使用 #### 示例 ```vb ' 查询并自动转换 If db.Sql("SELECT * FROM users WHERE age > 18").Fetch Then ' 访问第一行 Debug.Print db.Row("name") Debug.Print db.Row("age") ' 遍历所有行 Dim i As Long For i = 1 To db.Rows.Count Debug.Print db.Rows(i)("name") Next End If ``` #### JSON 输出场景（主要用途） `Fetch` 方法的主要优势是方便将查询结果转换为 JSON 字符串，用于外部数据交换： ```vb ' 在 HttpServer 路由中使用 Private Sub Server_OnRoute(ctx As VBMAN.cHttpServerContext) ' 查询数据 If ctx.Db.Sql("SELECT * FROM users").Fetch Then ' 直接输出 JSON（一句话完成） ctx.Response.Json ctx.Db.Rows End If End Sub ' 或者使用 cJson 对象 Dim json As New VBMAN.cJson If db.Sql("SELECT * FROM users").Fetch Then Dim sJson As String sJson = json.Encode(db.Rows) ' 转换为 JSON 字符串 Debug.Print sJson End If ``` **注意**：`cHttpServerResponse.Json` 方法会自动识别 Recordset 并转换，但使用 `Fetch` 后直接传入 `db.Rows`（Collection）更高效，因为已经完成转换。 *** ## 查询方法对比 | 方法 | 返回类型 | 自动转换 | 使用场景 | | ------------ | --------- | -------- | -------------------------------------------------------------- | | `Query` | `Boolean` | 否 | 需要直接操作 `db.Rs` (Recordset)，使用 Recordset 高级功能 | | `Fetch` | `Boolean` | 是→Rows | **主要用于 JSON 输出和数据交换**，配合 cHttpServer、cJson 使用 | | `QueryParam` | `Boolean` | 否 | 参数化查询，结果存储在 `db.Rs` | | `FetchParam` | `Boolean` | 是→Rows | **参数化查询 + 自动转换**，推荐配合 JSON 输出使用 | **注意**：所有方法的返回值都是 `Boolean`（True/False），不是 Recordset。 *** ## 结果集处理 ### Rs 属性 `Rs` 属性提供对 ADO Recordset 的直接访问。 ```vb ' 使用 Recordset If db.Sql("SELECT * FROM users").Query Then Do Until db.Rs.EOF Debug.Print db.Rs("name") Debug.Print db.Rs("age") db.Rs.MoveNext Loop ' 获取记录数 Debug.Print "总记录数: " & db.Rs.RecordCount End If ``` ### Rows 属性 `Rows` 属性是转换后的 **cCollection**（VBMAN 自定义集合类型，兼容标准 Collection 的用法），包含所有行的 Dictionary。**可以直接用于 JSON 序列化**。 ```vb ' 使用 Collection If db.Sql("SELECT * FROM users").Fetch Then Dim i As Long For i = 1 To db.Rows.Count Debug.Print db.Rows(i)("name") Debug.Print db.Rows(i)("age") Next End If ``` #### JSON 输出示例 ```vb ' 场景 1：在 HttpServer 中直接输出 JSON Private Sub Server_OnRoute(ctx As VBMAN.cHttpServerContext) If ctx.Db.Sql("SELECT * FROM users").Fetch Then ' 直接输出为 JSON（推荐方式） ctx.Response.Json ctx.Db.Rows End If End Sub ' 场景 2：使用 cJson 对象转换为 JSON 字符串 Dim json As New VBMAN.cJson If db.Sql("SELECT * FROM users").Fetch Then Dim sJson As String sJson = json.Encode(db.Rows) ' 输出: [{"id":1,"name":"张三","age":25},{"id":2,"name":"李四","age":30}] End If ' 场景 3：带分页的 JSON 输出 If db.Sql("SELECT * FROM users").Page(1, 10).Fetch Then Dim lTotal As Long lTotal = db.Count("users") ' 输出带总数和分页信息的 JSON ctx.Response.Json db.Rows, 200, "成功", lTotal End If ``` ### Row 属性 `Row` 属性是当前第一行的 Dictionary（`Dictionary` 类型）。 ```vb ' 访问第一行 If db.Sql("SELECT * FROM users WHERE id = 1").Fetch Then Debug.Print db.Row("name") Debug.Print db.Row("age") End If ``` ### 结果集结构 ``` Rows (cCollection - 兼容标准 Collection 的用法) ├── Rows(1) (Dictionary) │ ├── "id" => 1 │ ├── "name" => "张三" │ └── "age" => 25 ├── Rows(2) (Dictionary) │ ├── "id" => 2 │ ├── "name" => "李四" │ └── "age" => 30 └── ... ``` *** ## 查询选项 ### 游标类型 (CursorTypeEnum) | 类型 | 值 | 说明 | | ------------------- | --- | ------------------ | | `adOpenForwardOnly` | 0 | 仅向前游标（最快） | | `adOpenKeyset` | 1 | 键集游标（默认） | | `adOpenDynamic` | 2 | 动态游标 | | `adOpenStatic` | 3 | 静态游标 | ```vb ' 使用仅向前游标（性能最佳） db.Sql("SELECT * FROM users").Query adOpenForwardOnly ' 使用静态游标（支持 RecordCount） db.Sql("SELECT * FROM users").Query adOpenStatic ``` ### 锁定类型 (LockTypeEnum) | 类型 | 值 | 说明 | | ----------------------- | --- | ---------------- | | `adLockReadOnly` | 1 | 只读（默认查询） | | `adLockPessimistic` | 2 | 悲观锁定 | | `adLockOptimistic` | 3 | 乐观锁定 | | `adLockBatchOptimistic` | 4 | 批量乐观锁定 | ```vb ' 只读查询（性能最佳） db.Sql("SELECT * FROM users").Query adOpenKeyset, adLockReadOnly ``` *** ## 常见查询场景 ### 场景 1：单条记录查询 ```vb ' 查询单条记录 If db.Sql("SELECT * FROM users WHERE id = 1").Fetch Then If db.Rows.Count > 0 Then Debug.Print "用户名: " & db.Row("name") Debug.Print "年龄: " & db.Row("age") Else Debug.Print "未找到记录" End If End If ``` ### 场景 2：条件查询 ```vb ' 多条件查询 Dim sSql As String sSql = "SELECT * FROM users WHERE age > 18 AND status = 'active'" If db.Sql(sSql).Fetch Then Dim i As Long For i = 1 To db.Rows.Count Debug.Print db.Rows(i)("name") Next End If ``` ### 场景 3：排序查询 ```vb ' 按年龄降序排列 If db.Sql("SELECT * FROM users ORDER BY age DESC").Fetch Then Dim i As Long For i = 1 To db.Rows.Count Debug.Print db.Rows(i)("name") & " - " & db.Rows(i)("age") Next End If ``` ### 场景 4：聚合查询 ```vb ' 统计查询 If db.Sql("SELECT COUNT(*) AS cnt, AVG(age) AS avg_age FROM users").Fetch Then If db.Rows.Count > 0 Then Debug.Print "总用户数: " & db.Row("cnt") Debug.Print "平均年龄: " & db.Row("avg_age") End If End If ``` ### 场景 5：分组查询 ```vb ' 分组统计 If db.Sql("SELECT status, COUNT(*) AS cnt FROM users GROUP BY status").Fetch Then Dim i As Long For i = 1 To db.Rows.Count Debug.Print db.Rows(i)("status") & ": " & db.Rows(i)("cnt") Next End If ``` ### 场景 6：联表查询 ```vb ' 内连接查询 Dim sSql As String sSql = "SELECT u.name, p.title " & _ "FROM users u " & _ "INNER JOIN posts p ON u.id = p.user_id" If db.Sql(sSql).Fetch Then Dim i As Long For i = 1 To db.Rows.Count Debug.Print db.Rows(i)("name") & " - " & db.Rows(i)("title") Next End If ``` ### 场景 7：子查询 ```vb ' 子查询 Dim sSql As String sSql = "SELECT * FROM users " & _ "WHERE id IN (SELECT user_id FROM orders WHERE amount > 1000)" If db.Sql(sSql).Fetch Then ' 处理结果 End If ``` ### 场景 8：模糊查询 ```vb ' LIKE 查询 If db.Sql("SELECT * FROM users WHERE name LIKE '%张%'").Fetch Then Dim i As Long For i = 1 To db.Rows.Count Debug.Print db.Rows(i)("name") Next End If ``` ### 场景 9：分页查询 ```vb ' 使用 Page 方法（详见 pagination.md） If db.Sql("SELECT * FROM users").Page(1, 10).Fetch Then Dim i As Long For i = 1 To db.Rows.Count Debug.Print db.Rows(i)("name") Next End If ``` ### 场景 10：参数化查询 ```vb ' 使用参数化查询（详见 parameterized.md） If db.Sql("SELECT * FROM users WHERE name = ? AND age > ?") _ .Param("name", "张三", adVarWChar) _ .Param("age", 18, adInteger) _ .QueryParam Then Dim i As Long For i = 1 To db.Rows.Count Debug.Print db.Rows(i)("name") Next End If ``` ### 场景 11：JSON 输出（Fetch 的主要场景） ```vb ' 在 HttpServer 路由中输出 JSON Private Sub Server_OnRoute(ctx As VBMAN.cHttpServerContext) ' 查询数据并转换为 Collection If ctx.Db.Sql("SELECT * FROM users WHERE status = 'active'").Fetch Then ' 直接输出 JSON（一句话完成） ctx.Response.Json ctx.Db.Rows End If End Sub ' 带分页的 JSON API Private Sub Server_OnRoute(ctx As VBMAN.cHttpServerContext) Dim lPage As Long Dim lPageSize As Long lPage = CLng(ctx.Request.Query("page")) lPageSize = CLng(ctx.Request.Query("pageSize")) ' 查询分页数据 If ctx.Db.Sql("SELECT * FROM users ORDER BY id").Page(lPage, lPageSize).Fetch Then Dim lTotal As Long lTotal = ctx.Db.Count("users") ' 输出 JSON，包含数据、总数等信息 ctx.Response.Json ctx.Db.Rows, 200, "成功", lTotal End If End Sub ' 使用 cJson 对象转换为 JSON 字符串 Dim json As New VBMAN.cJson If db.Sql("SELECT * FROM users").Fetch Then Dim sJson As String sJson = json.Encode(db.Rows) ' 可以用于文件保存、网络传输等 Debug.Print sJson End If ``` *** ## 参数化查询方法 ### FetchParam 方法 `FetchParam` 是参数化查询 + 自动转换的组合方法，**推荐用于参数化查询的 JSON 输出场景**。 ```vb ' 参数化查询 + Fetch（一步到位） If db.Sql("SELECT * FROM users WHERE age > ? AND status = ?") _ .Param("age", 18, adInteger) _ .Param("status", "active", adVarWChar) _ .FetchParam Then ' 直接使用 Rows 进行 JSON 输出 ctx.Response.Json db.Rows End If ``` > 详细用法请参考 [参数化查询](./parameterized.md) 中的 FetchParam 章节。 *** ## 性能优化 ### 1. 只查询需要的字段 ```vb ' ? 不推荐：查询所有字段 db.Sql("SELECT * FROM users").Query ' ? 推荐：只查询需要的字段 db.Sql("SELECT id, name FROM users").Query ``` ### 2. 使用索引字段 ```vb ' ? 推荐：使用索引字段作为条件 db.Sql("SELECT * FROM users WHERE id = 1").Query ``` ### 3. 限制结果集大小 ```vb ' ? 推荐：使用 TOP 限制结果 db.Sql("SELECT TOP 100 * FROM users").Query ``` ### 4. 使用合适的游标类型 ```vb ' ? 推荐：只读查询使用 ForwardOnly db.Sql("SELECT * FROM users").Query adOpenForwardOnly, adLockReadOnly ``` *** ## 错误处理 ```vb ' 查询错误处理 If Not db.Sql("SELECT * FROM users").Query Then Debug.Print "查询失败" Debug.Print "错误代码: " & db.LastErrNumber Debug.Print "错误描述: " & db.LastErrDescription Debug.Print "完整信息: " & db.LastErr Exit Sub End If ``` *** ## 最佳实践 ### 1. 始终检查返回值 ```vb ' ? 推荐 If db.Sql("SELECT * FROM users").Query Then ' 处理结果 Else ' 处理错误 End If ``` ### 2. 使用 Fetch 进行 JSON 输出 ```vb ' ? 推荐：使用 Fetch 进行 JSON 输出（主要场景） If db.Sql("SELECT * FROM users").Fetch Then ' 在 HttpServer 中直接输出 ctx.Response.Json db.Rows ' 只输出一行记录的 ctx.Response.Json db.Row ' 或使用 cJson 对象 Dim json As New VBMAN.cJson Dim sJson As String sJson = json.Encode(db.Rows) End If ``` ### 3. 及时释放资源 ```vb ' ? 推荐：查询完成后关闭 Recordset If db.Sql("SELECT * FROM users").Query Then ' 处理结果 If db.Rs.State <> adStateClosed Then db.Rs.Close End If End If ``` *** **最后更新**: 2026-01-21 --- --- url: /zh/vbman/Toast/faq.md --- # 常见问题 本文档整理了 cToast 组件的常见问题及解答。 ## 目录 * [基础问题](#基础问题) * [使用问题](#使用问题) * [技术问题](#技术问题) * [性能问题](#性能问题) * [扩展问题](#扩展问题) *** ## 基础问题 ### Q1: cToast 是什么？有什么用？ **A:** cToast 是 VBMan 框架中用于显示消息提示弹窗的核心类。它提供了一种优雅、现代的消息提示方式，用于向用户显示操作反馈、系统通知等重要信息。相比传统的 `MsgBox`，cToast 具有以下优势： * 不会阻塞用户操作（无焦点窗口） * 支持多种显示位置和主题 * 支持自动堆叠和批量管理 * 支持鼠标悬停暂停倒计时 * 外观更美观、更现代 *** ### Q2: cToast 和 MsgBox 有什么区别？ **A:** | 特性 | cToast | MsgBox | | -------- | -------------- | -------------- | | 是否阻塞 | 否（无焦点） | 是（模态窗口） | | 显示位置 | 9种位置可选 | 固定居中 | | 自动关闭 | 支持 | 不支持 | | 多条消息 | 支持堆叠 | 不支持 | | 交互方式 | 仅提示 | 可返回用户选择 | | 使用场景 | 操作反馈、通知 | 确认对话框 | **使用建议：** * 操作反馈（成功/失败）：使用 cToast * 需要用户确认：使用 MsgBox *** ### Q3: 如何添加 cToast 到我的项目？ **A:** 需要添加以下文件到你的项目： 1. **核心类**： * `cToast.cls` - 核心管理类 * `mToast.bas` - 工具函数模块 2. **窗体文件**： * `FToastCenter.frm` - 居中弹窗 * `FToastDrawer.frm` - 侧边抽屉弹窗 3. **依赖组件**： * `cShadow.cls` - 阴影效果类 **步骤：** 1. 在 VB6 IDE 中，打开你的项目 2. 右键点击"工程"，选择"添加文件" 3. 选择上述文件添加到项目 4. 重新编译项目 *** ### Q4: cToast 支持哪些显示位置？ **A:** cToast 支持9种预设显示位置： ```vb ' 左侧系列 LeftTop ' 左上（堆叠） LeftCenter ' 左中（覆盖） LeftBottom ' 左下（堆叠） ' 中间系列 CenterTop ' 居上（顺序堆叠） Center ' 居中（覆盖） CenterBottom ' 居下（倒序堆叠） ' 右侧系列 RightTop ' 右上（堆叠） RightCenter ' 右中（覆盖） RightBottom ' 右下（堆叠） ``` *** ### Q5: cToast 支持哪些状态主题？ **A:** cToast 支持4种状态主题： ```vb Info ' 信息（蓝色）&HC58B36 Success ' 成功（绿色）&HC000& Warning ' 警告（黄色）&HC0C0& Danger ' 危险（红色）&HC0& ``` *** ## 使用问题 ### Q6: 如何让弹窗不自动关闭？ **A:** 将 `Show` 方法的 `Delay` 参数设置为 0： ```vb ' 持久显示 With New cToast .Show "这条消息不会自动关闭", 0 End With ``` **注意：** * `Delay = 0` 表示持久显示 * 弹窗会一直显示，直到手动关闭或程序结束 *** ### Q7: 如何关闭指定的弹窗？ **A:** 需要先为弹窗命名，然后使用 `CloseMe` 方法关闭： ```vb Dim Toast As New cToast ' 创建命名的弹窗 Toast.Tag("msg1").Pos(RightTop).Show "第一条消息", 0 ' 关闭指定弹窗 Toast.CloseMe "msg1" ``` **注意事项：** * 必须在 `Show` 之前调用 `Tag` 方法 * TagName 必须唯一，相同名称的弹窗不会重复创建 *** ### Q8: 为什么相同 TagName 的弹窗没有创建？ **A:** 这是设计行为，cToast 防止相同名称的弹窗重复创建。如果需要多次显示相同消息，建议： **方案1：使用不同的 TagName** ```vb Toast.Tag("msg_" & Now).Show "消息内容", 0 ``` **方案2：先关闭再创建** ```vb If Toast.Exists("msg1") Then Toast.CloseMe "msg1" End If Toast.Tag("msg1").Show "消息内容", 0 ``` **方案3：不指定 TagName（自动生成随机名）** ```vb Toast.Show "消息内容", 0 ``` *** ### Q9: 如何实现弹窗更新已有内容？ **A:** 当前版本不支持直接更新内容。可以通过以下方式实现： **方案1：关闭旧弹窗，显示新弹窗** ```vb If Toast.Exists("msg1") Then Toast.CloseMe "msg1" End If Toast.Tag("msg1").Show "更新的内容", 0 ``` **方案2：显示新的弹窗，旧的自动覆盖** ```vb ' 使用覆盖位置（如 Center） Toast.Pos(Center).Show "新内容", 0 ``` *** ### Q10: 鼠标悬停时倒计时会暂停吗？ **A:** 是的，鼠标进入弹窗区域时会自动暂停计时器，移开后恢复倒计时。这个功能让用户有足够时间阅读较长的消息内容。 **实现机制：** * 鼠标进入弹窗：`MouseMove` 事件触发，暂停 Timer * 鼠标离开弹窗：检测到坐标超出范围，恢复 Timer *** ### Q11: 可以在同一个位置显示多个弹窗吗？ **A:** 可以。根据位置类型不同，显示方式也不同： **堆叠位置（Top/Bottom 系列）：** * `LeftTop`、`LeftBottom`、`CenterTop`、`CenterBottom`、`RightTop`、`RightBottom` * 支持多个弹窗堆叠显示 * 自动或手动指定堆叠顺序 **覆盖位置（Center 系列）：** * `Center`、`LeftCenter`、`RightCenter` * 不支持堆叠 * 新的弹窗会覆盖旧的（旧的自动关闭） *** ### Q12: 如何实现多个弹窗的顺序显示？ **A:** 使用堆叠位置和自动堆叠： ```vb Dim Toast As New cToast Toast.Pos(RightTop).State(Success) Toast.Show "第1条", 0 ' 自动索引0（最上） Toast.Show "第2条", 0 ' 自动索引1 Toast.Show "第3条", 0 ' 自动索引2 Toast.Show "第4条", 0 ' 自动索引3 ``` *** ### Q13: 如何实现底部倒序堆叠？ **A:** 使用底部位置（Bottom 系列），自动实现倒序堆叠： ```vb Dim Toast As New cToast Toast.Pos(RightBottom).State(Warning) Toast.Show "第1条（最下）", 0 ' 自动索引0（最下） Toast.Show "第2条", 0 ' 自动索引1 Toast.Show "第3条", 0 ' 自动索引2 Toast.Show "第4条（最上）", 0 ' 自动索引3（最上） ``` *** ### Q14: 如何手动指定堆叠位置？ **A:** 使用 `InstIndex` 方法手动指定堆叠索引： ```vb Dim Toast As New cToast ' 手动指定每个位置 Toast.Pos(RightTop).InstIndex(0).Show "第1条", 0 Toast.Pos(RightTop).InstIndex(1).Show "第2条", 0 Toast.Pos(RightTop).InstIndex(2).Show "第3条", 0 ``` **注意事项：** * `InstIndex` 必须在 `Pos` 之后、`Show` 之前调用 * 居中/覆盖位置调用无效 *** ### Q15: 如何获取某个弹窗的位置或状态？ **A:** 当前版本不直接支持查询弹窗属性。建议： **方案1：在创建时记录信息** ```vb ' 使用字典记录 Dim toastInfo As Object Set toastInfo = New cCollection toastInfo("msg1_pos") = RightTop toastInfo("msg1_state") = Success Toast.Tag("msg1").Pos(toastInfo("msg1_pos")).State(toastInfo("msg1_state")).Show "消息", 0 ``` **方案2：使用不同的 TagName 区分** ```vb Toast.Tag("success_msg").State(Success).Show "成功", 0 Toast.Tag("warning_msg").State(Warning).Show "警告", 0 ``` *** ### Q16: 如何遍历所有活动弹窗？ **A:** 使用 `ActiveKeys` 属性： ```vb Dim Keys As Collection Dim Key As Variant Set Keys = Toast.ActiveKeys For Each Key In Keys Debug.Print "活动弹窗: " & Key Next Key ``` *** ### Q17: 如何统计当前活动弹窗数量？ **A:** 使用 `Count` 属性： ```vb Debug.Print "当前活动弹窗数量: " & Toast.Count If Toast.Count > 0 Then Debug.Print "还有 " & Toast.Count & " 个弹窗未关闭" End If ``` *** ## 技术问题 ### Q18: cToast 为什么不获取焦点？ **A:** cToast 使用了 Windows API 设置无焦点窗口样式： ```vb SetWindowLong Me.hwnd, GWL_EXSTYLE, GetWindowLong(Me.hwnd, GWL_EXSTYLE) Or WS_EX_NOACTIVATE SetWindowLong Me.hwnd, GWL_STYLE, GetWindowLong(Me.hwnd, GWL_STYLE) Or WS_DISABLED ``` **目的：** * 不打断用户当前操作 * 不影响用户正在使用的其他窗口 * 提供非侵入式的通知体验 *** ### Q19: cToast 的弹窗为什么始终在最上层？ **A:** cToast 使用了 `HWND_TOPMOST` 标志将窗口设置为顶层窗口： ```vb SetWindowPos Me.hwnd, HWND_TOPMOST, x, y, cx, cy, SWP_NOSIZE Or SWP_NOACTIVATE Or SWP_SHOWWINDOW ``` **目的：** * 确保弹窗始终可见 * 不会被其他窗口遮挡 *** ### Q20: cToast 如何实现阴影效果？ **A:** cToast 使用了 `cShadow` 类来实现阴影效果： ```vb Private Sub Form_Load() Set Sad = New cShadow With Sad .BackColor = vbBlack .BorderRadius = 0 .BorderWidth = 0 .ShadowColor = &H0& .ShadowOffsetX = 0 .ShadowOffsetY = 0 .ShadowSize = 5 End With Sad.ShowBorders Me.hwnd, False End Sub ``` **注意：** * 如果不需要阴影，可以移除 `cShadow` 相关代码 *** ### Q21: cToast 为什么使用两个窗体？ **A:** cToast 内部使用两个不同的窗体实现不同的显示效果： **FToastCenter（居中弹窗）：** * 用于居中显示 * 包含底部颜色条 * 自动宽度计算 * 适合重要提示 **FToastDrawer（侧边弹窗）：** * 用于侧边显示 * 包含侧边颜色条 * 包含标题和内容两行 * 适合多条消息堆叠 **设计原因：** * 不同场景需要不同的显示效果 * 分离关注点，便于维护 * 满足多样化的UI需求 *** ### Q22: cToast 如何实现自动堆叠？ **A:** cToast 通过内部标记 `m_ManualStack` 判断是否启用自动堆叠： ```vb ' InstIndex 调用时设置标记 Public Function InstIndex(ByVal i As Long) As cToast Set InstIndex = Me m_Index = i m_ManualStack = True End Function ' Show 方法中的自动堆叠逻辑 If Not m_ManualStack Then If Coll.Count > 0 Then m_Index = Coll.Count End If End If ``` **工作流程：** 1. 用户不调用 `InstIndex` 时，`m_ManualStack = False` 2. 如果集合已有实例，自动设置 `m_Index = Coll.Count` 3. 实现自动堆叠 *** ### Q23: cToast 如何避免重复创建相同 TagName 的弹窗？ **A:** 在 `Show` 方法中检查 TagName 是否已存在： ```vb ' 检查是否已存在同名实例 On Error Resume Next m_AllKeys.Item TagName If ERR.Number = 0 Then ' 同名实例已存在，不创建新实例 On Error GoTo 0 Exit Function End If On Error GoTo 0 ``` **目的：** * 防止重复显示相同消息 * 节省系统资源 * 避免用户困惑 *** ### Q24: cToast 的事件什么时候触发？ **A:** cToast 有两个事件，触发时机不同： **OnToastCountChange 事件：** * 调用 `Show` 创建新弹窗时 * 调用 `CloseMe` 关闭弹窗时 * 窗体自然关闭（Timer到期）时 * 窗体卸载时 **OnCloseAll 事件：** * 调用 `CloseAll()` 方法后 * 类的 `Class_Terminate` 时调用 `CloseAll` **不触发的情况：** * `CloseAll` 不会触发 `OnToastCountChange`（避免频繁回调） *** ### Q25: 如何监听 cToast 事件？ **A:** 使用 `WithEvents` 关键字声明变量： ```vb Private WithEvents Toast As cToast Private Sub Form_Load() Set Toast = New cToast End Sub Private Sub Toast_OnToastCountChange(ByVal TagName As String, ByVal IsDelete As Boolean, ByVal CurrentCount As Long) ' 事件处理代码 Debug.Print "数量变化: " & TagName & ", 删除=" & IsDelete & ", 总数=" & CurrentCount End Sub Private Sub Toast_OnCloseAll(ByVal ClosedCount As Long) ' 事件处理代码 Debug.Print "批量关闭: " & ClosedCount & " 个" End Sub ``` *** ## 性能问题 ### Q26: cToast 可以同时显示多少个弹窗？ **A:** cToast 本身没有限制弹窗数量，理论上可以显示任意数量的弹窗。但建议： **建议上限：** * 单个位置：不超过 5-10 个 * 全局总数：不超过 20-30 个 **原因：** * 屏幕空间有限，过多弹窗会影响用户体验 * 过多弹窗会占用较多系统资源 * 用户可能无法及时处理所有通知 **最佳实践：** ```vb ' 限制单个位置的最大弹窗数 If Toast.Count >= 10 Then Toast.CloseMe "oldest_msg" End If ``` *** ### Q27: cToast 的性能如何？会影响程序性能吗？ **A:** cToast 的性能表现良好，主要原因： **优化措施：** * 使用集合存储弹窗，查找效率高 O(1) * 批量关闭时只触发一次事件，避免频繁回调 * 及时释放窗体资源 * 使用高效的 API 函数 **实际测试：** * 显示/关闭单个弹窗：响应时间 < 10ms * 同时显示10个弹窗：无明显卡顿 * 批量关闭20个弹窗：响应时间 < 50ms **建议：** * 避免短时间内创建过多弹窗 * 及时关闭不需要的弹窗 * 合理使用持久显示（Delay=0） *** ### Q28: cToast 是否会占用大量内存？ **A:** cToast 的内存占用相对较小，主要消耗来自： **内存消耗来源：** * 每个弹窗实例：约 50-100KB * 阴影对象：约 20-50KB * 9个集合对象：约 1-2KB **优化建议：** * 及时关闭不需要的弹窗 * 使用 `CloseAll` 批量关闭 * 避免持久显示过多弹窗 **示例：** ```vb ' 显示5个弹窗，内存占用约 350-750KB For i = 1 To 5 Toast.Show "消息 " & i, 0 Next i ' 关闭后释放内存 Toast.CloseAll ``` *** ## 扩展问题 ### Q29: 可以为 cToast 添加自定义图标吗？ **A:** 当前版本不支持自定义图标。弹窗的状态通过颜色条表示： * 信息：蓝色 * 成功：绿色 * 警告：黄色 * 危险：红色 **变通方案：** 如果需要图标，可以考虑： 1. 修改源码，添加图片控件 2. 使用富文本显示（需要额外控件） 3. 自定义新的窗体类型 *** ### Q30: 可以为 cToast 添加进度条吗？ **A:** 当前版本不支持进度条。但可以通过以下方式实现： **方案1：多条弹窗模拟进度** ```vb For i = 1 To 10 Toast.State(Info).Show "进度: " & i & "/10", 1000 ' 执行任务... Next i ``` **方案2：修改源码添加进度条** 在 `FToastDrawer` 窗体中添加进度条控件，并扩展 API 方法。 *** ### Q31: 可以为 cToast 添加动画效果吗？ **A:** 当前版本不支持动画效果。如果需要，可以考虑： **方案1：使用淡入动画** ```vb ' 窗体显示时逐步增加透明度（需要额外API支持） Me.Show Dim i As Integer For i = 0 To 255 Step 5 SetWindowPos Me.hwnd, ... DoEvents Next i ``` **方案2：使用缩放动画** ```vb ' 从小到大显示窗体 Me.ScaleWidth = 100 Me.Show For i = 100 To 400 Step 10 Me.ScaleWidth = i DoEvents Next i ``` **注意：** 需要修改源码实现。 *** ### Q32: 如何创建全局单例 Toast 对象？ **A:** 可以创建一个全局函数，简化调用： **方案1：使用模块函数** ```vb ' 在 mToast.bas 中添加 Public Function Toast() As cToast Static instance As cToast If instance Is Nothing Then Set instance = New cToast End If Set Toast = instance End Function ``` **使用示例：** ```vb ' 简化调用 Toast.State(Success).Show "操作成功", 2000 ``` **方案2：创建便捷方法** ```vb Public Sub ToastSuccess(ByVal Message As String, Optional ByVal Duration As Long = 3000) With New cToast .State(Success).Show Message, Duration End With End Sub Public Sub ToastInfo(ByVal Message As String, Optional ByVal Duration As Long = 3000) With New cToast .State(Info).Show Message, Duration End With End Sub Public Sub ToastWarning(ByVal Message As String, Optional ByVal Duration As Long = 3000) With New cToast .State(Warning).Show Message, Duration End With End Sub Public Sub ToastDanger(ByVal Message As String, Optional ByVal Duration As Long = 3000) With New cToast .State(Danger).Show Message, Duration End With End Sub ``` **使用示例：** ```vb ' 非常简洁 ToastSuccess "操作成功" ToastInfo "这是一条信息" ToastWarning "请注意" ToastDanger "发生错误" ``` *** ### Q33: 如何适配不同分辨率？ **A:** cToast 使用 twips 单位，VB6 会自动适配不同分辨率。但如果需要精确控制，可以考虑： **方案1：使用相对位置** ```vb Dim screenWidth As Long screenWidth = Screen.Width Toast.Pos(RightTop).Show "消息", 0 ' 自动计算相对位置 ``` **方案2：检测分辨率调整** ```vb If Screen.Width > 12000 Then ' 高分辨率 Toast.FontSize = 12 Else ' 低分辨率 Toast.FontSize = 10 End If ``` **注意：** cToast 已经考虑了不同分辨率的情况，通常不需要特殊处理。 *** ## 其他问题 ### Q34: cToast 支持多线程吗？ **A:** VB6 不支持真正的多线程，cToast 也不支持多线程。但在单线程环境下，cToast 的表现是稳定可靠的。 **注意：** * 如果在后台任务中需要显示弹窗，需要确保在主线程调用 * 使用 `DoEvents` 让系统处理消息队列 *** ### Q35: cToast 是否支持国际化？ **A:** cToast 本身不直接支持国际化，但你可以： **方案1：使用外部配置** ```vb ' 从配置文件读取消息 Dim msg As String msg = GetLocalizedString("MSG_SAVE_SUCCESS") Toast.State(Success).Show msg, 2000 ``` **方案2：使用资源文件** ```vb ' 从资源文件加载本地化字符串 Toast.State(Success).Show LoadResString(101), 2000 ``` *** ### Q36: cToast 是否可以在其他程序中使用？ **A:** cToast 是为 VB6 设计的，理论上可以在支持 COM 的环境中使用（如 VBA、VB.NET），但需要注意： **VBA：** * 可以直接使用 cToast 类 * 需要引用 VB6 运行时库 * 可能需要调整部分 API 调用 **VB.NET：** * 可以通过 COM 互操作使用 * 建议使用 .NET 原生的 Toast 组件 **其他语言：** * 不推荐，建议使用语言原生的通知组件 *** ### Q37: 如何获取帮助或报告问题？ **A:** 如果遇到问题或需要帮助，可以通过以下方式： * **QQ交流群**：915520648 [点击这里加群](http://qm.qq.com/cgi-bin/qm/qr?_wv=1027\&k=maQtC3a5Zxb3gMLvwpj6oE5fwmZGCOlY\&authKey=8%2FhBgSMLqADLatzXghFXO5BIBa%2BxSoHO%2FHFvtbZQk2kURUx%2FegxZukzAvhSPX6WJ\&noverify=0\&group_code=915520648) * **GitHub Issues**：如果项目在 GitHub 上，可以提交 Issue * **邮件联系**：通过项目主页获取联系方式 *** ### Q38: cToast 的许可证是什么？ **A:** cToast 遵循 VBMan 框架的许可证。具体信息请查看项目主页或源码文件中的许可证声明。 **一般原则：** * 可以在个人和商业项目中使用 * 可以修改源码以适应需求 * 需要保留原始版权声明 * 请查阅具体许可证了解详细信息 *** ## 总结 如果您的问题没有在本文档中找到答案，建议： 1. 查看 [API 参考](./api.md) 了解详细的接口说明 2. 查看 [使用示例](./examples.md) 学习实际应用 3. 查看 [技术细节](./technical.md) 了解内部实现 4. 加入 QQ 交流群（915520648）寻求帮助 --- --- url: /zh/vbman2/webview2/faq.md --- # 常见问题 (FAQ) ## 🔄 初始化与创建 ### ❓ Q1: WebView2 创建失败怎么办？ **现象**: 调用 Initialize 后没有触发 Create 或 Ready 事件。 **可能原因**: 1. 未安装 WebView2 Runtime 2. 目标机器的 WebView2 版本过旧 3. UserDataFolder 路径冲突 **解决方案**: ```vb ' 检查 WebView2 是否已安装 ' 查找路径: C:\Program Files (x86)\Microsoft\EdgeWebView\Application ' 指定最低版本号 wv.EnvironmentOptions.TargetCompatibleBrowserVersion = "86.0.616.0" ``` cWebView2Host 内部有重试逻辑，最多尝试 10 次创建，每次自动递增 UserDataFolder 路径。 *** ### ❓ Q2: Initialize 应该传入 Form 对象还是 hWnd？ 两者都支持： ```vb wv.Initialize Me.hWnd, "https://vb6.pro" ' 传入窗口句柄 wv.Initialize Me, "https://vb6.pro" ' 传入 Form 对象（自动获取 hWnd） ``` 传入 Form 对象时，内部自动调用 `Form.hWnd` 获取窗口句柄。效果完全相同。 *** ### ❓ Q3: 什么时候用两参数 Initialize，什么时候用一参数？ * **两参数** `Initialize(hWnd, url)` - 最常用，自动导航到指定 URL * **一参数** `Initialize(hWnd)` - 需要在导航前配置环境参数时使用 ```vb ' 简单场景：直接导航 wv.Initialize Me.hWnd, "https://vb6.pro" ' 高级场景：需要配置环境参数 wv.Initialize Me.hWnd ' 不立即导航 Private Sub wv_Create() ' 在导航前配置 wv.EnvironmentOptions.UserDataFolder = App.Path & "\UserData" wv.Security.CertificateErrorAction = CEA_AlwaysAllow End Sub Private Sub wv_Ready() wv.Navigate "https://example.com" End Sub ``` *** ## 🔗 数据绑定 ### ❓ Q4: BindUI 回调方法必须是 Public 吗？ **是的**。BindUI 使用 `CallByName` 调用宿主方法，VB6 的 CallByName 只能调用 Public 成员。 ```vb ' 正确 Public Sub OnClick(ByVal EventName As String, ByVal Detail As String) ' 错误 - 不会被调用 Private Sub OnClick(ByVal EventName As String, ByVal Detail As String) ``` *** ### ❓ Q5: BindUI 如何获取 DOM 元素的值？ Detail 参数包含 JSON 格式的事件详情，不同事件的 Detail 不同。需要手动解析： ```vb Public Sub OnNameInput(ByVal EventName As String, ByVal Detail As String) ' Detail 示例: {"type":"input","value":"用户输入的文本"} Dim val As String val = JsonValue(Detail, "value") wv.SetData "name", val End Sub ``` *** ### ❓ Q6: SetData 可以传递数组或对象吗？ SetData 的 Value 参数是 Variant，内部直接生成 JS 字面量。传递复杂结构有两种方式： ```vb ' 方式1：使用 innerHTML 属性绑定 wv.BindData "list", "#item-list", "innerHTML" wv.SetData "list", "
  • Item 1
  • Item 2
    • " ' 方式2：调用 JS 函数处理 JSON wv.JsRun "renderList(" & jsonString & ")" ``` *** ## ⚡ JavaScript 执行 ### ❓ Q7: JsRun 和 ExecuteScript 有什么区别？ | 特性 | JsRun | ExecuteScript | |------|-------|---------------| | 执行方式 | 同步（阻塞等待） | 异步（事件回调） | | 返回值 | 直接返回 String | JsAsyncResult 事件 | | WithEvents | 不需要 | 建议使用 | | 典型场景 | 立即获取结果 | 不需等待结果 | *** ### ❓ Q8: JsRun 和 Script.Eval 有什么区别？ | 特性 | JsRun | Script.Eval | |------|-------|-------------| | 输入 | JS 表达式/属性路径 | JS 代码段（支持 return） | | 包装 | 直接执行 | 包装为 function 后执行 | | 用法 | `wv.JsRun("document.title")` | `wv.Script.Eval("return document.title")` | | 适用场景 | 简单表达式 | 复杂代码块 | `Script.Eval` 会将代码包装为 `function EvalFuncName(){...}`，注入后调用，因此需要使用 `return` 返回值。 *** ## 🛡️ 安全 ### ❓ Q9: 如何忽略 HTTPS 证书错误？ **必须在 Create 事件中设置**，在导航开始之前： ```vb Dim WithEvents wv As cWebView2Host Private Sub Form_Load() Set wv = New cWebView2Host wv.Initialize Me.hWnd, "https://self-signed.example.com/" End Sub Private Sub wv_Create() ' 在导航前设置 wv.Security.CertificateErrorAction = CEA_AlwaysAllow End Sub ``` 如果在 Create 事件之后设置则不生效。 *** ### ❓ Q10: 如何禁用 DevTools 和右键菜单？ ```vb Private Sub wv_Create() wv.AreDevToolsEnabled = False wv.AreDefaultContextMenusEnabled = False End Sub ``` *** ## 🍪 Cookie ### ❓ Q11: GetCookies 和 GetCookiesFull 的区别？ | 方法 | 获取方式 | HttpOnly Cookie | 性能 | |------|---------|----------------|------| | `Cookies.GetCookies` | document.cookie | 不可见 | 快 | | `Cookies.GetCookiesFull` | CDP Network.getCookies | 可见 | 稍慢 | | `Cookies.GetCookiesFullAsync` | CDP 异步 | 可见 | 非阻塞 | 对于需要访问 HttpOnly Cookie 的场景，必须使用 `GetCookiesFull` 或 `GetCookiesFullAsync`。 *** ## 🖥️ 宿主环境 ### ❓ Q12: Access 中使用有什么限制？ Access 使用 MessageWindowAdapter，以下功能不可用： * 宿主鼠标事件（HostMouse\*） * 宿主键盘事件（HostKeyDown/Up/Press） * HostFocus / HostBlur 事件 替代方案： * 使用 BindUI 绑定 DOM 事件 * 使用 UserMouse 系列事件（需 EnableUserMouseEvents = True） *** ### ❓ Q13: 多个 WebView2 实例如何共享或隔离会话？ 通过 `UserDataFolder` 控制： ```vb ' 共享会话：相同 UserDataFolder wv1.EnvironmentOptions.UserDataFolder = App.Path & "\UserData" wv2.EnvironmentOptions.UserDataFolder = App.Path & "\UserData" ' 隔离会话：不同 UserDataFolder wv1.EnvironmentOptions.UserDataFolder = App.Path & "\UserDir\account-001" wv2.EnvironmentOptions.UserDataFolder = App.Path & "\UserDir\account-002" ``` 共享会话的实例将共享 Cookie、localStorage 等。隔离会话完全独立。 *** ## 📦 本地资源加载 ### ❓ Q14: 如何加载本地 HTML 文件？ 三种方式： ```vb ' 方式1：传入本地文件夹路径（最简单） wv.Initialize Me.hWnd, App.Path & "\www" ' 自动映射为 http://vbman2.com/index.html ' 方式2：虚拟主机名映射（推荐，支持 https 协议） wv.Initialize Me.hWnd ' 在 wv_Ready 中： wv.SetVirtualHostNameToFolderMapping "myapp.local", App.Path & "\www" wv.Navigate "https://myapp.local/index.html" ' 方式3：从 VB6 资源文件加载（单文件分发） wv.Initialize Me.hWnd ' 在 wv_Ready 中： wv.NavigateToString VBMAN2.Res(LoadResData("INDEX.HTML", "WWW")).ReturnString() ``` *** ### ❓ Q15: 本地 HTML 中的 AJAX 请求跨域问题？ 使用 `SetVirtualHostNameToFolderMapping` 方式加载时，页面以 `https://` 协议运行，可以正常访问同协议的外部 API，不会遇到 `file://` 协议的限制。 *** **最后更新**: 2026-06-24 --- --- url: /zh/emoji/2000-206F.md --- # 常用标点 (General Punctuation) 本页面展示了Unicode字符集中，位于U+2000到U+206F范围的常用标点符号。这些符号包括各种空格、破折号、引号和其他标点符号。 | 字符 | Unicode | VB函数值 | 名称 | |:---:|:---:|:---:|:---| | | U+2000 | ChrW(\&H2000) | EN QUAD空格 | | | U+2001 | ChrW(\&H2001) | EM QUAD空格 | | | U+2002 | ChrW(\&H2002) | EN SPACE空格 | | | U+2003 | ChrW(\&H2003) | EM SPACE空格 | | | U+2004 | ChrW(\&H2004) | 三分之一EM空格 | | | U+2005 | ChrW(\&H2005) | 四分之一EM空格 | | | U+2006 | ChrW(\&H2006) | 六分之一EM空格 | | | U+2007 | ChrW(\&H2007) | 数字空格 | | | U+2008 | ChrW(\&H2008) | 标点空格 | | | U+2009 | ChrW(\&H2009) | 窄空格 | | | U+200A | ChrW(\&H200A) | 头发空格 | | ‌ | U+200C | ChrW(\&H200C) | 零宽非连接符 | | ‍ | U+200D | ChrW(\&H200D) | 零宽连接符 | | ‎ | U+200E | ChrW(\&H200E) | 从左至右符号 | | ‏ | U+200F | ChrW(\&H200F) | 从右至左符号 | | ‐ | U+2010 | ChrW(\&H2010) | 连字符 | | ‑ | U+2011 | ChrW(\&H2011) | 非断开连字符 | | ‒ | U+2012 | ChrW(\&H2012) | 图形减号 | | – | U+2013 | ChrW(\&H2013) | EN破折号 | | — | U+2014 | ChrW(\&H2014) | EM破折号 | | ― | U+2015 | ChrW(\&H2015) | 水平条 | | ‖ | U+2016 | ChrW(\&H2016) | 双竖线 | | ‗ | U+2017 | ChrW(\&H2017) | 双下划线 | | ' | U+2018 | ChrW(\&H2018) | 左单引号 | | ' | U+2019 | ChrW(\&H2019) | 右单引号 | | ‚ | U+201A | ChrW(\&H201A) | 单低引号 | | ‛ | U+201B | ChrW(\&H201B) | 单高反引号 | | " | U+201C | ChrW(\&H201C) | 左双引号 | | " | U+201D | ChrW(\&H201D) | 右双引号 | | „ | U+201E | ChrW(\&H201E) | 双低引号 | | ‟ | U+201F | ChrW(\&H201F) | 双高反引号 | | † | U+2020 | ChrW(\&H2020) | 剑号 | | ‡ | U+2021 | ChrW(\&H2021) | 双剑号 | | • | U+2022 | ChrW(\&H2022) | 项目符号 | | ‣ | U+2023 | ChrW(\&H2023) | 三角项目符号 | | ․ | U+2024 | ChrW(\&H2024) | 一点领导符 | | ‥ | U+2025 | ChrW(\&H2025) | 二点领导符 | | … | U+2026 | ChrW(\&H2026) | 水平省略号 | | ‧ | U+2027 | ChrW(\&H2027) | 连字点 | | ‰ | U+2030 | ChrW(\&H2030) | 千分号 | | ‱ | U+2031 | ChrW(\&H2031) | 万分号 | | ′ | U+2032 | ChrW(\&H2032) | 角分符号 | | ″ | U+2033 | ChrW(\&H2033) | 角秒符号 | | ‴ | U+2034 | ChrW(\&H2034) | 角秒秒符号 | | ‵ | U+2035 | ChrW(\&H2035) | 反角分符号 | | ‶ | U+2036 | ChrW(\&H2036) | 反角秒符号 | | ‷ | U+2037 | ChrW(\&H2037) | 反角秒秒符号 | | ‸ | U+2038 | ChrW(\&H2038) | 插入符号 | | ‹ | U+2039 | ChrW(\&H2039) | 左单尖引号 | | › | U+203A | ChrW(\&H203A) | 右单尖引号 | | ※ | U+203B | ChrW(\&H203B) | 参考标记 | | ‼ | U+203C | ChrW(\&H203C) | 双感叹号 | | ‽ | U+203D | ChrW(\&H203D) | 问号感叹号 | | ‾ | U+203E | ChrW(\&H203E) | 上划线 | | ‿ | U+203F | ChrW(\&H203F) | 下划线连接符 | | ⁀ | U+2040 | ChrW(\&H2040) | 上划线连接符 | | ⁁ | U+2041 | ChrW(\&H2041) | 插入符号 | | ⁂ | U+2042 | ChrW(\&H2042) | 星号分隔符 | | ⁃ | U+2043 | ChrW(\&H2043) | 连字符项目符号 | | ⁄ | U+2044 | ChrW(\&H2044) | 分数斜线 | | ⁅ | U+2045 | ChrW(\&H2045) | 左方括号带点 | | ⁆ | U+2046 | ChrW(\&H2046) | 右方括号带点 | | ⁇ | U+2047 | ChrW(\&H2047) | 双问号 | | ⁈ | U+2048 | ChrW(\&H2048) | 问号感叹号 | | ⁉ | U+2049 | ChrW(\&H2049) | 感叹号问号 | | ⁊ | U+204A | ChrW(\&H204A) | 倒问号 | | ⁋ | U+204B | ChrW(\&H204B) | 倒段落符号 | | ⁌ | U+204C | ChrW(\&H204C) | 黑色左指针 | | ⁍ | U+204D | ChrW(\&H204D) | 黑色右指针 | | ⁎ | U+204E | ChrW(\&H204E) | 低星号 | | ⁏ | U+204F | ChrW(\&H204F) | 反分号 | | ⁐ | U+2050 | ChrW(\&H2050) | 上下箭头加点 | | ⁑ | U+2051 | ChrW(\&H2051) | 双星号 | | ⁒ | U+2052 | ChrW(\&H2052) | 商业减号 | | ⁓ | U+2053 | ChrW(\&H2053) | 波浪号 | | ⁔ | U+2054 | ChrW(\&H2054) | 下划线连接符 | | ⁕ | U+2055 | ChrW(\&H2055) | 花型星号 | | ⁖ | U+2056 | ChrW(\&H2056) | 三点标点 | | ⁗ | U+2057 | ChrW(\&H2057) | 四点标记 | | ⁘ | U+2058 | ChrW(\&H2058) | 四点操作符 | | ⁙ | U+2059 | ChrW(\&H2059) | 五点标点 | | ⁚ | U+205A | ChrW(\&H205A) | 两点标点 | | ⁛ | U+205B | ChrW(\&H205B) | 四点标点 | | ⁜ | U+205C | ChrW(\&H205C) | 带点十字 | | ⁝ | U+205D | ChrW(\&H205D) | 三点竖排 | | ⁞ | U+205E | ChrW(\&H205E) | 四点竖排 | --- --- url: /zh/emoji/1100-11FF.md --- # 朝鲜文 (Hangul Jamo) 本页面展示了Unicode字符集中，位于U+1100到U+11FF范围的朝鲜文字符。朝鲜文谚文字母（Jamo）是构成朝鲜文音节的基本字母单位。 | 字符 | Unicode | VB函数值 | 名称 | |:---:|:---:|:---:|:---| | ᄀ | U+1100 | ChrW(\&H1100) | 朝鲜文字母KIYEOK | | ᄁ | U+1101 | ChrW(\&H1101) | 朝鲜文字母SSANGKIYEOK | | ᄂ | U+1102 | ChrW(\&H1102) | 朝鲜文字母NIEUN | | ᄃ | U+1103 | ChrW(\&H1103) | 朝鲜文字母TIKEUT | | ᄄ | U+1104 | ChrW(\&H1104) | 朝鲜文字母SSANGTIKEUT | | ᄅ | U+1105 | ChrW(\&H1105) | 朝鲜文字母RIEUL | | ᄆ | U+1106 | ChrW(\&H1106) | 朝鲜文字母MIEUM | | ᄇ | U+1107 | ChrW(\&H1107) | 朝鲜文字母PIEUP | | ᄈ | U+1108 | ChrW(\&H1108) | 朝鲜文字母SSANGPIEUP | | ᄉ | U+1109 | ChrW(\&H1109) | 朝鲜文字母SIOS | | ᄊ | U+110A | ChrW(\&H110A) | 朝鲜文字母SSANGSIOS | | ᄋ | U+110B | ChrW(\&H110B) | 朝鲜文字母IEUNG | | ᄌ | U+110C | ChrW(\&H110C) | 朝鲜文字母CIEUC | | ᄍ | U+110D | ChrW(\&H110D) | 朝鲜文字母SSANGCIEUC | | ᄎ | U+110E | ChrW(\&H110E) | 朝鲜文字母CHIEUCH | | ᄏ | U+110F | ChrW(\&H110F) | 朝鲜文字母KHIEUKH | | ᄐ | U+1110 | ChrW(\&H1110) | 朝鲜文字母THIEUTH | | ᄑ | U+1111 | ChrW(\&H1111) | 朝鲜文字母PHIEUPH | | ᄒ | U+1112 | ChrW(\&H1112) | 朝鲜文字母HIEUH | | ᄓ | U+1113 | ChrW(\&H1113) | 朝鲜文字母NIEUN-KIYEOK | | ᄔ | U+1114 | ChrW(\&H1114) | 朝鲜文字母SSANGNIEUN | | ᄕ | U+1115 | ChrW(\&H1115) | 朝鲜文字母NIEUN-TIKEUT | | ᄖ | U+1116 | ChrW(\&H1116) | 朝鲜文字母NIEUN-PIEUP | | ᄗ | U+1117 | ChrW(\&H1117) | 朝鲜文字母TIKEUT-KIYEOK | | ᄘ | U+1118 | ChrW(\&H1118) | 朝鲜文字母RIEUL-NIEUN | | ᄙ | U+1119 | ChrW(\&H1119) | 朝鲜文字母SSANGRIEUL | | ᄚ | U+111A | ChrW(\&H111A) | 朝鲜文字母RIEUL-HIEUH | | ᄛ | U+111B | ChrW(\&H111B) | 朝鲜文字母KAPYEOUNRIEUL | | ᄜ | U+111C | ChrW(\&H111C) | 朝鲜文字母MIEUM-PIEUP | | ᄝ | U+111D | ChrW(\&H111D) | 朝鲜文字母KAPYEOUNMIEUM | | ᄞ | U+111E | ChrW(\&H111E) | 朝鲜文字母PIEUP-KIYEOK | | ᄟ | U+111F | ChrW(\&H111F) | 朝鲜文字母PIEUP-NIEUN | --- --- url: /zh/vbman/serialport/framing.md --- # 串口数据帧分帧协议 > 解决串口通信中"设备连发导致粘包"和"无法识别完整帧"的核心问题 ## 📖 目录 * [问题背景](#问题背景) * [分帧方案对比](#分帧方案对比) * [方案 B：帧间隔超时分帧](#方案-b帧间隔超时分帧) * [方案 C：协议分帧解析器](#方案-c协议分帧解析器) * [B + C 组合实战](#b--c-组合实战) * [方案选型建议](#方案选型建议) * [调参与排错](#调参与排错) *** ## 问题背景 ### 粘包现象 串口通信中，设备常常连续发送多帧数据。Windows 串口驱动把所有收到的字节堆在接收缓冲区里，**不区分帧边界**。如果使用 50ms 轮询定时器读取： ``` 时间线： 0ms 设备发送 Frame1 (10字节) 5ms 设备发送 Frame2 (8字节) ← 与 Frame1 之间没有停顿 12ms 设备发送 Frame3 (12字节) ... 50ms Timer 触发 Poll() 缓冲区有 30 字节 → ReadExisting() 一次全读出 结果：3 帧粘成一坨无法解析 ``` ### 轮询定时的局限 `SetTimer` 在 Windows 上的真实精度只有 ~15ms，即使把 `PollInterval` 设成 10ms 也无法做到真正实时。**缩短轮询间隔只能缓解，不能根治粘包**。 ### 解决思路 要识别每一帧的边界，需要明确的"分帧规则"。本类提供两种互补方案： * **方案 B**：利用设备发完一帧后的**短暂停顿**作为天然分帧点 * **方案 C**：按设备**协议格式**精确切分（分隔符 / 起止标记 / 长度字段 / 固定长度） *** ## 分帧方案对比 | 方案 | 实时性 | 精确度 | 是否需知协议 | 适用场景 | |------|--------|--------|-------------|---------| | **B. 帧间隔超时** | 好 | 中 | 否 | 设备发完一帧会停顿（绝大多数场景） | | **C1. 分隔符** | 最好 | 高 | 是 | 文本协议，有固定分隔符（如 `\r\n`） | | **C2. 起止标记** | 最好 | 高 | 是 | 二进制协议，有 STX/ETX 标记 | | **C3. 长度前缀** | 最好 | 高 | 是 | 含长度字段的协议（如 Modbus 类） | | **C4. 固定长度** | 最好 | 高 | 是 | 帧长度固定的协议 | | **B + C 组合** | 最好 | 最高 | 是 | 高可靠性场景，先粗分再精切 | *** ## 方案 B：帧间隔超时分帧 ### 原理 设备每次发完一帧后，必然有一个短暂停顿（哪怕几毫秒）才会发下一帧。这个停顿就是天然的帧边界： ``` Frame1(10B) |停顿| Frame2(8B) |停顿| Frame3(12B) ↑ ↑ 分帧点 分帧点 ``` `cSerialPort` 内部维护一个帧缓冲区，连续收到的数据视为同一帧；当超过 `FrameInterval` 毫秒没有新数据到达时，判定一帧结束，触发 `FrameReceived` 事件。 ### 启用分帧 只需设置 `FrameInterval` 属性为非 0 值即可启用： ```vb Private WithEvents m_Port As cSerialPort Private Sub Form_Load() Set m_Port = New cSerialPort m_Port.PortName = "COM3" m_Port.Config.BaudRate = br9600 If m_Port.OpenPort() Then ' 启用分帧：30ms 无新数据 = 一帧结束 m_Port.FrameInterval = 30 ' 轮询间隔建议 <= FrameInterval / 2，保证及时性 m_Port.StartMonitoring 20 End If End Sub ' 帧接收事件 - 每收到一个完整帧触发一次 Private Sub m_Port_FrameReceived(FrameData() As Byte) Dim s As String s = StrConv(FrameData, vbUnicode) Debug.Print "收到帧 (" & UBound(FrameData) + 1 & "字节): " & s End Sub ``` ### 关键属性 | 属性 | 类型 | 默认值 | 说明 | |------|------|--------|------| | `FrameInterval` | Long | 0 | 帧间隔超时(ms)，0=禁用分帧（保持原始 `DataReceived` 模式） | | `MaxFrameSize` | Long | 65536 | 单帧最大字节数，超过则强制触发，防止异常数据导致内存溢出 | | `FrameBufferLength` | Long | - | 只读，当前帧缓冲区中的字节数（已收到的未触发数据） | ### FrameInterval 取值建议 | 设备类型 | 建议值 | 说明 | |---------|--------|------| | 文本设备（GPS、温湿度等） | 20-50ms | 帧间停顿明显 | | 工业仪表 | 10-30ms | 响应快，停顿短 | | Modbus RTU | - | 不推荐用 B，应使用方案 C3（详见下文） | | 慢速设备（电子秤等） | 50-100ms | 设备本身发送就慢 | > 经验法则：先观察设备连续发数据时帧间的实际停顿（可用串口调试助手查看时间戳），`FrameInterval` 取停顿时间的一半左右最稳妥。 ### 注意事项 1. **轮询间隔与帧间隔的关系**：`PollInterval` 应 ≤ `FrameInterval / 2`，否则可能错过帧超时判定时机。 2. **不破坏原模式**：`FrameInterval = 0` 时仍走原来的 `DataReceived` 路径，向后兼容。 3. **最后一帧不丢**：`StopMonitoring` 和 `ClosePort` 时会自动 flush 缓冲区中剩余的未触发帧。 4. **大帧保护**：单帧超过 `MaxFrameSize` 时强制触发，避免异常数据耗尽内存。 *** ## 方案 C：协议分帧解析器 `cSerialFrameParser` 是独立的帧解析类，支持 4 种协议分帧模式。**它不直接读串口**，而是接收 `AppendData` 传入的字节流，按协议规则切分出完整帧。 ### 引用方式 ```vb ' 方式一：源码引用 ' 将 src/SerialPort/cSerialFrameParser.cls 加入工程 ' 方式二：DLL 引用 Dim parser As New VBMANLIB.cSerialFrameParser ``` ### C1. 分隔符模式 适用于有固定分隔符的协议（文本协议最常见）： ``` [DATA1][DELIM][DATA2][DELIM][DATA3][DELIM]... ``` ```vb Dim parser As New cSerialFrameParser ' 按 CRLF 分帧，返回的帧不包含分隔符 parser.SetDelimiterMode vbCrLf, False ' 也可以用其他分隔符 parser.SetDelimiterMode Chr(10), False ' 仅 LF parser.SetDelimiterMode "|", False ' 自定义字符 ' 注入数据 parser.AppendData someBytes ' 循环取出所有完整帧 Do While parser.HasFrame() Dim frame() As Byte frame = parser.GetFrame() Debug.Print StrConv(frame, vbUnicode) Loop ``` 参数说明： | 参数 | 说明 | |------|------| | `DelimiterStr` | 分隔符字符串（可以是多字节，如 `vbCrLf`） | | `IncludeDelim` | `True`=返回帧包含分隔符；`False`=不包含（默认） | ### C2. 起始结束标记模式 适用于有 STX/ETX 等定界符的二进制协议： ``` [STX][DATA1][ETX][STX][DATA2][ETX]... ``` ```vb Dim parser As New cSerialFrameParser ' STX(0x02) ... ETX(0x03)，返回帧包含标记 parser.SetStartEndMode Chr$(&H2), Chr$(&H3), True ' 也支持多字节标记 parser.SetStartEndMode "<<<", ">>>", True ``` | 参数 | 说明 | |------|------| | `StartStr` | 起始标记字符串 | | `EndStr` | 结束标记字符串 | | `IncludeMarks` | `True`=返回帧含标记；`False`=只返回中间数据 | **容错特性**：缓冲区开头不是 `StartMark` 时，解析器会自动跳过无效字节，从下一个 `StartMark` 开始解析。这能正确处理"半帧残留"问题（上次未收完的残帧）。 ### C3. 长度前缀模式 适用于含长度字段的二进制协议（如 Modbus、自定义帧头协议）： ``` ┌─────────┬───────────┬──────────┬─────────┐ │ Header │ Length(n) │ Payload │ Trailer │ │ (固定) │ (1/2/4B) │ (n字节) │ (固定) │ └─────────┴───────────┴──────────┴─────────┘ ``` #### 配置参数 | 参数 | 说明 | |------|------| | `Offset` | 长度字段在帧中的字节偏移（从 0 开始） | | `Size` | 长度字段大小：1/2/4 字节 | | `BaseSize` | 帧基础大小（长度值代表的范围之外的字节数：Header + Length字段 + Trailer） | | `BigEndian` | `True`=大端序；`False`=小端序 | | `Meaning` | 长度值的含义（见下表） | #### LengthMeaning 枚举 | 值 | 含义 | 帧总长度计算 | |----|------|------------| | `lmPayload` (0) | 长度值 = 数据负载长度 | `FrameBaseSize + 长度值` | | `lmPayloadAndTrailer` (1) | 长度值 = 负载 + 帧尾 | `FrameBaseSize + 长度值` | | `lmTotalFrame` (2) | 长度值 = 整个帧长度 | `长度值` | #### 常见协议配置示例 **示例 1：简单长度前缀** ``` [LEN(1)][DATA(n)] ``` 长度值 = n（数据长度），无 Header/Trailer。 ```vb ' Offset=0, Size=1, BaseSize=1(LEN本身), 小端, lmPayload parser.SetLengthPrefixMode 0, 1, 1, False, lmPayload ``` **示例 2：带 STX 和 CRC** ``` [STX(1)][LEN(2,BE)][DATA(n)][CRC(1)] ``` 长度值 = n，BaseSize = 1(STX) + 2(LEN) + 1(CRC) = 4。 ```vb parser.SetLengthPrefixMode 1, 2, 4, True, lmPayload ' Offset=1(跳过STX), Size=2字节, BaseSize=4, 大端序 ``` **示例 3：长度值代表整帧** ``` [HEADER(2)][LEN(2,LE)][DATA(n)] ``` 长度值 = 2 + 2 + n（整帧长度）。 ```vb parser.SetLengthPrefixMode 2, 2, 0, False, lmTotalFrame ' Offset=2(跳过HEADER), Size=2字节, BaseSize=0(用不上), 小端 ``` **示例 4：长度值包含 Trailer** ``` [LEN(1)][DATA(n)][CRC(1)] ``` 长度值 = n + 1（包含 CRC），BaseSize = 1（仅 LEN 字段）。 ```vb parser.SetLengthPrefixMode 0, 1, 1, False, lmPayloadAndTrailer ``` #### Modbus RTU 特殊说明 Modbus RTU **没有长度字段**，帧边界靠 3.5 字符时间的静默间隔识别（9600bps 下约 3.5ms）。这种情况下： * 推荐用 **方案 B**（`FrameInterval = 4` 左右）实现"Modbus 风格分帧" * 或直接使用 VBManLib 的 `cModbusMaster` / `cModbusSlave` 类，它们已内置 RTU 分帧 ### C4. 固定长度模式 适用于帧长度固定的协议（如某些传感器每帧固定 16 字节）： ```vb parser.SetFixedSizeMode 16 ' 每 16 字节切一帧 Do While parser.HasFrame() Dim frame() As Byte frame = parser.GetFrame() ' 处理 frame... Loop ``` ### 通用 API 无论哪种模式，对外接口统一： | 方法/属性 | 说明 | |----------|------| | `AppendData(Data() As Byte)` | 追加字节流到内部缓冲区 | | `HasFrame() As Boolean` | 检查缓冲区中是否有完整帧 | | `GetFrame() As Byte()` | 取出一帧并从缓冲区移除 | | `GetAllFrames() As Collection` | 取出所有可用帧（每元素为 Byte 数组） | | `Clear()` | 清空内部缓冲区 | | `BufferLength` | 只读，缓冲区剩余未解析字节数 | ```vb ' 一次性取出所有帧 Dim frames As Collection Set frames = parser.GetAllFrames() Dim v As Variant, frame() As Byte For Each v In frames frame = v Debug.Print StrConv(frame, vbUnicode) Next ``` *** ## B + C 组合实战 最高可靠性场景：先用方案 B 粗切（基于时间），再用方案 C 精切（基于协议）。这样即使设备帧间无停顿，也能正确分帧。 ### 典型场景 设备协议：`[STX][LEN][DATA][ETX]`，但设备可能连续发多帧无停顿。 ### 完整代码 ```vb Private WithEvents m_Port As cSerialPort Private m_Parser As cSerialFrameParser Private Sub Form_Load() Set m_Port = New cSerialPort Set m_Parser = New cSerialFrameParser ' 配置协议分帧（方案 C2：起止标记模式） m_Parser.SetStartEndMode Chr$(&H2), Chr$(&H3), True ' 配置串口 m_Port.PortName = "COM3" m_Port.Config.BaudRate = br115200 If m_Port.OpenPort() Then ' 启用时间分帧（方案 B） m_Port.FrameInterval = 50 ' 启动监控 m_Port.StartMonitoring 20 End If End Sub ' 方案 B 触发：每次"时间帧"到达 Private Sub m_Port_FrameReceived(FrameData() As Byte) ' 把时间帧喂给协议解析器 m_Parser.AppendData FrameData ' 方案 C 精切：从一个时间帧中切出多个协议帧 Do While m_Parser.HasFrame() Dim frame() As Byte frame = m_Parser.GetFrame() Debug.Print "完整协议帧: " & BytesToHex(frame) Loop End Sub Private Sub Form_Unload(Cancel As Integer) If Not m_Port Is Nothing Then If m_Port.IsOpen Then m_Port.ClosePort Set m_Port = Nothing End If End Sub ' 辅助：字节数组转十六进制字符串 Private Function BytesToHex(buf() As Byte) As String Dim i As Long, s As String For i = 0 To UBound(buf) s = s & Right$("0" & Hex$(buf(i)), 2) & " " Next BytesToHex = Trim$(s) End Function ``` ### 数据流示意 ``` 设备发送: [STX][LEN=3][A][B][C][ETX][STX][LEN=2][X][Y][ETX] (两帧无停顿) 方案B (FrameInterval=50ms): └─ 触发 FrameReceived(12字节) 方案C (SetStartEndMode): └─ 切出两帧: 1. [STX][LEN=3][A][B][C][ETX] 2. [STX][LEN=2][X][Y][ETX] ``` *** ## 方案选型建议 ``` 是否知道设备协议格式？ ├── 否 ──→ 用方案 B（FrameInterval = 30~50ms） │ └── 是 ──→ 协议有哪种特征？ ├── 有分隔符（\r\n 等） ──→ 方案 C1 ├── 有 STX/ETX 起止标记 ──→ 方案 C2 ├── 有长度字段 ──→ 方案 C3 ├── 固定长度 ──→ 方案 C4 └── 都没有，但帧间有停顿 ──→ 方案 B │ └── 可靠性要求高？ ├── 是 ──→ B + C 组合 └── 否 ──→ 仅 B ``` ### 各方案适用场景速查 | 设备类型 | 推荐方案 | 配置示例 | |---------|---------|---------| | GPS 模块（NMEA 0183） | C1 | `SetDelimiterMode vbCrLf, False` | | 温湿度传感器（文本输出） | C1 或 B | 分隔符 `"\r\n"` 或 `FrameInterval=50` | | RFID 读卡器（STX/ETX 协议） | C2 | `SetStartEndMode Chr(2), Chr(3), True` | | Modbus RTU | B 或专用类 | `FrameInterval=4`，或用 `cModbusMaster` | | 自定义二进制协议（带长度） | C3 | 见长度前缀示例 | | 电子秤（固定长度输出） | C4 | `SetFixedSizeMode 16` | | 工业仪表（不定时上报） | B | `FrameInterval=30` | *** ## 调参与排错 ### 常见问题 #### 1. 帧被切成两半 **现象**：本应一帧的数据被分成两次 `FrameReceived` 触发。 **原因**：`FrameInterval` 太小，设备发一帧中途有短暂停顿就被误判为帧结束。 **解决**：增大 `FrameInterval`。可用串口调试助手先观察设备单帧发送过程中的最大字节间隔。 #### 2. 多帧粘连成一帧 **现象**：本应是两帧的数据被合并成一次 `FrameReceived` 触发。 **原因**：`FrameInterval` 太大，设备发完一帧后停顿时间小于 `FrameInterval`。 **解决**：减小 `FrameInterval`，或改用方案 C 按协议精确分帧。 #### 3. 最后一帧丢失 **现象**：设备发完最后一帧后停止发送，但没有触发 `FrameReceived`。 **原因**：最后一帧之后没有后续数据来"推动"超时判定。 **解决**：这是已修复的问题。`StopMonitoring` 和 `ClosePort` 时会自动 flush 剩余缓冲区。如果你手动管理生命周期，确保停止前调用 `m_Port.FlushFrames`。 #### 4. 方案 C 解析不出帧 **排查步骤**： ```vb ' 1. 打印原始数据确认 Debug.Print "原始数据: " & BytesToHex(rawBytes) ' 2. 检查 BufferLength 是否在增长 Debug.Print "缓冲区长度: " & parser.BufferLength ' 3. 检查配置是否正确 Debug.Print "模式: " & parser.Mode ' 应为 1/2/3/4 Debug.Print "缓冲区: " & parser.BufferLength ' 4. 协议是否与配置匹配？ ' - 分隔符模式：检查分隔符字节是否正确 ' - 起止标记：确认 STX/ETX 字节值 ' - 长度前缀：用调试助手查看长度字段值，手算帧总长度是否匹配 ``` ### 调试辅助函数 ```vb ' 字节数组转十六进制字符串（调试用） Private Function BytesToHex(buf() As Byte) As String Dim i As Long, s As String On Error Resume Next For i = LBound(buf) To UBound(buf) s = s & Right$("0" & Hex$(buf(i)), 2) & " " Next BytesToHex = Trim$(s) End Function ' 字节数组转可见 ASCII（不可见字符显示为 .） Private Function BytesToAscii(buf() As Byte) As String Dim i As Long, s As String, b As Byte On Error Resume Next For i = LBound(buf) To UBound(buf) b = buf(i) If b >= 32 And b < 127 Then s = s & Chr$(b) Else s = s & "." End If Next BytesToAscii = s End Function ``` ### 性能注意事项 1. **`GetFrame()` 不复制大块内存**：内部使用 `CopyMemory` 高效搬运，单帧 MB 级也无压力。 2. **缓冲区自动扩容**：`AppendData` 时自动按需扩容，无需手动管理。 3. **避免在事件中耗时操作**：`FrameReceived` 事件回调中应尽快处理，不要做重计算或 UI 刷新，避免影响下一帧接收。 *** ## 完整 API 速查 ### cSerialPort 分帧相关 | 成员 | 类型 | 说明 | |------|------|------| | `FrameInterval` | 属性 | 帧间隔超时(ms)，0=禁用分帧 | | `MaxFrameSize` | 属性 | 单帧最大字节数（默认 65536） | | `FrameBufferLength` | 属性 | 只读，当前帧缓冲区字节数 | | `FrameReceived` | 事件 | 完整帧到达时触发（参数：`FrameData() As Byte`） | | `FlushFrames` | 方法 | 手动触发缓冲区中剩余的帧 | ### cSerialFrameParser 完整 API | 成员 | 类型 | 说明 | |------|------|------| | `Mode` | 属性 | 分帧模式（`fmNone/fmDelimiter/fmStartEnd/fmLengthPrefix/fmFixedSize`） | | `BufferLength` | 属性 | 只读，缓冲区剩余字节数 | | `AppendData` | 方法 | 追加字节流 | | `HasFrame` | 方法 | 检查是否有完整帧 | | `GetFrame` | 方法 | 取出一帧 | | `GetAllFrames` | 方法 | 取出所有帧 | | `Clear` | 方法 | 清空缓冲区 | | `SetDelimiterMode` | 方法 | 配置为分隔符模式 | | `SetStartEndMode` | 方法 | 配置为起止标记模式 | | `SetLengthPrefixMode` | 方法 | 配置为长度前缀模式 | | `SetFixedSizeMode` | 方法 | 配置为固定长度模式 | *** **最后更新**: 2026-07-05 --- --- url: /zh/packages/vbccr/text/windowedlabel.md description: 窗口化标签控件（WindowedLabel） - VBCCR 开发手册，基于源码的完整 API 参考 --- # 窗口化标签控件（WindowedLabel） 提供具有窗口句柄的标签控件，支持省略号显示、垂直对齐、自动换行和透明背景等增强功能。 ## 枚举 ### WlbEllipsisFormatConstants 省略号格式常量。 | 常量 | 值 | 说明 | |------|-----|------| | WlbEllipsisNone | 0 | 不显示省略号 | | WlbEllipsisEnd | 1 | 在文本末尾显示省略号 | | WlbEllipsisPath | 2 | 在路径中间显示省略号（保留文件名） | | WlbEllipsisWord | 3 | 在单词边界显示省略号 | ## 属性 ### Name ```vb Public Property Get Name() As String ``` 返回在代码中标识对象的名称。 ### Tag ```vb Public Property Get Tag() As String Public Property Let Tag(ByVal Value As String) ``` 存储程序所需的额外数据。 ### Parent ```vb Public Property Get Parent() As Object ``` 返回对象所在的对象。 ### Container ```vb Public Property Get Container() As Object Public Property Set Container(ByVal Value As Object) ``` 返回/设置对象的容器。 ### Left ```vb Public Property Get Left() As Single Public Property Let Left(ByVal Value As Single) ``` 返回/设置对象与其容器左边缘的距离。 ### Top ```vb Public Property Get Top() As Single Public Property Let Top(ByVal Value As Single) ``` 返回/设置对象与其容器顶边缘的距离。 ### Width ```vb Public Property Get Width() As Single Public Property Let Width(ByVal Value As Single) ``` 返回/设置对象的宽度。 ### Height ```vb Public Property Get Height() As Single Public Property Let Height(ByVal Value As Single) ``` 返回/设置对象的高度。 ### Visible ```vb Public Property Get Visible() As Boolean Public Property Let Visible(ByVal Value As Boolean) ``` 返回/设置对象是否可见。 ### ToolTipText ```vb Public Property Get ToolTipText() As String Public Property Let ToolTipText(ByVal Value As String) ``` 返回/设置鼠标悬停时显示的提示文本。 ### WhatsThisHelpID ```vb Public Property Get WhatsThisHelpID() As Long Public Property Let WhatsThisHelpID(ByVal Value As Long) ``` 返回/设置关联的上下文帮助ID。 ### DragIcon ```vb Public Property Get DragIcon() As IPictureDisp Public Property Let DragIcon(ByVal Value As IPictureDisp) Public Property Set DragIcon(ByVal Value As IPictureDisp) ``` 返回/设置拖放操作中显示的图标。 ### DragMode ```vb Public Property Get DragMode() As Integer Public Property Let DragMode(ByVal Value As Integer) ``` 返回/设置拖动模式。 ### hWnd ```vb Public Property Get hWnd() As LongPtr ``` 返回控件句柄。 ### Font ```vb Public Property Get Font() As StdFont Public Property Let Font(ByVal NewFont As StdFont) Public Property Set Font(ByVal NewFont As StdFont) ``` 返回/设置字体。 ### Appearance ```vb Public Property Get Appearance() As CCAppearanceConstants Public Property Let Appearance(ByVal Value As CCAppearanceConstants) ``` 返回/设置外观样式。参见通用枚举。 ### BackColor ```vb Public Property Get BackColor() As OLE_COLOR Public Property Let BackColor(ByVal Value As OLE_COLOR) ``` 返回/设置背景色。 ### ForeColor ```vb Public Property Get ForeColor() As OLE_COLOR Public Property Let ForeColor(ByVal Value As OLE_COLOR) ``` 返回/设置前景色。 ### Enabled ```vb Public Property Get Enabled() As Boolean Public Property Let Enabled(ByVal Value As Boolean) ``` 返回/设置对象是否能响应用户事件。 ### OLEDropMode ```vb Public Property Get OLEDropMode() As OLEDropModeConstants Public Property Let OLEDropMode(ByVal Value As OLEDropModeConstants) ``` 返回/设置对象是否可以作为OLE放置目标。 ### MousePointer ```vb Public Property Get MousePointer() As CCMousePointerConstants Public Property Let MousePointer(ByVal Value As CCMousePointerConstants) ``` 返回/设置鼠标悬停时显示的指针类型。参见通用枚举。 ### MouseIcon ```vb Public Property Get MouseIcon() As IPictureDisp Public Property Let MouseIcon(ByVal Value As IPictureDisp) Public Property Set MouseIcon(ByVal Value As IPictureDisp) ``` 返回/设置自定义鼠标图标。 ### MouseTrack ```vb Public Property Get MouseTrack() As Boolean Public Property Let MouseTrack(ByVal Value As Boolean) ``` 返回/设置是否在鼠标进入或离开控件时触发事件。 ### RightToLeft ```vb Public Property Get RightToLeft() As Boolean Public Property Let RightToLeft(ByVal Value As Boolean) ``` 返回/设置从右到左显示方向。 ### RightToLeftMode ```vb Public Property Get RightToLeftMode() As CCRightToLeftModeConstants Public Property Let RightToLeftMode(ByVal Value As CCRightToLeftModeConstants) ``` 返回/设置从右到左模式。参见通用枚举。 ### Alignment ```vb Public Property Get Alignment() As VBRUN.AlignmentConstants Public Property Let Alignment(ByVal Value As VBRUN.AlignmentConstants) ``` 返回/设置文本水平对齐方式。 ### BorderStyle ```vb Public Property Get BorderStyle() As CCBorderStyleConstants Public Property Let BorderStyle(ByVal Value As CCBorderStyleConstants) ``` 返回/设置边框样式。参见通用枚举。 ### Caption ```vb Public Property Get Caption() As String Public Property Let Caption(ByVal Value As String) ``` 返回/设置标签文本。 ### Default ```vb Public Property Get Default() As String Public Property Let Default(ByVal Value As String) ``` 返回/设置默认文本。 ### UseMnemonic ```vb Public Property Get UseMnemonic() As Boolean Public Property Let UseMnemonic(ByVal Value As Boolean) ``` 返回/设置是否处理助记符前缀（&字符）。 ### AutoSize ```vb Public Property Get AutoSize() As Boolean Public Property Let AutoSize(ByVal Value As Boolean) ``` 返回/设置是否自动调整大小以适应内容。 ### WordWrap ```vb Public Property Get WordWrap() As Boolean Public Property Let WordWrap(ByVal Value As Boolean) ``` 返回/设置是否自动换行。 ### SingleLine ```vb Public Property Get SingleLine() As Boolean Public Property Let SingleLine(ByVal Value As Boolean) ``` 返回/设置是否强制单行显示。 ### EllipsisFormat ```vb Public Property Get EllipsisFormat() As WlbEllipsisFormatConstants Public Property Let EllipsisFormat(ByVal Value As WlbEllipsisFormatConstants) ``` 返回/设置省略号格式。 ### MimicTextBox ```vb Public Property Get MimicTextBox() As Boolean Public Property Let MimicTextBox(ByVal Value As Boolean) ``` 返回/设置是否模拟文本框外观（3D边框+白色背景）。 ### VerticalAlignment ```vb Public Property Get VerticalAlignment() As CCVerticalAlignmentConstants Public Property Let VerticalAlignment(ByVal Value As CCVerticalAlignmentConstants) ``` 返回/设置垂直对齐方式。参见通用枚举。 ### Transparent ```vb Public Property Get Transparent() As Boolean Public Property Let Transparent(ByVal Value As Boolean) ``` 返回/设置是否使用透明背景。 ### DisplayedCaption ```vb Public Property Get DisplayedCaption() As String ``` 返回实际显示的文本（包含省略号处理后的结果）。 ## 方法 ### OLEDrag ```vb Public Sub OLEDrag() ``` 启动OLE拖放操作。 ### Drag ```vb Public Sub Drag(Optional ByRef Action As Variant) ``` 开始、结束或取消拖动操作。 ### ZOrder ```vb Public Sub ZOrder(Optional ByRef Position As Variant) ``` 设置Z顺序。 ### Refresh ```vb Public Sub Refresh() ``` 强制完全重绘对象。 ## 事件 ### Click ```vb Public Event Click() ``` 用户单击控件时触发。 ### DblClick ```vb Public Event DblClick() ``` 用户双击控件时触发。 ### Change ```vb Public Event Change() ``` Caption属性改变时触发。 ### MouseDown ```vb Public Event MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` 按下鼠标按钮时触发。 ### MouseMove ```vb Public Event MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` 移动鼠标时触发。 ### MouseUp ```vb Public Event MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` 释放鼠标按钮时触发。 ### MouseEnter ```vb Public Event MouseEnter() ``` 鼠标进入控件区域时触发。 ### MouseLeave ```vb Public Event MouseLeave() ``` 鼠标离开控件区域时触发。 ### OLECompleteDrag ```vb Public Event OLECompleteDrag(Effect As Long) ``` OLE拖放操作完成时触发。 ### OLEDragDrop ```vb Public Event OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single) ``` OLE拖放操作放置时触发。 ### OLEDragOver ```vb Public Event OLEDragOver(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single, State As Integer) ``` OLE拖放操作悬停时触发。 ### OLEGiveFeedback ```vb Public Event OLEGiveFeedback(Effect As Long, DefaultCursors As Boolean) ``` OLE拖放操作给反馈时触发。 ### OLESetData ```vb Public Event OLESetData(Data As DataObject, DataFormat As Integer) ``` OLE拖放操作设置数据时触发。 ### OLEStartDrag ```vb Public Event OLEStartDrag(Data As DataObject, AllowedEffects As Long) ``` OLE拖放操作开始时触发。 ## 代码示例 ### 基本用法 ```vb ' 设置窗口化标签 With WindowedLabel1 .Caption = "C:\Users\Documents\Very\Long\Path\FileName.txt" .AutoSize = False .EllipsisFormat = WlbEllipsisPath .VerticalAlignment = CCVerticalAlignmentCenter .WordWrap = False .SingleLine = True .UseMnemonic = False End With ' 监听文本变化 Private Sub WindowedLabel1_Change() Debug.Print "显示文本: " & WindowedLabel1.DisplayedCaption End Sub ' 模拟文本框外观的标签 With WindowedLabel1 .MimicTextBox = True .BorderStyle = CCBorderStyleSunken End With ``` --- --- url: /zh/emoji/0D00-0D7F.md --- # 德拉维族语 (Malayalam) 本页面展示了Unicode字符集中，位于U+0D00到U+0D7F范围的马拉雅拉姆文字符。马拉雅拉姆文是印度喀拉拉邦的官方文字，用于书写马拉雅拉姆语。 | 字符 | Unicode | VB函数值 | 名称 | |:---:|:---:|:---:|:---| | ഁ | U+0D01 | ChrW(\&H0D01) | 马拉雅拉姆文标记CANDRABINDU | | ം | U+0D02 | ChrW(\&H0D02) | 马拉雅拉姆文标记ANUSVARA | | ഃ | U+0D03 | ChrW(\&H0D03) | 马拉雅拉姆文标记VISARGA | | അ | U+0D05 | ChrW(\&H0D05) | 马拉雅拉姆文字母A | | ആ | U+0D06 | ChrW(\&H0D06) | 马拉雅拉姆文字母AA | | ഇ | U+0D07 | ChrW(\&H0D07) | 马拉雅拉姆文字母I | | ഈ | U+0D08 | ChrW(\&H0D08) | 马拉雅拉姆文字母II | | ഉ | U+0D09 | ChrW(\&H0D09) | 马拉雅拉姆文字母U | | ഊ | U+0D0A | ChrW(\&H0D0A) | 马拉雅拉姆文字母UU | | ഋ | U+0D0B | ChrW(\&H0D0B) | 马拉雅拉姆文字母VOCALIC R | --- --- url: /zh/packages/vbccr/ranges/animation.md description: 动画控件（Animation） - VBCCR 开发手册，基于源码的完整 API 参考 --- # 动画控件（Animation） 封装 SysAnimate32 系统动画控件，用于播放无声 AVI 动画。 ## 枚举 ### CCBackStyleConstants 参见通用枚举。 ## 属性 ### AutoPlay ```vb Property Get AutoPlay() As Boolean Property Let AutoPlay(ByVal Value As Boolean) ``` 自动播放，控件创建后立即开始播放。 ### BackStyle ```vb Property Get BackStyle() As CCBackStyleConstants Property Let BackStyle(ByVal Value As CCBackStyleConstants) ``` 背景样式，透明或不透明。 ### Center ```vb Property Get Center() As Boolean Property Let Center(ByVal Value As Boolean) ``` 是否将 AVI 动画居中显示。 ### RightToLeft ```vb Property Get RightToLeft() As Boolean Property Let RightToLeft(ByVal Value As Boolean) ``` 从右到左显示方向。 ### RightToLeftLayout ```vb Property Get RightToLeftLayout() As Boolean Property Let RightToLeftLayout(ByVal Value As Boolean) ``` 从右到左镜像布局。 ### RightToLeftMode ```vb Property Get RightToLeftMode() As CCRightToLeftModeConstants Property Let RightToLeftMode(ByVal Value As CCRightToLeftModeConstants) ``` 从右到左模式。参见通用枚举。 ### hWnd ```vb Property Get hWnd() As LongPtr ``` 动画控件的窗口句柄。 ### hWndUserControl ```vb Property Get hWndUserControl() As LongPtr ``` 用户控件的窗口句柄。 ### Font ```vb Property Get Font() As StdFont Property Let Font(ByVal NewFont As StdFont) Property Set Font(ByVal NewFont As StdFont) ``` 字体。 ### Enabled ```vb Property Get Enabled() As Boolean Property Let Enabled(ByVal Value As Boolean) ``` 是否可用。 ### MousePointer ```vb Property Get MousePointer() As CCMousePointerConstants Property Let MousePointer(ByVal Value As CCMousePointerConstants) ``` 鼠标指针样式。参见通用枚举。 ### MouseIcon ```vb Property Get MouseIcon() As IPictureDisp Property Let MouseIcon(ByVal Value As IPictureDisp) Property Set MouseIcon(ByVal Value As IPictureDisp) ``` 自定义鼠标图标。 ### MouseTrack ```vb Property Get MouseTrack() As Boolean Property Let MouseTrack(ByVal Value As Boolean) ``` 是否启用鼠标进入/离开跟踪。 ### Playing ```vb Property Get Playing() As Boolean ``` 是否正在播放。只读。 ### Name ```vb Property Get Name() As String ``` 控件名称。只读。 ### Tag ```vb Property Get Tag() As String Property Let Tag(ByVal Value As String) ``` 自定义数据。 ### Parent ```vb Property Get Parent() As Object ``` 父对象。只读。 ### Container ```vb Property Get Container() As Object Property Set Container(ByVal Value As Object) ``` 容器对象。 ### Left ```vb Property Get Left() As Single Property Let Left(ByVal Value As Single) ``` 左边距。 ### Top ```vb Property Get Top() As Single Property Let Top(ByVal Value As Single) ``` 顶边距。 ### Width ```vb Property Get Width() As Single Property Let Width(ByVal Value As Single) ``` 宽度。 ### Height ```vb Property Get Height() As Single Property Let Height(ByVal Value As Single) ``` 高度。 ### Visible ```vb Property Get Visible() As Boolean Property Let Visible(ByVal Value As Boolean) ``` 是否可见。 ### ToolTipText ```vb Property Get ToolTipText() As String Property Let ToolTipText(ByVal Value As String) ``` 工具提示文本。 ### HelpContextID ```vb Property Get HelpContextID() As Long Property Let HelpContextID(ByVal Value As Long) ``` 帮助上下文 ID。 ### WhatsThisHelpID ```vb Property Get WhatsThisHelpID() As Long Property Let WhatsThisHelpID(ByVal Value As Long) ``` "这是什么"帮助 ID。 ### DragIcon ```vb Property Get DragIcon() As IPictureDisp Property Let DragIcon(ByVal Value As IPictureDisp) Property Set DragIcon(ByVal Value As IPictureDisp) ``` 拖动图标。 ### DragMode ```vb Property Get DragMode() As Integer Property Let DragMode(ByVal Value As Integer) ``` 拖动模式。 ## 方法 ### Play ```vb Public Sub Play(Optional ByVal FromFrame As Variant, Optional ByVal ToFrame As Variant, Optional ByVal RepeatCount As Variant) ``` 播放动画。可指定起始帧、结束帧和重复次数。 ### StopPlay ```vb Public Sub StopPlay() ``` 停止播放动画。 ### LoadFile ```vb Public Sub LoadFile(ByVal PathName As String) ``` 从文件加载 AVI 动画。 ### LoadRes ```vb Public Sub LoadRes(ByVal ResourceID As Variant) ``` 从资源加载 AVI 动画。支持字符串或数字资源 ID。 ### Unload ```vb Public Sub Unload() ``` 卸载当前动画。 ### Refresh ```vb Public Sub Refresh() ``` 强制重绘控件。 ### OLEDrag ```vb Public Sub OLEDrag() ``` 启动 OLE 拖放操作。 ### Drag ```vb Public Sub Drag(Optional ByRef Action As Variant) ``` 开始、结束或取消拖动操作。 ### ZOrder ```vb Public Sub ZOrder(Optional ByRef Position As Variant) ``` 调整 Z 顺序。 ### SetFocus ```vb Public Sub SetFocus() ``` 获取焦点。 ### Move ```vb Public Sub Move(ByVal Left As Single, Optional ByVal Top As Variant, Optional ByVal Width As Variant, Optional ByVal Height As Variant) ``` 移动并调整控件位置和大小。 ## 事件 ### Click ```vb Public Event Click() ``` 单击。 ### DblClick ```vb Public Event DblClick() ``` 双击。 ### Change ```vb Public Event Change() ``` 动画状态改变时触发。 ### PreviewKeyDown ```vb Public Event PreviewKeyDown(KeyCode As Integer, Shift As Integer) ``` 按键前事件，在 KeyDown 之前触发。 ### PreviewKeyUp ```vb Public Event PreviewKeyUp(KeyCode As Integer, Shift As Integer) ``` 按键释放前事件，在 KeyUp 之前触发。 ### KeyDown ```vb Public Event KeyDown(KeyCode As Integer, Shift As Integer) ``` 按键按下。 ### KeyUp ```vb Public Event KeyUp(KeyCode As Integer, Shift As Integer) ``` 按键释放。 ### KeyPress ```vb Public Event KeyPress(KeyAscii As Integer) ``` 按键字符。 ### MouseDown ```vb Public Event MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` 鼠标按下。 ### MouseMove ```vb Public Event MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` 鼠标移动。 ### MouseUp ```vb Public Event MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` 鼠标释放。 ### MouseEnter ```vb Public Event MouseEnter() ``` 鼠标进入控件。 ### MouseLeave ```vb Public Event MouseLeave() ``` 鼠标离开控件。 ### OLECompleteDrag ```vb Public Event OLECompleteDrag(Effect As Long) ``` OLE 拖放完成。 ### OLEDragDrop ```vb Public Event OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single) ``` OLE 拖放落下。 ### OLEDragOver ```vb Public Event OLEDragOver(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single, State As Integer) ``` OLE 拖放悬停。 ### OLEGiveFeedback ```vb Public Event OLEGiveFeedback(Effect As Long, DefaultCursors As Boolean) ``` OLE 给出反馈。 ### OLESetData ```vb Public Event OLESetData(Data As DataObject, DataFormat As Integer) ``` OLE 设置数据。 ### OLEStartDrag ```vb Public Event OLEStartDrag(Data As DataObject, AllowedEffects As Long) ``` OLE 开始拖动。 ## 代码示例 ### 基本用法 ```vb ' 加载并播放 AVI 动画 Animation1.LoadFile "C:\Icons\filecopy.avi" Animation1.AutoPlay = True ' 从第 5 帧播放到第 20 帧，重复 3 次 Animation1.Play 5, 20, 3 ' 停止播放 Animation1.StopPlay ' 从资源加载 Animation1.LoadRes 101 ' 卸载动画 Animation1.Unload ``` --- --- url: /zh/emoji/2580-259F.md --- # 方块元素 (U+2580 - U+259F) 本节包含用于创建块状图形的字符，这些字符通常用于制作简单的图形界面或进度条等显示元素。 | 字符 | Unicode | VB函数值 | 名称 | |:---:|:---:|:---:|:---| | ▀ | U+2580 | ChrW(\&H2580) | 上半方块 | | ▁ | U+2581 | ChrW(\&H2581) | 下八分之一方块 | | ▂ | U+2582 | ChrW(\&H2582) | 下四分之一方块 | | ▃ | U+2583 | ChrW(\&H2583) | 下八分之三方块 | | ▄ | U+2584 | ChrW(\&H2584) | 下半方块 | | ▅ | U+2585 | ChrW(\&H2585) | 下八分之五方块 | | ▆ | U+2586 | ChrW(\&H2586) | 下四分之三方块 | | ▇ | U+2587 | ChrW(\&H2587) | 下八分之七方块 | | █ | U+2588 | ChrW(\&H2588) | 实心方块 | | ▉ | U+2589 | ChrW(\&H2589) | 左七八方块 | | ▊ | U+258A | ChrW(\&H258A) | 左四分之三方块 | | ▋ | U+258B | ChrW(\&H258B) | 左五八方块 | | ▌ | U+258C | ChrW(\&H258C) | 左半方块 | | ▍ | U+258D | ChrW(\&H258D) | 左三八方块 | | ▎ | U+258E | ChrW(\&H258E) | 左四分之一方块 | | ▏ | U+258F | ChrW(\&H258F) | 左八分之一方块 | | ▐ | U+2590 | ChrW(\&H2590) | 右半方块 | | ░ | U+2591 | ChrW(\&H2591) | 浅色阴影 | | ▒ | U+2592 | ChrW(\&H2592) | 中等阴影 | | ▓ | U+2593 | ChrW(\&H2593) | 深色阴影 | | ▔ | U+2594 | ChrW(\&H2594) | 上八分之一方块 | | ▕ | U+2595 | ChrW(\&H2595) | 右八分之一方块 | | ▖ | U+2596 | ChrW(\&H2596) | 左下四分之一方块 | | ▗ | U+2597 | ChrW(\&H2597) | 右下四分之一方块 | | ▘ | U+2598 | ChrW(\&H2598) | 左上四分之一方块 | | ▙ | U+2599 | ChrW(\&H2599) | 左上三分之一方块 | | ▚ | U+259A | ChrW(\&H259A) | 右上左下四分之一方块 | | ▛ | U+259B | ChrW(\&H259B) | 左上和左下和右上四分之一方块 | | ▜ | U+259C | ChrW(\&H259C) | 左上和右上四分之一方块 | | ▝ | U+259D | ChrW(\&H259D) | 右上四分之一方块 | | ▞ | U+259E | ChrW(\&H259E) | 左下和右上四分之一方块 | | ▟ | U+259F | ChrW(\&H259F) | 右下四分之一方块 | --- --- url: /zh/vbman/winsock/packet-protocol.md --- # 分包协议与心跳机制 > 📦💓 解决 TCP 粘包/分包问题的内置协议，以及保持连接活跃的智能心跳 ## 📖 目录 * [概述](#概述) * [TCP 粘包与分包问题](#tcp-粘包与分包问题) * [封包协议](#封包协议) * [安全限制属性](#安全限制属性) * [事件模型](#事件模型) * [智能心跳机制](#智能心跳机制) * [UDP 协议支持](#udp-协议支持) * [完整示例](#完整示例) * [最佳实践](#最佳实践) * [常见问题](#常见问题) *** ## 概述 TCP 是流式协议，没有消息边界——发送方连续发送的数据，接收方可能分多次收到（分包），也可能一次收到多条消息拼接的数据（粘包）。cWinsock 内置封包协议 `cPacketProtocol` 和智能心跳 `cHeartbeat`，自动解决这些问题： * **封包协议**：三种内置协议，自动封包/解包，保证每次收到的都是完整消息 * **心跳机制**：内嵌定时器自动驱动，服务端超时检测 + 客户端智能保活 *** ## TCP 粘包与分包问题 ### 什么是粘包/分包？ | 现象 | 术语 | 说明 | |------|------|------| | 一次 Send 的数据，分多次 Receive 到达 | **分包** | 发了 1000 字节，先收到 300，再收到 700 | | 多次 Send 的数据，一次 Receive 全到 | **粘包** | 连续发了 3 条消息，一次收到拼接在一起的数据 | | 上面两种混合出现 | **最常见** | 收到的数据既不完整又混着下一条的开头 | ### 现象图解 ``` 应用层发送：[Msg1][Msg2][Msg3] ↓ TCP 流式传输（无边界） 接收端可能收到： 情况1（分包）： [Msg1前半] [Msg1后半+Msg2前半] [Msg2后半+Msg3] 情况2（粘包）： [Msg1+Msg2] [Msg3] 情况3（混合）： [Msg1前半] [Msg1后半+Msg2] [Msg3前半] [Msg3后半] 理想情况（少见）：[Msg1] [Msg2] [Msg3] ``` ### cPacketProtocol 的解决思路 在数据中定义明确的边界，将无界的字节流还原为有界的消息： ``` 原始 TCP 字节流（无边界）： [Msg1前半][Msg1后半+Msg2前半][Msg2后半] ↓ cPacketProtocol.Decode() 完整消息： [Msg1 完整] → 触发 MessageArrival [Msg2 完整] → 触发 MessageArrival ``` *** ## 封包协议 ### 三种协议对比 | 协议类型 | 原理 | 分包处理 | 粘包处理 | 优缺点 | |----------|------|----------|----------|--------| | `ppLengthHeader` | 头部指明消息体长度 | 长度不够则缓存，等数据到齐再提取 | 长度够了就切一条，剩余继续解析 | **推荐**。不依赖数据内容，不限消息长度 | | `ppDelimiter` | 分隔符标记消息结尾 | 未找到分隔符则缓存 | 找到分隔符就切一条，剩余继续找 | 简单，但分隔符不能出现在消息体中 | | `ppFixedLength` | 每条消息固定长度 | 不足定长则缓存 | 凑够定长就切一条 | 仅适用于定长消息场景 | ### 推荐方案：ppLengthHeader 4 字节小端长度头协议是最通用的选择： * 不依赖数据内容中出现特殊字符（分隔符协议的硬伤） * 不限制单条消息长度（定长协议的硬伤） * 每条消息自带长度，接收端精确知道要读多少字节 *** ### ppDelimiter - 分隔符协议 使用指定的字符/字符串作为消息边界标记。 **适用场景**：文本协议、行式命令协议（如聊天、HTTP 头部） ```vb ' 配置 m_oServer.PacketProtocol = ppDelimiter m_oServer.Delimiter = vbCrLf ' 换行分隔 ' 发送自动追加分隔符 Client.SendData "Hello" ' 实际发送: "Hello" + vbCrLf ' 接收自动去除分隔符 Private Sub m_oServer_MessageArrival(Client As cWinsock, ByVal bytesTotal As Long) Debug.Print "完整消息: " & Client.GetDataText() ' "Hello" End Sub ``` **常用分隔符**： | 分隔符 | 常量 | 适用场景 | |--------|------|----------| | `\r\n` | `vbCrLf` | 行式文本协议 | | `\n` | `vbLf` | Unix 风格行协议 | | `\0` | `vbNullChar` | C 字符串风格 | | 自定义字符串 | `""` | 自定义协议 | **注意**：分隔符不能出现在消息体中，否则消息会被错误拆分。 *** ### ppFixedLength - 定长协议 每条消息固定长度，适用于已知长度的结构化数据。 **适用场景**：状态包、传感器数据、固定格式报文 ```vb ' 配置 m_oServer.PacketProtocol = ppFixedLength m_oServer.FixedLength = 256 ' 每条消息固定 256 字节 ' 发送：不足 256 字节会补零，超过 256 字节会报错 Client.SendData myData ``` **注意**：数据超长时会直接报错（不会静默截断）。 *** ### ppLengthHeader - 长度头协议（推荐） 在消息头部添加长度信息，最通用、最推荐的协议。 **适用场景**：二进制协议、变长消息、任何需要可靠传输的场景 ```vb ' 配置 m_oServer.PacketProtocol = ppLengthHeader m_oServer.HeaderBytes = 4 ' 4字节长度头（支持最大约4GB） m_oServer.HeaderEndian = eeLittleEndian ' 小端序 ' 发送自动加长度头 Client.SendData "Hello" ' 实际发送: [4字节长度=5] + "Hello" ' 接收自动剥离长度头 Private Sub m_oServer_MessageArrival(Client As cWinsock, ByVal bytesTotal As Long) Dim baData() As Byte baData = Client.GetDataByteArray() ' 100% 是一条完整消息 End Sub ``` **HeaderBytes 选项**： | 值 | 类型 | 最大消息长度 | 说明 | |-----|------|------------|------| | 2 | Unsigned Integer | 65,535 字节（~64KB） | 小消息场景，节省带宽 | | 4 | Unsigned Long | 2,147,483,647 字节（~2GB） | 通用场景，推荐 | **HeaderEndian 字节序**： | 值 | 说明 | 适用场景 | |-----|------|----------| | `eeLittleEndian` | 小端序（默认） | x86/x64 平台内部通信 | | `eeBigEndian` | 大端序（网络字节序） | 与 Java/C 服务端通信 | *** ## 安全限制属性 防止恶意数据包耗尽内存，2026-06-09 新增： ### MaxPacketSize 单包最大大小限制，防止恶意超大包声明耗尽内存。 ```vb Property Get MaxPacketSize() As Long Property Let MaxPacketSize(ByVal Value As Long) ``` * **默认值**：1MB（1048576 字节） * **作用**：长度头协议解析时，如果声明的消息长度超过此值，直接报错丢弃 * **适用协议**：`ppLengthHeader` ```vb ' 调整最大包限制 m_oServer.MaxPacketSize = 524288 ' 512KB ' 新客户端自动继承此配置 ``` ### MaxBufferSize 缓冲区累积上限，防止大量不完整包慢慢吃内存。 ```vb Property Get MaxBufferSize() As Long Property Let MaxBufferSize(ByVal Value As Long) ``` * **默认值**：4MB（4194304 字节） * **作用**：Decode 合并缓冲区前检查，超限报错 * **适用协议**：所有协议 ```vb ' 调整缓冲区上限 m_oServer.MaxBufferSize = 8388608 ' 8MB ``` ### 超限行为 | 超限类型 | 行为 | |----------|------| | 单包超过 `MaxPacketSize` | 抛出明确错误信息，丢弃缓冲区 | | 累积超过 `MaxBufferSize` | 抛出明确错误信息，丢弃缓冲区 | | 数据超长（FixedLength） | 抛出错误（不静默截断） | *** ## 事件模型 ### 协议模式与无协议模式的区别 | 模式 | 触发事件 | 说明 | |------|----------|------| | 无协议（`ppNone`） | `DataArrival` | 原始字节流，可能不完整或粘连 | | 有协议 | `MessageArrival` | 每次一定是完整的一条消息 | **关键规则**：协议模式下**只触发 `MessageArrival`**，不触发 `DataArrival`，避免同一数据被两个事件重复读取。 ### MessageArrival 事件 ```vb Private Sub object_MessageArrival(Client As cWinsock, ByVal bytesTotal As Long) ``` | 参数 | 类型 | 说明 | |------|------|------| | `Client` | cWinsock | 接收消息的客户端对象 | | `bytesTotal` | Long | 完整消息的字节数 | ### 使用示例 ```vb ' 设置长度头协议 m_oServer.PacketProtocol = ppLengthHeader m_oServer.HeaderBytes = 4 m_oServer.HeaderEndian = eeLittleEndian ' 接收完整消息 Private Sub m_oServer_MessageArrival(Client As cWinsock, ByVal bytesTotal As Long) ' 此时缓冲区中已是完整消息，100% 完整 Dim sData As String sData = Client.GetDataText() Debug.Print "完整消息: " & sData End Sub ``` ### 与 DataArrival 的区别 | 事件 | 触发时机 | 数据完整性 | 适用场景 | |------|----------|-----------|----------| | `DataArrival` | 每次收到原始数据 | 可能是分片或粘包数据 | 无协议模式 | | `MessageArrival` | 协议解析出完整消息后 | 保证是一条完整消息 | 协议模式 | *** ## 智能心跳机制 cWinsock 内置 `cHeartbeat` 心跳管理器，内嵌 `cTimer` 自动驱动，无需外部定时器。 ### 服务端：超时检测 服务端定期检查所有客户端的空闲时间，超时则自动断开僵尸连接。 ```vb ' 配置 m_oServer.AutoHeartbeat = True m_oServer.HeartbeatTimeout = 120 ' 2分钟无活动则超时 ' 超时事件 Private Sub m_oServer_ClientTimeout(Client As cWinsock) Debug.Print "客户端 " & Client.Tag & " 超时，已自动断开" End Sub ``` ### 客户端：心跳保活 客户端定期发送心跳包，保持连接活跃。具有智能跳过机制——有数据收发时跳过心跳，节省带宽。 ```vb ' 配置 m_oClient.AutoHeartbeat = True m_oClient.HeartbeatInterval = 50 ' 50秒无活动则发心跳 ' 心跳事件 Private Sub m_oClient_HeartbeatSent(Client As cWinsock) Debug.Print "心跳已发送，空闲: " & Client.IdleSeconds & "秒" End Sub ``` ### 自定义心跳包 ```vb ' 默认心跳包为单字节 &H00，可自定义 Dim baHB(0 To 3) As Byte baHB(0) = &H50 ' P baHB(1) = &H49 ' I baHB(2) = &H4E ' N baHB(3) = &H47 ' G m_oClient.HeartbeatData = baHB ``` ### 心跳与协议的一致性 心跳数据经过协议编码发送，不会污染协议状态机。即： * 心跳包通过 `SendData` 发送，会经过协议 `Encode` * 接收端心跳数据经过协议 `Decode` * 心跳不会导致粘包/分包状态混乱 ### 工作原理 1. 心跳管理器内嵌 `cTimer`，每 10 秒触发一次 Tick 2. **服务端**：检查所有客户端的 `IdleSeconds`，超时则触发 `ClientTimeout` 并自动断开 3. **客户端**：如果空闲超过 `HeartbeatInterval` 则发送心跳包，有数据收发时智能跳过 4. 每次收发数据自动重置 `LastActivityTime` ### 心跳相关属性 | 属性 | 类型 | 读写 | 说明 | |------|------|------|------| | `AutoHeartbeat` | Boolean | 读写 | 启用/禁用自动心跳 | | `HeartbeatTimeout` | Long | 读写 | 服务端超时秒数（默认120） | | `HeartbeatInterval` | Long | 读写 | 客户端心跳间隔秒数（默认50） | | `HeartbeatData` | Byte() | 读写 | 心跳包内容（默认单字节0） | | `IdleSeconds` | Long | 只读 | 当前空闲秒数 | *** ## UDP 协议支持 UDP 客户端同样支持分包协议。UDP 虽然是报文协议（天然有边界），但协议模式仍然可以用于： * 自定义消息格式处理 * 与 TCP 端共享协议逻辑 * 利用安全限制属性 ```vb ' UDP 服务端设置协议 m_oUdp.PacketProtocol = ppLengthHeader m_oUdp.HeaderBytes = 4 m_oUdp.MaxPacketSize = 65536 ' UDP 单包通常不超过 64KB ' UDP 虚拟客户端自动继承协议配置 Private Sub m_oUdp_MessageArrival(Client As cWinsock, ByVal bytesTotal As Long) Dim sData As String sData = Client.GetDataText() Debug.Print "UDP 完整消息: " & sData End Sub ``` *** ## 完整示例 ### TCP 服务端 + 长度头协议 + 心跳 ```vb Private WithEvents m_oServer As cWinsock Private Sub Form_Load() Set m_oServer = New cWinsock ' 设置封包协议（推荐：长度头协议） m_oServer.PacketProtocol = ppLengthHeader m_oServer.HeaderBytes = 4 m_oServer.HeaderEndian = eeLittleEndian m_oServer.MaxPacketSize = 1048576 ' 1MB m_oServer.MaxBufferSize = 4194304 ' 4MB ' 设置心跳 m_oServer.AutoHeartbeat = True m_oServer.HeartbeatTimeout = 120 ' 2分钟超时 ' 启动服务器 m_oServer.Listen 8080 Debug.Print "服务器已启动" End Sub Private Sub m_oServer_ConnectionRequest(Client As cWinsock, ByRef DisConnect As Boolean) Debug.Print "新客户端: " & Client.RemoteHostIP & ":" & Client.RemotePort ' 新客户端自动继承协议和心跳配置 End Sub Private Sub m_oServer_MessageArrival(Client As cWinsock, ByVal bytesTotal As Long) ' 100% 是完整消息 Dim sData As String sData = Client.GetDataText() Debug.Print "[" & Client.Tag & "] " & sData ' 回显 Client.SendData "Echo: " & sData End Sub Private Sub m_oServer_ClientTimeout(Client As cWinsock) Debug.Print "客户端超时: " & Client.Tag End Sub Private Sub m_oServer_CloseEvent(Client As cWinsock) Debug.Print "客户端断开: " & Client.Tag End Sub Private Sub Form_Unload(Cancel As Integer) On Error Resume Next m_oServer.Close_ End Sub ``` ### TCP 客户端 + 长度头协议 + 心跳 ```vb Private WithEvents m_oClient As cWinsock Private Sub Form_Load() Set m_oClient = New cWinsock ' 设置封包协议（必须与服务端一致） m_oClient.PacketProtocol = ppLengthHeader m_oClient.HeaderBytes = 4 m_oClient.HeaderEndian = eeLittleEndian ' 设置心跳 m_oClient.AutoHeartbeat = True m_oClient.HeartbeatInterval = 50 ' 50秒间隔 ' 连接 m_oClient.Connect "127.0.0.1", 8080 End Sub Private Sub m_oClient_Connect(Client As cWinsock) Debug.Print "已连接" Client.SendData "Hello, Server!" End Sub Private Sub m_oClient_MessageArrival(Client As cWinsock, ByVal bytesTotal As Long) Dim sData As String sData = Client.GetDataText() Debug.Print "收到: " & sData End Sub Private Sub m_oClient_HeartbeatSent(Client As cWinsock) Debug.Print "心跳已发送" End Sub Private Sub Form_Unload(Cancel As Integer) On Error Resume Next m_oClient.Close_ End Sub ``` ### 聊天服务端 + 分隔符协议 ```vb Private WithEvents m_oServer As cWinsock Private Sub Form_Load() Set m_oServer = New cWinsock ' 使用换行符作为消息分隔符 m_oServer.PacketProtocol = ppDelimiter m_oServer.Delimiter = vbCrLf ' 心跳保活 m_oServer.AutoHeartbeat = True m_oServer.HeartbeatTimeout = 180 m_oServer.Listen 9090 End Sub Private Sub m_oServer_MessageArrival(Client As cWinsock, ByVal bytesTotal As Long) Dim sMsg As String sMsg = Client.GetDataText() ' 广播给所有客户端 Dim oClient As cWinsock For Each oClient In m_oServer.Clients If Not oClient Is Client Then oClient.SendData "[" & Client.Tag & "] " & sMsg End If Next End Sub ``` *** ## 最佳实践 ### 1. 选择合适的协议类型 | 协议类型 | 适用场景 | 优缺点 | |----------|----------|--------| | `ppLengthHeader` | 二进制协议、变长消息 | 最通用，推荐 | | `ppDelimiter` | 文本协议（聊天、命令行式） | 简单直观，但数据中不能包含分隔符 | | `ppFixedLength` | 固定格式消息（状态包、传感器数据） | 解析最快，但不灵活 | ### 2. 协议模式下使用 MessageArrival ```vb ' ✅ 正确：协议模式下使用 MessageArrival Private Sub m_oServer_MessageArrival(Client As cWinsock, ByVal bytesTotal As Long) Dim sData As String sData = Client.GetDataText() ' 保证是完整消息 End Sub ' ❌ 错误：协议模式下使用 DataArrival ' 协议模式下 DataArrival 不会触发 ``` ### 3. 长度头协议的字节序 ```vb ' 与 C/Java 服务端通信时用大端序 m_oServer.HeaderEndian = eeBigEndian ' 纯 VB6 内部通信可用小端序（默认） m_oServer.HeaderEndian = eeLittleEndian ``` ### 4. 配置安全限制 ```vb ' 根据业务需求调整安全限制 m_oServer.MaxPacketSize = 524288 ' 512KB，单包最大 m_oServer.MaxBufferSize = 8388608 ' 8MB，缓冲区最大 ``` ### 5. 服务器配置协议在 Listen 之前 ```vb ' ✅ 正确：Listen 之前设置协议 m_oServer.PacketProtocol = ppLengthHeader m_oServer.HeaderBytes = 4 m_oServer.Listen 8080 ' 新客户端自动继承服务器配置，创建独立协议实例 ``` ### 6. 心跳与协议配合 心跳包走协议编码，不会污染协议状态机，无需手动过滤心跳。 *** ## 常见问题 ### ❓ 为什么要用封包协议？ TCP 是流式协议，没有消息边界。不使用协议时，`DataArrival` 可能收到不完整或粘连的数据，需要手动拼接/拆分，容易出错。使用封包协议后，`MessageArrival` 每次触发的都是一条完整消息，开发者无需关心底层字节流的分合。 ### ❓ MaxPacketSize 和 MaxBufferSize 有什么区别？ * `MaxPacketSize`：单条消息的最大长度，针对长度头协议中声明的消息体长度 * `MaxBufferSize`：接收缓冲区的累积上限，防止大量不完整包慢慢吃内存 ### ❓ 协议模式下还会触发 DataArrival 吗？ 不会。协议模式下**只触发 `MessageArrival`**，避免同一数据被两个事件重复读取。无协议模式下仍触发 `DataArrival`。 ### ❓ 心跳包会影响协议解析吗？ 不会。心跳数据经过协议编码发送和接收，不会污染协议状态机。 ### ❓ UDP 需要用封包协议吗？ UDP 天然有消息边界，不需要封包协议来解决粘包问题。但 UDP 客户端同样支持协议模式，可用于统一消息格式、利用安全限制属性等场景。 ### ❓ 2 字节长度头能传多大消息？ 2 字节头可表示 0~65535（最大约 64KB）。超过 65535 字节会报错。建议大数据使用 4 字节头。 *** ## 相关文档 | 文档 | 描述 | |------|------| | [属性参考](./properties.md) | 协议和心跳相关的属性详细说明 | | [事件详解](./events.md) | MessageArrival、ClientTimeout 等事件 | | [方法参考](./methods.md) | GetDataText、GetDataByteArray 等方法 | | [TCP编程](./tcp.md) | TCP 客户端和服务器编程指南 | | [最佳实践](./best-practices.md) | 常见场景的解决方案和性能优化建议 | *** **最后更新**: 2026-06-09 --- --- url: /zh/vbman/database/pagination.md --- # 分页功能 本文档详细介绍 cDataBase 类的分页查询功能，支持 SQL Server、MySQL、Access 等数据库。 *** ## ? 目录 * [分页概述](#分页概述) * [Page 方法](#page-方法) * [支持的数据库](#支持的数据库) * [使用示例](#使用示例) * [性能优化](#性能优化) * [常见问题](#常见问题) *** ## 分页概述 ### 什么是分页 分页是将大量数据分成多个页面显示的技术，每页显示固定数量的记录。 ### 分页的优势 * **性能优化** - 只查询需要的数据，减少内存占用 * **用户体验** - 快速加载，避免长时间等待 * **资源节约** - 减少网络传输和数据库负载 ### 分页原理 cDataBase 的分页功能使用 **ADO 原生分页属性**（`Rs.PageSize` 和 `Rs.AbsolutePage`）实现，**不修改 SQL 语句**。这意味着： * 分页对所有数据库类型（SQL Server、MySQL、Access、CSV）均有效 * 无需针对不同数据库编写不同的分页 SQL * 需要使用支持 `AbsolutePage` 的游标类型（如 `adOpenKeyset`） ``` 总记录数: 1000 每页显示: 10 总页数: 100 第 1 页: Rs.AbsolutePage = 1, Rs.PageSize = 10 第 2 页: Rs.AbsolutePage = 2, Rs.PageSize = 10 第 3 页: Rs.AbsolutePage = 3, Rs.PageSize = 10 ... ``` *** ## Page 方法 ### 语法 ```vb Function Page(Optional num As Long = 1, Optional Limit As Long = 10) As cDataBase ``` ### 参数说明 | 参数 | 类型 | 说明 | | ------- | ------ | --------------------------- | | `num` | `Long` | 页码（可选，默认 1） | | `Limit` | `Long` | 每页记录数（可选，默认 10） | ### 返回值 返回 `cDataBase` 对象，支持链式调用。 ### 示例 ```vb ' 查询第 1 页，每页 10 条 db.Sql("SELECT * FROM users").Page(1, 10).Query ' 查询第 2 页，每页 20 条 db.Sql("SELECT * FROM users").Page(2, 20).Query ``` *** ## 支持的数据库 分页使用 ADO 原生分页属性实现，**所有数据库类型通用**，无需针对不同数据库编写不同的 SQL。 ### 实现原理 `Page` 方法设置分页参数后，`Query` 或 `Fetch` 方法在打开 Recordset 后自动应用： ```vb ' 内部实现（源码） Rs.Open pvRawSqlString, Conn, CurType, LockType, Options If IsPage Then Rs.PageSize = pvPageLimit ' 设置每页记录数 Rs.AbsolutePage = pvPageNum ' 设置当前页码 IsPage = False End If ``` ### 注意事项 1. **游标类型要求**：分页需要使用支持 `AbsolutePage` 的游标类型（默认 `adOpenKeyset` 即可支持） 2. **不建议使用 `adOpenForwardOnly`**：仅向前游标不支持 `AbsolutePage`，分页将无法正常工作 3. **SQL 语句不变**：分页不会修改原始 SQL，SQL 保持原样执行，分页由 ADO 在 Recordset 层面处理 *** ## 使用示例 ### 示例 1：基本分页 ```vb ' 查询第 1 页，每页 10 条 If db.Sql("SELECT * FROM users").Page(1, 10).Fetch Then Dim i As Long For i = 1 To db.Rows.Count Debug.Print db.Rows(i)("name") Next End If ``` ### 示例 2：带排序的分页 ```vb ' 按年龄降序排列，分页显示 If db.Sql("SELECT * FROM users ORDER BY age DESC").Page(2, 10).Fetch Then Dim i As Long For i = 1 To db.Rows.Count Debug.Print db.Rows(i)("name") & " - " & db.Rows(i)("age") Next End If ``` ### 示例 3：条件查询分页 ```vb ' 查询年龄大于 18 的用户，分页显示 If db.Sql("SELECT * FROM users WHERE age > 18").Page(1, 20).Fetch Then Dim i As Long For i = 1 To db.Rows.Count Debug.Print db.Rows(i)("name") Next End If ``` ### 示例 4：获取总记录数 ```vb ' 查询总数 Dim lTotal As Long lTotal = db.Count("users") ' 计算总页数 Dim lPageSize As Long lPageSize = 10 Dim lTotalPages As Long lTotalPages = Int((lTotal + lPageSize - 1) / lPageSize) ' 分页查询 If db.Sql("SELECT * FROM users").Page(1, lPageSize).Fetch Then ' 显示数据 End If ``` ### 示例 5：完整分页函数 ```vb ' 分页查询函数 Function GetUsersPage(lPage As Long, lPageSize As Long) As Collection Set GetUsersPage = New Collection ' 查询数据 If db.Sql("SELECT * FROM users ORDER BY id").Page(lPage, lPageSize).Fetch Then Set GetUsersPage = db.Rows End If End Function ' 使用 Dim colUsers As Collection Set colUsers = GetUsersPage(1, 10) ``` ### 示例 6：分页导航 ```vb ' 分页导航类 Private m_lCurrentPage As Long Private m_lPageSize As Long Private m_lTotalRecords As Long Private Sub LoadPage(lPage As Long) ' 验证页码 If lPage < 1 Then lPage = 1 Dim lTotalPages As Long lTotalPages = Int((m_lTotalRecords + m_lPageSize - 1) / m_lPageSize) If lPage > lTotalPages Then lPage = lTotalPages m_lCurrentPage = lPage ' 查询数据 If db.Sql("SELECT * FROM users ORDER BY id").Page(lPage, m_lPageSize).Fetch Then ' 显示数据 DisplayUsers End If End Sub Private Sub cmdNextPage_Click() LoadPage m_lCurrentPage + 1 End Sub Private Sub cmdPrevPage_Click() LoadPage m_lCurrentPage - 1 End Sub ``` *** ## 性能优化 ### 1. 使用索引字段排序 ```vb ' ? 推荐：使用索引字段排序 db.Sql("SELECT * FROM users ORDER BY id").Page(1, 10).Query ' ? 不推荐：使用非索引字段排序 db.Sql("SELECT * FROM users ORDER BY name").Page(1, 10).Query ``` ### 2. 只查询需要的字段 ```vb ' ? 推荐：只查询需要的字段 db.Sql("SELECT id, name FROM users").Page(1, 10).Query ' ? 不推荐：查询所有字段 db.Sql("SELECT * FROM users").Page(1, 10).Query ``` ### 3. 使用 WHERE 条件限制 ```vb ' ? 推荐：使用 WHERE 条件 db.Sql("SELECT * FROM users WHERE status = 'active'").Page(1, 10).Query ' ? 不推荐：查询所有数据再分页 db.Sql("SELECT * FROM users").Page(1, 10).Query ``` ### 4. 合理设置每页记录数 ```vb ' ? 推荐：合理的每页记录数（10-50） db.Sql("SELECT * FROM users").Page(1, 20).Query ' ? 不推荐：每页记录数过大 db.Sql("SELECT * FROM users").Page(1, 1000).Query ``` *** ## 常见问题 ### Q1: 分页后 RecordCount 返回 -1 **原因**: 使用了 `adOpenForwardOnly` 游标类型，不支持 `RecordCount` 和 `AbsolutePage`。 **解决**: * 使用 `adOpenKeyset` 或 `adOpenStatic` 游标类型（默认即是 `adOpenKeyset`） * 分页查询不建议使用 `adOpenForwardOnly` ### Q2: 分页时 AbsolutePage 设置失败 **原因**: 游标类型不支持 `AbsolutePage` 属性。 **解决**: * 确保使用 `adOpenKeyset`（默认）或 `adOpenStatic` 游标类型 * 检查 SQL 语句是否正确执行并返回结果 ### Q3: 如何获取总记录数？ ```vb ' 方法 1：使用 Count 方法 Dim lTotal As Long lTotal = db.Count("users") ' 方法 2：使用 COUNT(*) 查询 If db.Sql("SELECT COUNT(*) AS cnt FROM users").Fetch Then lTotal = db.Row("cnt") End If ``` ### Q4: 分页后如何保持排序？ ```vb ' ? 正确：在 SQL 中包含 ORDER BY db.Sql("SELECT * FROM users ORDER BY age DESC").Page(1, 10).Query ' ? 错误：分页后再排序（会丢失排序） db.Sql("SELECT * FROM users").Page(1, 10).Query ' 然后对结果排序（只对当前页排序，不是全局排序） ``` ### Q5: 如何实现跳转到指定页？ ```vb Function GoToPage(lPage As Long, lPageSize As Long) As Boolean ' 验证页码 If lPage < 1 Then lPage = 1 ' 查询指定页 If db.Sql("SELECT * FROM users ORDER BY id").Page(lPage, lPageSize).Fetch Then GoToPage = True Else GoToPage = False End If End Function ``` *** ## 最佳实践 ### 1. 始终使用 ORDER BY ```vb ' ? 推荐：使用 ORDER BY 保证顺序 db.Sql("SELECT * FROM users ORDER BY id").Page(1, 10).Query ' ? 不推荐：不使用 ORDER BY（顺序不确定） db.Sql("SELECT * FROM users").Page(1, 10).Query ``` ### 2. 验证页码和每页记录数 ```vb ' ? 推荐：验证参数 Function GetPage(lPage As Long, lPageSize As Long) As Collection If lPage < 1 Then lPage = 1 If lPageSize < 1 Then lPageSize = 10 If lPageSize > 100 Then lPageSize = 100 ' 限制最大每页记录数 If db.Sql("SELECT * FROM users ORDER BY id").Page(lPage, lPageSize).Fetch Then Set GetPage = db.Rows End If End Function ``` ### 3. 缓存总记录数 ```vb ' ? 推荐：缓存总记录数，避免频繁查询 Private m_lCachedTotal As Long Private m_dtCacheTime As Date Function GetTotalRecords() As Long ' 缓存 5 分钟 If DateDiff("s", m_dtCacheTime, Now) > 300 Or m_lCachedTotal = 0 Then m_lCachedTotal = db.Count("users") m_dtCacheTime = Now End If GetTotalRecords = m_lCachedTotal End Function ``` *** **最后更新**: 2026-01-21 --- --- url: /zh/packages/vbccr/bars/pager.md description: 分页控件（Pager） - VBCCR 开发手册，基于源码的完整 API 参考 --- # 分页控件（Pager） 封装 SysPager 系统分页控件，用于创建可滚动的控件区域，通过左右或上下按钮滚动关联的伙伴控件。 ## 枚举 ### PgrOrientationConstants | 常量 | 值 | 说明 | |------|-----|------| | PgrOrientationHorizontal | 0 | 水平方向 | | PgrOrientationVertical | 1 | 垂直方向 | ### PgrDirectionConstants | 常量 | 值 | 说明 | |------|-----|------| | PgrDirectionLeft | 0 | 向左滚动 | | PgrDirectionRight | 1 | 向右滚动 | | PgrDirectionUp | 2 | 向上滚动 | | PgrDirectionDown | 3 | 向下滚动 | ### PgrButtonConstants | 常量 | 值 | 说明 | |------|-----|------| | PgrButtonLeftTop | 0 | 左端/上端按钮 | | PgrButtonRightBottom | 1 | 右端/下端按钮 | ### PgrButtonStateConstants | 常量 | 值 | 说明 | |------|-----|------| | PgrButtonStateNormal | 0 | 正常 | | PgrButtonStateInvisible | 1 | 隐藏 | | PgrButtonStateGrayed | 2 | 灰色（禁用） | | PgrButtonStateInactive | 4 | 非活动 | | PgrButtonStateHot | 8 | 热态 | ### CCMousePointerConstants 参见通用枚举。 ## 属性 ### BuddyControl ```vb Property Get BuddyControl() As Variant Property Let BuddyControl(ByVal Value As Variant) ``` 关联的伙伴控件。可传递控件对象、控件名称或 hWnd。 ### Orientation ```vb Property Get Orientation() As PgrOrientationConstants Property Let Orientation(ByVal Value As PgrOrientationConstants) ``` 分页控件方向。 ### BorderWidth ```vb Property Get BorderWidth() As Long Property Let BorderWidth(ByVal Value As Long) ``` 边框宽度（像素）。 ### AutoScroll ```vb Property Get AutoScroll() As Boolean Property Let AutoScroll(ByVal Value As Boolean) ``` 是否自动滚动。 ### ButtonSize ```vb Property Get ButtonSize() As Long Property Let ButtonSize(ByVal Value As Long) ``` 按钮大小（像素）。 ### OLEDragDropScroll ```vb Property Get OLEDragDropScroll() As Boolean Property Let OLEDragDropScroll(ByVal Value As Boolean) ``` OLE 拖放时是否自动滚动。 ### Value ```vb Property Get Value() As Single Property Let Value(ByVal Value As Single) ``` 当前滚动位置。 ### VisualStyles ```vb Property Get VisualStyles() As Boolean Property Let VisualStyles(ByVal Value As Boolean) ``` 是否启用视觉样式。 ### hWnd ```vb Property Get hWnd() As LongPtr ``` 分页控件的窗口句柄。 ### hWndUserControl ```vb Property Get hWndUserControl() As LongPtr ``` 用户控件的窗口句柄。 ### Font ```vb Property Get Font() As StdFont Property Let Font(ByVal NewFont As StdFont) Property Set Font(ByVal NewFont As StdFont) ``` 字体。 ### Enabled ```vb Property Get Enabled() As Boolean Property Let Enabled(ByVal Value As Boolean) ``` 是否可用。 ### MousePointer ```vb Property Get MousePointer() As CCMousePointerConstants Property Let MousePointer(ByVal Value As CCMousePointerConstants) ``` 鼠标指针样式。参见通用枚举。 ### MouseIcon ```vb Property Get MouseIcon() As IPictureDisp Property Let MouseIcon(ByVal Value As IPictureDisp) Property Set MouseIcon(ByVal Value As IPictureDisp) ``` 自定义鼠标图标。 ### MouseTrack ```vb Property Get MouseTrack() As Boolean Property Let MouseTrack(ByVal Value As Boolean) ``` 是否启用鼠标进入/离开跟踪。 ### RightToLeft ```vb Property Get RightToLeft() As Boolean Property Let RightToLeft(ByVal Value As Boolean) ``` 从右到左显示方向。 ### RightToLeftMode ```vb Property Get RightToLeftMode() As CCRightToLeftModeConstants Property Let RightToLeftMode(ByVal Value As CCRightToLeftModeConstants) ``` 从右到左模式。参见通用枚举。 ### Name ```vb Property Get Name() As String ``` 控件名称。只读。 ### Tag ```vb Property Get Tag() As String Property Let Tag(ByVal Value As String) ``` 自定义数据。 ### Parent ```vb Property Get Parent() As Object ``` 父对象。只读。 ### Container ```vb Property Get Container() As Object Property Set Container(ByVal Value As Object) ``` 容器对象。 ### Left ```vb Property Get Left() As Single Property Let Left(ByVal Value As Single) ``` 左边距。 ### Top ```vb Property Get Top() As Single Property Let Top(ByVal Value As Single) ``` 顶边距。 ### Width ```vb Property Get Width() As Single Property Let Width(ByVal Value As Single) ``` 宽度。 ### Height ```vb Property Get Height() As Single Property Let Height(ByVal Value As Single) ``` 高度。 ### Visible ```vb Property Get Visible() As Boolean Property Let Visible(ByVal Value As Boolean) ``` 是否可见。 ### ToolTipText ```vb Property Get ToolTipText() As String Property Let ToolTipText(ByVal Value As String) ``` 工具提示文本。 ### HelpContextID ```vb Property Get HelpContextID() As Long Property Let HelpContextID(ByVal Value As Long) ``` 帮助上下文 ID。 ### WhatsThisHelpID ```vb Property Get WhatsThisHelpID() As Long Property Let WhatsThisHelpID(ByVal Value As Long) ``` "这是什么"帮助 ID。 ### DragIcon ```vb Property Get DragIcon() As IPictureDisp Property Let DragIcon(ByVal Value As IPictureDisp) Property Set DragIcon(ByVal Value As IPictureDisp) ``` 拖拽图标。 ### DragMode ```vb Property Get DragMode() As Integer Property Let DragMode(ByVal Value As Integer) ``` 拖拽模式。 ## 方法 ### ReCalcSize ```vb Public Sub ReCalcSize() ``` 重新计算分页控件和伙伴控件的大小。 ### GetButtonState ```vb Public Function GetButtonState(ByVal Button As PgrButtonConstants) As PgrButtonStateConstants ``` 获取指定按钮的状态。 ### Drag ```vb Public Sub Drag([ByRef Action As Variant]) ``` 开始、结束或取消拖放操作。 ### SetFocus ```vb Public Sub SetFocus() ``` 将焦点移至控件。 ### ZOrder ```vb Public Sub ZOrder([ByRef Position As Variant]) ``` 设置控件的 Z 顺序。 ### OLEDrag ```vb Public Sub OLEDrag() ``` 启动 OLE 拖放操作。 ### Refresh ```vb Public Sub Refresh() ``` 强制重绘控件。 ## 事件 ### Scroll ```vb Public Event Scroll() ``` 滚动位置发生改变时触发。 ### CalcSize ```vb Public Event CalcSize() ``` 需要重新计算伙伴控件大小前触发。 ### HotChanged ```vb Public Event HotChanged() ``` 按钮热态改变时触发。 ### Click ```vb Public Event Click() ``` 单击控件时触发。 ### DblClick ```vb Public Event DblClick() ``` 双击控件时触发。 ### MouseDown ```vb Public Event MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` 按下鼠标按钮时触发。 ### MouseUp ```vb Public Event MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` 释放鼠标按钮时触发。 ### MouseMove ```vb Public Event MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` 移动鼠标时触发。 ### MouseEnter ```vb Public Event MouseEnter() ``` 鼠标进入控件时触发。 ### MouseLeave ```vb Public Event MouseLeave() ``` 鼠标离开控件时触发。 ### OLEDragDrop ```vb Public Event OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single) ``` OLE 拖放完成时触发。 ### OLEDragOver ```vb Public Event OLEDragOver(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single, State As Integer) ``` OLE 拖放经过控件时触发。 ### OLEGiveFeedback ```vb Public Event OLEGiveFeedback(Effect As Long, DefaultCursors As Boolean) ``` OLE 拖放需要更改光标时触发。 ### OLEStartDrag ```vb Public Event OLEStartDrag(Data As DataObject, AllowedEffects As Long) ``` OLE 拖放开始时触发。 ### OLECompleteDrag ```vb Public Event OLECompleteDrag(Effect As Long) ``` OLE 拖放完成时触发。 ### OLESetData ```vb Public Event OLESetData(Data As DataObject, DataFormat As Integer) ``` OLE 放置目标请求数据时触发。 ## 代码示例 ```vb ' 设置水平分页控件与图片框关联 Pager1.Orientation = PgrOrientationHorizontal Set Pager1.BuddyControl = Picture1 Pager1.ButtonSize = 16 Call Pager1.ReCalcSize ``` --- --- url: /zh/emoji/2460-24FF.md --- # 封闭式字母数字 (U+2460 - U+24FF) 本节包含带圈或括号的数字和字母，通常用于列表标记或特殊标识。 | 字符 | Unicode | VB函数值 | 名称 | |:---:|:---:|:---:|:---| | ① | U+2460 | ChrW(\&H2460) | 带圈数字1 | | ② | U+2461 | ChrW(\&H2461) | 带圈数字2 | | ③ | U+2462 | ChrW(\&H2462) | 带圈数字3 | | ④ | U+2463 | ChrW(\&H2463) | 带圈数字4 | | ⑤ | U+2464 | ChrW(\&H2464) | 带圈数字5 | | ⑥ | U+2465 | ChrW(\&H2465) | 带圈数字6 | | ⑦ | U+2466 | ChrW(\&H2466) | 带圈数字7 | | ⑧ | U+2467 | ChrW(\&H2467) | 带圈数字8 | | ⑨ | U+2468 | ChrW(\&H2468) | 带圈数字9 | | ⑩ | U+2469 | ChrW(\&H2469) | 带圈数字10 | | ⑪ | U+246A | ChrW(\&H246A) | 带圈数字11 | | ⑫ | U+246B | ChrW(\&H246B) | 带圈数字12 | | ⑬ | U+246C | ChrW(\&H246C) | 带圈数字13 | | ⑭ | U+246D | ChrW(\&H246D) | 带圈数字14 | | ⑮ | U+246E | ChrW(\&H246E) | 带圈数字15 | | ⑯ | U+246F | ChrW(\&H246F) | 带圈数字16 | | ⑰ | U+2470 | ChrW(\&H2470) | 带圈数字17 | | ⑱ | U+2471 | ChrW(\&H2471) | 带圈数字18 | | ⑲ | U+2472 | ChrW(\&H2472) | 带圈数字19 | | ⑳ | U+2473 | ChrW(\&H2473) | 带圈数字20 | | ⑴ | U+2474 | ChrW(\&H2474) | 带括号数字1 | | ⑵ | U+2475 | ChrW(\&H2475) | 带括号数字2 | | ⑶ | U+2476 | ChrW(\&H2476) | 带括号数字3 | | ⑷ | U+2477 | ChrW(\&H2477) | 带括号数字4 | | ⑸ | U+2478 | ChrW(\&H2478) | 带括号数字5 | | ⑹ | U+2479 | ChrW(\&H2479) | 带括号数字6 | | ⑺ | U+247A | ChrW(\&H247A) | 带括号数字7 | | ⑻ | U+247B | ChrW(\&H247B) | 带括号数字8 | | ⑼ | U+247C | ChrW(\&H247C) | 带括号数字9 | | ⑽ | U+247D | ChrW(\&H247D) | 带括号数字10 | | ⑾ | U+247E | ChrW(\&H247E) | 带括号数字11 | | ⑿ | U+247F | ChrW(\&H247F) | 带括号数字12 | | ⒀ | U+2480 | ChrW(\&H2480) | 带括号数字13 | | ⒁ | U+2481 | ChrW(\&H2481) | 带括号数字14 | | ⒂ | U+2482 | ChrW(\&H2482) | 带括号数字15 | | ⒃ | U+2483 | ChrW(\&H2483) | 带括号数字16 | | ⒄ | U+2484 | ChrW(\&H2484) | 带括号数字17 | | ⒅ | U+2485 | ChrW(\&H2485) | 带括号数字18 | | ⒆ | U+2486 | ChrW(\&H2486) | 带括号数字19 | | ⒇ | U+2487 | ChrW(\&H2487) | 带括号数字20 | --- --- url: /zh/biz/cs-auther/server.md --- # 服务端模块详解 ## 工程概览 * **工程文件**: `src-server/Server.vbp` * **启动对象**: `Form1` * **输出文件**: `dist/服务端/Server.exe` * **数据库文件**: `data.mdb` (Access) *** ## 全局模块 ### Insts.bas — 全局实例与系统日志 定义服务端全局共享的实例： ```vb Public TcpServer As cWinsock ' TCP 监听对象 Public Db As cDataBase ' 数据库连接对象 Public FileServer As cFileServer ' 文件服务器对象 ``` **全局日志函数**: ```vb Public Sub AddLog(ByVal Msg As String, Optional Level As EnumLogLevel = LvInfo, Optional Title As String) ``` | 参数 | 类型 | 说明 | |------|------|------| | `Msg` | String | 日志内容 | | `Level` | EnumLogLevel | 日志级别：`LvInfo`, `LvWarning`, `LvDanger` | | `Title` | String | 日志标题/分类 | **功能特点**: * 日志同时输出到文件（通过 `VBMAN.Logs`）和主窗体 `List2` 列表 * 列表最多保留 1000 条记录，超出自动移除最早记录 * 日志文件按日期自动分目录存储 *** ## 窗体模块 ### Form1.frm — 服务端主窗体 **界面布局**: * `List1` — 左侧用户列表（显示昵称，在线用户前缀 `[ 在线 ]` 并置顶） * `List2` — 右侧操作日志/信息列表 * `Label1` — 右上角在线客户端数量 **菜单**: * `文件 → 开机启动` — 切换 Windows 开机启动状态 * `刷新用户` — 重新从数据库加载用户列表 * `推送公告` — 打开 `fNotify` 编辑并推送公告 **核心逻辑**: 1. **Form\_Load**: * 创建 `cWinsock` 实例，监听 **TCP 800 端口** * 连接 `data.mdb` Access 数据库 * 首次加载用户列表 `LoadUsersFromDB True` * 注册路由和中间件 `RegRouter` * 设置 `Common.IsServer = True` 2. **RegRouter** — 注册中间件与路由: ```vb ' 中间件 Common.MiddleWares.Add New mAuth, "Auth" ' 白名单（无需验证 Token） Common.MiddleWaresWhiteList.Add 1, "User/Login" ' 业务路由 Common.Router.Add New bUser, "User" Common.Router.Add New cMessage, "Message" Common.Router.Add New bNotify, "Notify" Common.Router.Add New bCalc, "Calc" ``` 3. **LoadUsersFromDB** — 加载用户列表: * 参数 `Force=True` 时重新执行 SQL 查询 * 使用静态变量 `Users` 缓存查询结果，避免频繁查库 * 遍历用户，通过 `mTcp.ExistsUser(x("UserName"))` 判断在线状态 * 在线用户添加 `[ 在线 ]` 前缀并插入到列表顶部（`AddItem ..., 0`） 4. **Tcp 事件**: * `ConnectionRequest` — 新客户端接入（可用于 IP 白名单控制） * `ClientCountChange` — 客户端数量变化时更新状态栏和在线列表 * `DataArrival` — 调用 `Common.HandleReciver` 分发请求 * `CloseEvent` — 客户端断开 *** ### fNotify.frm — 公告编辑器 **界面元素**: * `Text1` — 公告标题 * `Text2` — 公告内容（多行文本） * `Command1` — 立即推送按钮 * `Command2` — 清空按钮 * `Label3` — 显示上次推送时间 **核心逻辑**: 1. **Form\_Load**: * 从 `config.ini` 读取已保存的公告内容并填充 2. **Command1\_Click (推送)**: ```vb VBMAN.Ini.Section("Notify")("Time") = Format(Now, "yyyy年MM月dd日 hh:mm:ss") VBMAN.Ini.Section("Notify")("Title") = Text1.Text VBMAN.Ini.MultiLineText("Notify", "Content") = Text2.Text VBMAN.Ini.SaveTo Common.SendToAll Insts.TcpServer, "Notify/Show", VBMAN.Ini("Notify") ``` 公告保存到 INI 文件后，向所有在线客户端广播。 3. **Command2\_Click (清空)**: * 删除 INI 中的公告节点 * 发送空公告到所有客户端，实现"撤回"效果 *** ## 日志系统 服务端采用多级日志设计，分为**全局系统日志**和**业务专用日志**两类： * **全局系统日志**: `Insts.AddLog` — 记录系统启动、客户端连接/断开、登录认证等事件 * **业务专用日志**: 各模块独立的 `cLogs` 实例 — 记录业务数据（如文件传输、计算参数、公告推送等） 详细说明请参考 [日志系统详解](logging.md)。 *** ## 业务类 ### bUser.cls — 用户登录验证 | 方法 | 说明 | |------|------| | `Login(Inst, Data)` | 处理客户端登录请求，验证账号密码，生成 Token，绑定用户 | | `ChangePassword(Inst, Data)` | 处理客户端修改密码请求，验证旧密码并更新数据库 | **登录验证流程**: 1. 从 `Data` 中提取 `username` 和 `password` 2. 查询数据库: `select * from users where username='xxx'` 3. 验证用户名是否存在、密码是否设置、密码是否匹配 4. 如果该账号已在线 → 向旧客户端发送"账号在另外一个地方登录"，并强制断开 (`CloseUser`) 5. 生成 GUID 作为 Token 6. 绑定用户到连接: `TcpServer.BindUser UserName, Inst, Token, UserData` 7. 刷新服务端用户列表 `Form1.LoadUsersFromDB` 8. 返回用户信息给客户端: `SendTo Inst, "User/Info", .Row` **修改密码流程 (ChangePassword)**: 1. 从 `Data` 中提取 `oldPassword` 和 `newPassword` 2. 获取当前连接绑定的用户名 `Inst.CurrentUser` 和客户端 IP 3. **参数验证**: * 旧密码或新密码为空 → 拒绝，记录日志 4. **数据库验证**: * 查询用户信息，用户不存在 → 拒绝，记录详细日志（包含提交的账号、密码、IP） * 验证旧密码，不匹配 → 拒绝，记录日志（包含提交的密码、IP） 5. **更新密码**: * 执行 SQL: `update users set password='xxx' where ID=xxx` * 发送 Toast 通知客户端"密码修改成功" * 记录成功日志（包含用户名、IP） * 返回更新后的用户信息 **安全日志记录**: | 场景 | 日志级别 | 记录内容 | |------|---------|---------| | 参数为空 | Warn | 用户名、IP | | 用户不存在 | Danger | 提交的账号、旧密码、新密码、IP | | 旧密码错误 | Warn | 用户名、提交的旧密码、IP | | 修改成功 | Info | 用户名、IP | **数据库表结构 (users)**: | 字段 | 类型 | 说明 | |------|------|------| | `ID` | AutoNumber | 主键 | | `UserName` | Text | 登录账号 | | `NickName` | Text | 显示昵称 | | `Password` | Text | 哈希后的密码 | *** ### bNotify.cls — 公告查询 | 方法 | 说明 | |------|------| | `CheckNew(Inst, Data)` | 客户端启动后调用，查询是否有离线期间的公告 | **逻辑**: * 如果 INI 中存在公告 → 将公告内容发送给请求客户端 * 如果没有公告 → 发送空对象，客户端显示"暂无公告..." *** ### bCalc.cls — 参数计算处理 | 方法 | 说明 | |------|------| | `Submit(Inst, Data)` | 接收客户端发送的 50 个参数，模拟修改后回传 | **模拟修改示例**: ```vb Data("id") = 1000 Data("memo") = Data("memo") & vbCrLf & "这是服务端追加的备注内容" Data("remark") = "你可以修改更多的字段" Common.SendTo Inst, "Calc/Show", Data.Root ``` > 实际业务中可以在此进行真实的计算、数据校验、持久化等操作。 *** ## 中间件 ### mAuth.cls — 授权验证中间件 **设计理念**: 中间件是前置拦截器，所有请求（除白名单外）在进入业务逻辑前都必须通过中间件校验。 **接口定义**: ```vb Public Function Entry(Inst As cWinsock, Req As cJson, Optional LastError As String) As Boolean ``` | 参数 | 说明 | |------|------| | `Inst` | 当前客户端连接实例 | | `Req` | 客户端发来的完整 JSON 请求对象 | | `LastError` | 若返回 `False`，此参数携带错误信息回传给客户端 | **校验规则**: 1. `Req("token") = ""` → 错误: "凭证为空" 2. `Inst.CurrentUserToken = ""` → 错误: "当前客户端未绑定用户" 3. `Inst.CurrentUserToken <> Req("token")` → 错误: "凭证验证失败" 4. 全部通过 → 返回 `True` **扩展中间件**: 可按相同模式新增中间件类，在 `Form1.RegRouter` 中添加到 `MiddleWares` 集合即可实现链式调用。 *** ## 数据库操作 服务端使用 VBMAN 的 `cDataBase` 对象操作 Access 数据库： ```vb Dim mDB As New cDataBase mDB.Connect Access, App.Path & "\data.mdb" ' 查询单条记录 mDB.Sql("select * from users where username='wangli'").Fetch If mDB.Row.Count > 0 Then Debug.Print mDB.Row("NickName") End If ' 查询多条记录 mDB.Sql("select * from users").Query Dim Users As New cJson Users.Decode mDB.Rs ``` **常用方法**: | 方法 | 说明 | |------|------| | `.Connect Access, 路径` | 连接 Access 数据库 | | `.Sql("...")` | 设置 SQL 语句 | | `.Fetch` | 执行并获取单条记录到 `.Row` | | `.Query` | 执行并获取记录集到 `.Rs` | | `.Row.Count` | 返回记录数（0 表示无记录） | --- --- url: /zh/packages/vbccr/buttons/checkboxw.md description: 复选框控件（CheckBoxW） - VBCCR 开发手册，基于源码的完整 API 参考 --- # 复选框控件（CheckBoxW） 增强型复选框控件，支持视觉样式、自绘、ImageList 图标和 PushLike 模式。 ## 枚举 ### ChkImageListAlignmentConstants | 常量 | 值 | 说明 | |------|-----|------| | ChkImageListAlignmentLeft | 0 | 左对齐 | | ChkImageListAlignmentRight | 1 | 右对齐 | | ChkImageListAlignmentTop | 2 | 顶部对齐 | | ChkImageListAlignmentBottom | 3 | 底部对齐 | | ChkImageListAlignmentCenter | 4 | 居中对齐 | ### ChkDrawModeConstants | 常量 | 值 | 说明 | |------|-----|------| | ChkDrawModeNormal | 0 | 正常模式，由系统绘制 | | ChkDrawModeOwnerDraw | 1 | 自绘模式，由代码绘制 | ## 属性 ### VisualStyles ```vb Property Get VisualStyles() As Boolean Property Let VisualStyles(ByVal Value As Boolean) ``` 是否启用视觉样式。 ### Appearance ```vb Property Get Appearance() As CCAppearanceConstants Property Let Appearance(ByVal Value As CCAppearanceConstants) ``` 外观样式。参见通用枚举。 ### BackColor ```vb Property Get BackColor() As OLE_COLOR Property Let BackColor(ByVal Value As OLE_COLOR) ``` 背景色。 ### ForeColor ```vb Property Get ForeColor() As OLE_COLOR Property Let ForeColor(ByVal Value As OLE_COLOR) ``` 前景色。 ### ImageList ```vb Property Get ImageList() As Variant Property Let ImageList(ByVal Value As Variant) Property Set ImageList(ByVal Value As Variant) ``` 关联的 ImageList 控件。 ### ImageListAlignment ```vb Property Get ImageListAlignment() As ChkImageListAlignmentConstants Property Let ImageListAlignment(ByVal Value As ChkImageListAlignmentConstants) ``` ImageList 图标对齐方式。 ### ImageListMargin ```vb Property Get ImageListMargin() As Single Property Let ImageListMargin(ByVal Value As Single) ``` ImageList 图标边距。 ### Value ```vb Property Get Value() As Integer Property Let Value(ByVal Value As Integer) ``` 复选框状态（0-未选中，1-选中，2-灰显）。 ### Caption ```vb Property Get Caption() As String Property Let Caption(ByVal Value As String) ``` 标题文本。 ### Alignment ```vb Property Get Alignment() As CCLeftRightAlignmentConstants Property Let Alignment(ByVal Value As CCLeftRightAlignmentConstants) ``` 复选框的对齐方式。参见通用枚举。 ### TextAlignment ```vb Property Get TextAlignment() As VBRUN.AlignmentConstants Property Let TextAlignment(ByVal Value As VBRUN.AlignmentConstants) ``` 文本对齐方式。 ### PushLike ```vb Property Get PushLike() As Boolean Property Let PushLike(ByVal Value As Boolean) ``` 是否以按钮样式显示。 ### Picture ```vb Property Get Picture() As IPictureDisp Property Let Picture(ByVal Value As IPictureDisp) Property Set Picture(ByVal Value As IPictureDisp) ``` 图片。 ### WordWrap ```vb Property Get WordWrap() As Boolean Property Let WordWrap(ByVal Value As Boolean) ``` 是否自动换行。 ### Transparent ```vb Property Get Transparent() As Boolean Property Let Transparent(ByVal Value As Boolean) ``` 是否透明背景（运行时有效）。 ### VerticalAlignment ```vb Property Get VerticalAlignment() As CCVerticalAlignmentConstants Property Let VerticalAlignment(ByVal Value As CCVerticalAlignmentConstants) ``` 垂直对齐。参见通用枚举。 ### Style ```vb Property Get Style() As VBRUN.ButtonConstants Property Let Style(ByVal Value As VBRUN.ButtonConstants) ``` 外观样式（标准或图形）。 ### DisabledPicture ```vb Property Get DisabledPicture() As IPictureDisp Property Let DisabledPicture(ByVal Value As IPictureDisp) Property Set DisabledPicture(ByVal Value As IPictureDisp) ``` 禁用状态图片。Style 为图形时有效。 ### DownPicture ```vb Property Get DownPicture() As IPictureDisp Property Let DownPicture(ByVal Value As IPictureDisp) Property Set DownPicture(ByVal Value As IPictureDisp) ``` 按下状态图片。Style 为图形时有效。 ### UseMaskColor ```vb Property Get UseMaskColor() As Boolean Property Let UseMaskColor(ByVal Value As Boolean) ``` 是否使用遮罩色。Style 为图形时有效。 ### MaskColor ```vb Property Get MaskColor() As OLE_COLOR Property Let MaskColor(ByVal Value As OLE_COLOR) ``` 遮罩色。Style 为图形时有效。 ### DrawMode ```vb Property Get DrawMode() As ChkDrawModeConstants Property Let DrawMode(ByVal Value As ChkDrawModeConstants) ``` 绘制模式。 ### Pushed ```vb Property Get Pushed() As Boolean ``` 是否处于按下状态。只读。 ### Hot ```vb Property Get Hot() As Boolean ``` 是否处于热状态（鼠标悬停）。只读。 ### hWnd ```vb Property Get hWnd() As LongPtr ``` 窗口句柄。 ### hWndUserControl ```vb Property Get hWndUserControl() As LongPtr ``` 用户控件窗口句柄。 ### Font ```vb Property Get Font() As StdFont Property Let Font(ByVal NewFont As StdFont) Property Set Font(ByVal NewFont As StdFont) ``` 字体。 ### Enabled ```vb Property Get Enabled() As Boolean Property Let Enabled(ByVal Value As Boolean) ``` 是否可用。 ### OLEDropMode ```vb Property Get OLEDropMode() As OLEDropModeConstants Property Let OLEDropMode(ByVal Value As OLEDropModeConstants) ``` OLE 拖放模式。参见通用枚举。 ### MousePointer ```vb Property Get MousePointer() As CCMousePointerConstants Property Let MousePointer(ByVal Value As CCMousePointerConstants) ``` 鼠标指针。参见通用枚举。 ### MouseIcon ```vb Property Get MouseIcon() As IPictureDisp Property Let MouseIcon(ByVal Value As IPictureDisp) Property Set MouseIcon(ByVal Value As IPictureDisp) ``` 自定义鼠标图标。 ### MouseTrack ```vb Property Get MouseTrack() As Boolean Property Let MouseTrack(ByVal Value As Boolean) ``` 鼠标进入/离开跟踪。 ### Name / Tag / Parent / Container / Left / Top / Width / Height / Visible / ToolTipText / HelpContextID / WhatsThisHelpID / DragIcon / DragMode 参见标准扩展器属性。 ## 方法 ### Refresh ```vb Public Sub Refresh() ``` 强制重绘。 ### OLEDrag ```vb Public Sub OLEDrag() ``` 启动 OLE 拖放。 ### Drag / ZOrder / SetFocus / Move 参见标准方法。 ## 事件 ### Click ```vb Public Event Click() ``` 单击。 ### DblClick ```vb Public Event DblClick() ``` 双击。 ### HotChanged ```vb Public Event HotChanged() ``` 热状态改变时触发。 ### OwnerDraw ```vb Public Event OwnerDraw(ByVal ItemAction As Long, ByVal ItemState As Long, ByVal hDC As LongPtr, ByVal Left As Long, ByVal Top As Long, ByVal Right As Long, ByVal Bottom As Long) ``` 自绘事件。DrawMode 为 OwnerDraw 时触发。 ### KeyDown ```vb Public Event KeyDown(KeyCode As Integer, Shift As Integer) ``` ### KeyUp ```vb Public Event KeyUp(KeyCode As Integer, Shift As Integer) ``` ### KeyPress ```vb Public Event KeyPress(KeyAscii As Integer) ``` ### MouseDown ```vb Public Event MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` ### MouseMove ```vb Public Event MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` ### MouseUp ```vb Public Event MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` ### MouseEnter ```vb Public Event MouseEnter() ``` ### MouseLeave ```vb Public Event MouseLeave() ``` ### OLECompleteDrag / OLEDragDrop / OLEDragOver / OLEGiveFeedback / OLESetData / OLEStartDrag 参见 OLE 拖放事件。 ## 代码示例 ### 基本用法 ```vb ' 设置三态复选框 CheckBoxW1.Value = vbChecked ' 选中 CheckBoxW2.Value = vbUnchecked ' 未选中 CheckBoxW3.Value = vbGrayed ' 灰显 ' PushLike 按钮样式 CheckBoxW1.PushLike = True ' 关联 ImageList Set CheckBoxW1.ImageList = ImageList1 CheckBoxW1.ImageListAlignment = ChkImageListAlignmentLeft ``` ### 自绘模式 ```vb Private Sub CheckBoxW1_OwnerDraw(ByVal ItemAction As Long, ByVal ItemState As Long, _ ByVal hDC As LongPtr, ByVal Left As Long, ByVal Top As Long, _ ByVal Right As Long, ByVal Bottom As Long) ' 在此绘制自定义复选框 End Sub ``` --- --- url: /zh/packages/vbccr/text/richtextbox.md description: 富文本框控件（RichTextBox） - VBCCR 开发手册，基于源码的完整 API 参考 --- # 富文本框控件（RichTextBox） 封装 RichEdit 系统富文本编辑控件，提供格式化文本编辑、RTF 文件读写、OLE 对象嵌入、打印、查找替换及自动超链接检测等功能。 ## 枚举 ### RtfLoadSaveFormatConstants | 常量 | 值 | 说明 | |------|-----|------| | RtfLoadSaveFormatRTF | 0 | RTF 格式 | | RtfLoadSaveFormatText | 1 | 纯文本格式 | | RtfLoadSaveFormatUnicodeText | 2 | Unicode 纯文本格式 | ### RtfFindOptionConstants | 常量 | 值 | 说明 | |------|-----|------| | RtfFindOptionWholeWord | \&H2 | 全字匹配 | | RtfFindOptionMatchCase | \&H4 | 区分大小写 | | RtfFindOptionNoHighlight | \&H8 | 不高亮匹配结果 | | RtfFindOptionReverse | \&H10 | 反向搜索 | ### RtfActionTypeConstants | 常量 | 值 | 说明 | |------|-----|------| | RtfActionTypeUnknown | 0 | 未知操作 | | RtfActionTypeTyping | 1 | 键入操作 | | RtfActionTypeDelete | 2 | 删除操作 | | RtfActionTypeDragDrop | 3 | 拖放操作 | | RtfActionTypeCut | 4 | 剪切操作 | | RtfActionTypePaste | 5 | 粘贴操作 | | RtfActionTypeAutoTable | 6 | 自动表格操作 | ### RtfSelAlignmentConstants | 常量 | 值 | 说明 | |------|-----|------| | RtfSelAlignmentLeft | 0 | 左对齐 | | RtfSelAlignmentRight | 1 | 右对齐 | | RtfSelAlignmentCenter | 2 | 居中对齐 | | RtfSelAlignmentJustified | 3 | 两端对齐 | ### RtfSelTypeConstants | 常量 | 值 | 说明 | |------|-----|------| | RtfSelTypeEmpty | 0 | 空选区 | | RtfSelTypeText | 1 | 文本 | | RtfSelTypeObject | 2 | OLE 对象 | | RtfSelTypeMultiChar | 4 | 多字符 | | RtfSelTypeMultiObject | 8 | 多 OLE 对象 | ### RtfTextModeConstants | 常量 | 值 | 说明 | |------|-----|------| | RtfTextModeRichText | 0 | 富文本模式 | | RtfTextModePlainText | 1 | 纯文本模式 | ### CCMousePointerConstants 参见通用枚举。 ### OLEDropModeConstants 参见通用枚举。 ### CCRightToLeftModeConstants 参见通用枚举。 ### CCIMEModeConstants 参见通用枚举。 ## 属性 ### Text ```vb Property Get Text() As String Property Let Text(ByVal Value As String) ``` 控件中包含的纯文本内容。默认属性。 ### TextLength ```vb Property Get TextLength() As Long ``` 文本长度（字符数）。只读。 ### TextRTF ```vb Property Get TextRTF() As String Property Let TextRTF(ByVal Value As String) ``` 包含所有 RTF 代码的 RTF 文本内容。 ### SelText ```vb Property Get SelText() As String Property Let SelText(ByVal Value As String) ``` 当前选区的文本内容。 ### SelRTF ```vb Property Get SelRTF() As String Property Let SelRTF(ByVal Value As String) ``` 当前选区的 RTF 文本（包含所有 RTF 代码）。 ### SelStart ```vb Property Get SelStart() As Long Property Let SelStart(ByVal Value As Long) ``` 选区的起始位置，无选区时为插入点位置。 ### SelLength ```vb Property Get SelLength() As Long Property Let SelLength(ByVal Value As Long) ``` 选区的字符数。 ### SelAlignment ```vb Property Get SelAlignment() As Variant Property Let SelAlignment(ByVal Value As Variant) ``` 段落对齐方式，值为 RtfSelAlignmentConstants 之一。 ### SelBold ```vb Property Get SelBold() As Variant Property Let SelBold(ByVal Value As Variant) ``` 当前选区的粗体格式。 ### SelItalic ```vb Property Get SelItalic() As Variant Property Let SelItalic(ByVal Value As Variant) ``` 当前选区的斜体格式。 ### SelStrikethru ```vb Property Get SelStrikethru() As Variant Property Let SelStrikethru(ByVal Value As Variant) ``` 当前选区的删除线格式。 ### SelUnderline ```vb Property Get SelUnderline() As Variant Property Let SelUnderline(ByVal Value As Variant) ``` 当前选区的下划线格式。 ### SelBullet ```vb Property Get SelBullet() As Variant Property Let SelBullet(ByVal Value As Variant) ``` 当前选区或插入点所在段落是否具有项目符号样式。 ### SelCharOffset ```vb Property Get SelCharOffset() As Variant Property Let SelCharOffset(ByVal Value As Variant) ``` 字符偏移量，确定文本显示在基线上（正常）、基线上方（上标）或基线下方（下标）。 ### SelColor ```vb Property Get SelColor() As Variant Property Let SelColor(ByVal Value As Variant) ``` 当前选区的文本颜色。 ### SelBkColor ```vb Property Get SelBkColor() As Variant Property Let SelBkColor(ByVal Value As Variant) ``` 当前选区的文本背景颜色。 ### SelFontName ```vb Property Get SelFontName() As Variant Property Let SelFontName(ByVal Value As Variant) ``` 当前选区的字体名称。 ### SelFontSize ```vb Property Get SelFontSize() As Variant Property Let SelFontSize(ByVal Value As Variant) ``` 当前选区的字体大小（磅）。 ### SelFontCharset ```vb Property Get SelFontCharset() As Variant Property Let SelFontCharset(ByVal Value As Variant) ``` 当前选区的字体字符集。 ### SelProtected ```vb Property Get SelProtected() As Variant Property Let SelProtected(ByVal Value As Variant) ``` 当前选区文本是否受保护（不可编辑）。 ### SelIndent ```vb Property Get SelIndent() As Variant Property Let SelIndent(ByVal Value As Variant) ``` 左缩进距离。 ### SelRightIndent ```vb Property Get SelRightIndent() As Variant Property Let SelRightIndent(ByVal Value As Variant) ``` 右缩进距离。 ### SelHangingIndent ```vb Property Get SelHangingIndent() As Variant Property Let SelHangingIndent(ByVal Value As Variant) ``` 首行缩进距离（相对于左缩进）。 ### SelVisible ```vb Property Get SelVisible() As Variant Property Let SelVisible(ByVal Value As Variant) ``` 当前选区文本是否可见。 ### SelLink ```vb Property Get SelLink() As Variant Property Let SelLink(ByVal Value As Variant) ``` 当前选区文本是否标记为超链接。 ### SelTabCount ```vb Property Get SelTabCount() As Variant Property Let SelTabCount(ByVal Value As Variant) ``` 当前选区的制表位数量。 ### SelTabs ```vb Property Get SelTabs(ByVal Element As Integer) As Variant Property Let SelTabs(ByVal Element As Integer, ByVal Value As Variant) ``` 当前选区的绝对制表位位置。 ### Modified ```vb Property Get Modified() As Boolean Property Let Modified(ByVal Value As Boolean) ``` 控件内容是否已被修改。设置 Text 属性将重置为 False，任何输入操作将设为 True。 ### UndoType ```vb Property Get UndoType() As RtfActionTypeConstants ``` 下一个撤销操作的类型。只读。 ### RedoType ```vb Property Get RedoType() As RtfActionTypeConstants ``` 下一个重做操作的类型。只读。 ### LeftMargin ```vb Property Get LeftMargin() As Single Property Let LeftMargin(ByVal Value As Single) ``` 左边距宽度。 ### RightMargin ```vb Property Get RightMargin() As Single Property Let RightMargin(ByVal Value As Single) ``` 右边距宽度。 ### ZoomFactor ```vb Property Get ZoomFactor() As Double Property Let ZoomFactor(ByVal Value As Double) ``` 当前缩放比例。 ### VisualStyles ```vb Property Get VisualStyles() As Boolean Property Let VisualStyles(ByVal Value As Boolean) ``` 是否启用视觉样式。需要 comctl32.dll 6.0 或更高版本。 ### Enabled ```vb Property Get Enabled() As Boolean Property Let Enabled(ByVal Value As Boolean) ``` 是否可用。 ### AllowDropFiles ```vb Property Get AllowDropFiles() As Boolean Property Let AllowDropFiles(ByVal Value As Boolean) ``` 是否允许拖放文件。仅当没有 OLE 放置目标时适用。 ### OLEDragDropRTF ```vb Property Get OLEDragDropRTF() As Boolean Property Let OLEDragDropRTF(ByVal Value As Boolean) ``` 富文本框控件是否可作为 OLE 拖放源和放置目标。 ### OLEDragMode ```vb Property Get OLEDragMode() As VBRUN.OLEDragConstants Property Let OLEDragMode(ByVal Value As VBRUN.OLEDragConstants) ``` OLE 拖放模式。当 OLEDragDropRTF 为 True 时必须为 Manual。 ### OLEDragDropScroll ```vb Property Get OLEDragDropScroll() As Boolean Property Let OLEDragDropScroll(ByVal Value As Boolean) ``` OLE 拖放操作期间是否允许滚动。当 OLEDragDropRTF 为 True 时必须为 True。 ### OLEDropMode ```vb Property Get OLEDropMode() As OLEDropModeConstants Property Let OLEDropMode(ByVal Value As OLEDropModeConstants) ``` OLE 放置目标模式。当 OLEDragDropRTF 为 True 时必须为 None。参见通用枚举。 ### MousePointer ```vb Property Get MousePointer() As CCMousePointerConstants Property Let MousePointer(ByVal Value As CCMousePointerConstants) ``` 鼠标指针样式。参见通用枚举。 ### MouseIcon ```vb Property Get MouseIcon() As IPictureDisp Property Let MouseIcon(ByVal Value As IPictureDisp) Property Set MouseIcon(ByVal Value As IPictureDisp) ``` 自定义鼠标图标。 ### MouseTrack ```vb Property Get MouseTrack() As Boolean Property Let MouseTrack(ByVal Value As Boolean) ``` 是否启用鼠标进入/离开跟踪。 ### RightToLeft ```vb Property Get RightToLeft() As Boolean Property Let RightToLeft(ByVal Value As Boolean) ``` 从右到左显示方向。 ### RightToLeftMode ```vb Property Get RightToLeftMode() As CCRightToLeftModeConstants Property Let RightToLeftMode(ByVal Value As CCRightToLeftModeConstants) ``` 从右到左模式。参见通用枚举。 ### BorderStyle ```vb Property Get BorderStyle() As Integer Property Let BorderStyle(ByVal Value As Integer) ``` 边框样式（vbBSNone 或 vbFixedSingle）。 ### BackColor ```vb Property Get BackColor() As OLE_COLOR Property Let BackColor(ByVal Value As OLE_COLOR) ``` 背景颜色。仅当 Enabled 为 True 时适用。 ### Locked ```vb Property Get Locked() As Boolean Property Let Locked(ByVal Value As Boolean) ``` 内容是否锁定为只读。 ### HideSelection ```vb Property Get HideSelection() As Boolean Property Let HideSelection(ByVal Value As Boolean) ``` 控件失去焦点时是否隐藏选区。 ### PasswordChar ```vb Property Get PasswordChar() As String Property Let PasswordChar(ByVal Value As String) ``` 密码字符，用于替代实际字符显示。当 UseSystemPasswordChar 为 True 时此属性无效。 ### UseSystemPasswordChar ```vb Property Get UseSystemPasswordChar() As Boolean Property Let UseSystemPasswordChar(ByVal Value As Boolean) ``` 是否使用默认系统密码字符。此属性优先于 PasswordChar。 ### MultiLine ```vb Property Get MultiLine() As Boolean Property Let MultiLine(ByVal Value As Boolean) ``` 是否允许多行文本。运行时只读。 ### MaxLength ```vb Property Get MaxLength() As Long Property Let MaxLength(ByVal Value As Long) ``` 可输入的最大字符数。 ### ScrollBars ```vb Property Get ScrollBars() As VBRUN.ScrollBarConstants Property Let ScrollBars(ByVal Value As VBRUN.ScrollBarConstants) ``` 滚动条样式。 ### WantReturn ```vb Property Get WantReturn() As Boolean Property Let WantReturn(ByVal Value As Boolean) ``` 按下回车键时是执行默认按钮还是换行。仅适用于多行富文本框且有默认按钮时。 ### DisableNoScroll ```vb Property Get DisableNoScroll() As Boolean Property Let DisableNoScroll(ByVal Value As Boolean) ``` 不需要滚动条时是否禁用而非隐藏。运行时只读。 ### AutoURLDetect ```vb Property Get AutoURLDetect() As Boolean Property Let AutoURLDetect(ByVal Value As Boolean) ``` 是否启用自动超链接检测。 ### BulletIndent ```vb Property Get BulletIndent() As Single Property Let BulletIndent(ByVal Value As Single) ``` 段落使用项目符号时的缩进量。 ### SelectionBar ```vb Property Get SelectionBar() As Boolean Property Let SelectionBar(ByVal Value As Boolean) ``` 是否在左边距添加选择栏，光标变为右上箭头，允许用户选择整行。 ### FileName ```vb Property Get FileName() As String Property Let FileName(ByVal Value As String) ``` 设计时加载到控件中的文件名。 ### TextMode ```vb Property Get TextMode() As RtfTextModeConstants Property Let TextMode(ByVal Value As RtfTextModeConstants) ``` 文本模式（富文本或纯文本）。 ### UndoLimit ```vb Property Get UndoLimit() As Long Property Let UndoLimit(ByVal Value As Long) ``` 撤销队列中可存储的最大操作数。0 表示禁用撤销功能。 ### IMEMode ```vb Property Get IMEMode() As CCIMEModeConstants Property Let IMEMode(ByVal Value As CCIMEModeConstants) ``` 输入法编辑器（IME）模式。参见通用枚举。 ### AllowOverType ```vb Property Get AllowOverType() As Boolean Property Let AllowOverType(ByVal Value As Boolean) ``` 是否允许激活改写模式。 ### OverTypeMode ```vb Property Get OverTypeMode() As Boolean Property Let OverTypeMode(ByVal Value As Boolean) ``` 改写模式是否激活。在改写模式下，输入的字符逐个替换已有字符。 ### UseCrLf ```vb Property Get UseCrLf() As Boolean Property Let UseCrLf(ByVal Value As Boolean) ``` 控件是否将每个 Cr 翻译为 CrLf 用于 Text 属性。 ### AutoVerbMenu ```vb Property Get AutoVerbMenu() As Boolean Property Let AutoVerbMenu(ByVal Value As Boolean) ``` 右键单击选中的 OLE 对象时是否显示其动词弹出菜单。 ### Font ```vb Property Get Font() As StdFont Property Let Font(ByVal NewFont As StdFont) Property Set Font(ByVal NewFont As StdFont) ``` 字体。 ### hWnd ```vb Property Get hWnd() As LongPtr ``` 富文本框控件的窗口句柄。 ### hWndUserControl ```vb Property Get hWndUserControl() As LongPtr ``` 用户控件的窗口句柄。 ### Name ```vb Property Get Name() As String ``` 控件名称。只读。 ### Tag ```vb Property Get Tag() As String Property Let Tag(ByVal Value As String) ``` 自定义数据。 ### Parent ```vb Property Get Parent() As Object ``` 父对象。只读。 ### Container ```vb Property Get Container() As Object Property Set Container(ByVal Value As Object) ``` 容器对象。 ### Left ```vb Property Get Left() As Single Property Let Left(ByVal Value As Single) ``` 左边距。 ### Top ```vb Property Get Top() As Single Property Let Top(ByVal Value As Single) ``` 顶边距。 ### Width ```vb Property Get Width() As Single Property Let Width(ByVal Value As Single) ``` 宽度。 ### Height ```vb Property Get Height() As Single Property Let Height(ByVal Value As Single) ``` 高度。 ### Visible ```vb Property Get Visible() As Boolean Property Let Visible(ByVal Value As Boolean) ``` 是否可见。 ### ToolTipText ```vb Property Get ToolTipText() As String Property Let ToolTipText(ByVal Value As String) ``` 工具提示文本。 ### HelpContextID ```vb Property Get HelpContextID() As Long Property Let HelpContextID(ByVal Value As Long) ``` 帮助上下文 ID。 ### WhatsThisHelpID ```vb Property Get WhatsThisHelpID() As Long Property Let WhatsThisHelpID(ByVal Value As Long) ``` "这是什么"帮助 ID。 ### DragIcon ```vb Property Get DragIcon() As IPictureDisp Property Let DragIcon(ByVal Value As IPictureDisp) Property Set DragIcon(ByVal Value As IPictureDisp) ``` 拖拽图标。 ### DragMode ```vb Property Get DragMode() As Integer Property Let DragMode(ByVal Value As Integer) ``` 拖拽模式。 ## 方法 ### Copy ```vb Public Sub Copy() ``` 将当前选区复制到剪贴板。 ### Cut ```vb Public Sub Cut() ``` 删除当前选区并将文本复制到剪贴板。 ### Paste ```vb Public Sub Paste() ``` 将剪贴板内容粘贴到当前插入点位置。 ### CanPaste ```vb Public Function CanPaste(Optional ByVal wFormat As Long) As Boolean ``` 确定剪贴板上是否有可粘贴的格式。 ### PasteSpecial ```vb Public Sub PasteSpecial(ByVal wFormat As Long) ``` 以指定剪贴板格式粘贴到富文本框。 ### PasteSpecialDlg ```vb Public Sub PasteSpecialDlg() ``` 显示"选择性粘贴"对话框。 ### Clear ```vb Public Sub Clear() ``` 清除当前选区。 ### Undo ```vb Public Sub Undo() ``` 撤销上一次操作（如果有）。 ### CanUndo ```vb Public Function CanUndo() As Boolean ``` 确定撤销队列中是否有可撤销的操作。 ### StopUndoAction ```vb Public Sub StopUndoAction() ``` 停止控件将后续键入操作收集到当前撤销操作中。 ### ResetUndoQueue ```vb Public Sub ResetUndoQueue() ``` 重置撤销队列。 ### Redo ```vb Public Sub Redo() ``` 重做下一个操作（如果有）。 ### CanRedo ```vb Public Function CanRedo() As Boolean ``` 确定重做队列中是否有可重做的操作。 ### GetTextRange ```vb Public Function GetTextRange(ByVal Min As Long, ByVal Max As Long) As String ``` 获取指定范围内的文本。 ### Find ```vb Public Function Find(ByVal Text As String, Optional ByVal Min As Long, Optional ByVal Max As Long = -1, Optional ByVal Options As RtfFindOptionConstants) As Long ``` 在富文本框中查找文本，返回找到的字符位置，未找到返回 -1。 ### Span ```vb Public Sub Span(ByVal CharacterSet As String, Optional ByVal Forward As Boolean, Optional ByVal Negate As Boolean) ``` 基于指定字符集选中文本。 ### UpTo ```vb Public Sub UpTo(ByVal CharacterSet As String, Optional ByVal Forward As Boolean, Optional ByVal Negate As Boolean) ``` 将插入点移动到但不包含指定字符集中的第一个字符。 ### SaveFile ```vb Public Sub SaveFile(ByVal FileName As String, Optional ByVal Format As RtfLoadSaveFormatConstants = RtfLoadSaveFormatRTF, Optional ByVal SelectionOnly As Boolean) ``` 将控件内容保存到文件。 ### LoadFile ```vb Public Sub LoadFile(ByVal FileName As String, Optional ByVal Format As RtfLoadSaveFormatConstants = RtfLoadSaveFormatRTF, Optional ByVal SelectionOnly As Boolean) ``` 加载 RTF 或文本文件到控件。 ### GetLine ```vb Public Function GetLine(ByVal LineNumber As Long) As String ``` 获取指定行的文本。0 表示当前行（包含插入点的行）。 ### GetLineCount ```vb Public Function GetLineCount() As Long ``` 获取行数。 ### ScrollToLine ```vb Public Sub ScrollToLine(ByVal LineNumber As Long) ``` 滚动以确保指定行可见。 ### ScrollToCaret ```vb Public Sub ScrollToCaret() ``` 将插入点滚动到可见区域。 ### CharFromPos ```vb Public Function CharFromPos(ByVal X As Single, ByVal Y As Single) As Long ``` 返回距离指定点最近的字符索引。 ### GetLineFromChar ```vb Public Function GetLineFromChar(ByVal CharIndex As Long) As Long ``` 获取包含指定字符索引的行号。字符索引 -1 返回当前行。 ### GetSelType ```vb Public Function GetSelType() As Integer ``` 确定当前选区类型，返回 RtfSelTypeConstants 标志组合。 ### SelPrint ```vb Public Sub SelPrint(ByVal hDC As LongPtr, Optional ByVal CallStartEndDoc As Boolean = True, Optional ByVal DocName As String = "RICHTEXT", Optional ByVal LeftMargin As Long, Optional ByVal TopMargin As Long, Optional ByVal RightMargin As Long, Optional ByVal BottomMargin As Long) ``` 将富文本框中的格式化文本发送到设备进行打印。若无选区则打印全部内容。 ### PrintDoc ```vb Public Sub PrintDoc(ByVal hDC As LongPtr, Optional ByVal CallStartEndDoc As Boolean = True, Optional ByVal DocName As String = "RICHTEXT", Optional ByVal LeftMargin As Long, Optional ByVal TopMargin As Long, Optional ByVal RightMargin As Long, Optional ByVal BottomMargin As Long) ``` 将富文本框中的全部格式化文本发送到设备进行打印。 ### GetOLEInterface ```vb Public Function GetOLEInterface() As IUnknown ``` 检索 IRichEditOle 对象，用于访问 COM 功能。 ### OLEObjectsAdd ```vb Public Sub OLEObjectsAdd(ByVal LpOleObject As LongPtr) ``` 插入一个 OLE 对象到富文本框。 ### OLEObjectsAddFromFile ```vb Public Sub OLEObjectsAddFromFile(ByVal FileName As String, Optional ByVal LinkToFile As Boolean) ``` 从文件插入一个 OLE 对象到富文本框。 ### OLEObjectsAddFromPicture ```vb Public Sub OLEObjectsAddFromPicture(ByVal Picture As IPictureDisp, Optional ByVal ClipFormat As Variant) ``` 从图片对象插入一个 OLE 对象到富文本框。 ### OLEObjectsGet ```vb Public Function OLEObjectsGet(ByVal IndexObj As Long, Optional ByVal CharPos As Long) As LongPtr ``` 检索富文本框中的 OLE 对象。 ### OLEObjectsCount ```vb Public Function OLEObjectsCount() As Long ``` 返回当前富文本框中包含的 OLE 对象数量。 ### Drag ```vb Public Sub Drag([ByRef Action As Variant]) ``` 开始、结束或取消拖放操作。 ### SetFocus ```vb Public Sub SetFocus() ``` 将焦点移至控件。 ### ZOrder ```vb Public Sub ZOrder([ByRef Position As Variant]) ``` 设置控件的 Z 顺序。 ### OLEDrag ```vb Public Sub OLEDrag() ``` 启动 OLE 拖放操作。 ### Refresh ```vb Public Sub Refresh() ``` 强制重绘控件。 ## 事件 ### Change ```vb Public Event Change() ``` 控件内容发生变化时触发。 ### MaxText ```vb Public Event MaxText() ``` 当前文本插入超出最大字符数时触发。 ### SelChange ```vb Public Event SelChange(ByVal SelType As Integer, ByVal SelStart As Long, ByVal SelEnd As Long) ``` 当前文本选区发生变化或插入点移动时触发。 ### LinkEvent ```vb Public Event LinkEvent(ByVal wMsg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr, ByVal LinkStart As Long, ByVal LinkEnd As Long) ``` 鼠标点击或悬停在具有超链接格式的文本上时触发。 ### DropFiles ```vb Public Event DropFiles(ByRef FileList As Variant, ByVal X As Single, ByVal Y As Single, ByVal CharPos As Long, ByVal Protected As Boolean, ByRef Cancel As Boolean) ``` 用户将文件拖放到控件上时触发。仅当没有 OLE 放置目标且 AllowDropFiles 为 True 时适用。 ### ModifyProtected ```vb Public Event ModifyProtected(ByRef Allow As Boolean, ByVal SelStart As Long, ByVal SelEnd As Long) ``` 用户尝试编辑受保护文本时触发。 ### Scroll ```vb Public Event Scroll() ``` 重新定位滚动条时触发。 ### ContextMenu ```vb Public Event ContextMenu(ByRef Handled As Boolean, ByVal X As Single, ByVal Y As Single) ``` 用户右键单击或按 Shift+F10 时触发。设置 Handled 为 True 可取消默认菜单。 ### PreviewKeyDown ```vb Public Event PreviewKeyDown(ByVal KeyCode As Integer, ByRef IsInputKey As Boolean) ``` 在 KeyDown 事件之前触发。 ### PreviewKeyUp ```vb Public Event PreviewKeyUp(ByVal KeyCode As Integer, ByRef IsInputKey As Boolean) ``` 在 KeyUp 事件之前触发。 ### MouseEnter ```vb Public Event MouseEnter() ``` 鼠标进入控件时触发。 ### MouseLeave ```vb Public Event MouseLeave() ``` 鼠标离开控件时触发。 ### OLEDragDropDone ```vb Public Event OLEDragDropDone() ``` 富文本框控件完成或取消 OLE 拖放操作后触发。 ### OLEGetDropEffect ```vb Public Event OLEGetDropEffect(ByRef Effect As Long, ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) ``` OLE 拖放操作期间由控件触发，用于指定放置操作的结果效果。 ### OLEGetDragEffect ```vb Public Event OLEGetDragEffect(ByRef AllowedEffects As Long) ``` 控件启动 OLE 拖放操作时触发。 ### OLEGetContextMenu ```vb Public Event OLEGetContextMenu(ByVal SelType As Integer, ByVal LpOleObject As LongPtr, ByVal SelStart As Long, ByVal SelEnd As Long, ByRef hMenu As LongPtr) ``` 请求提供弹出菜单供控件右键单击时使用。控件在完成后销毁此菜单。 ### OLEContextMenuClick ```vb Public Event OLEContextMenuClick(ByVal ID As Long) ``` 用户从 OLEGetContextMenu 事件提供的弹出菜单中选择项时触发。 ### OLEDeleteObject ```vb Public Event OLEDeleteObject(ByVal LpOleObject As LongPtr) ``` OLE 对象即将在控件中被删除时触发。OLE 对象不一定被释放。 ### Click ```vb Public Event Click() ``` 在控件上按下并释放鼠标按钮时触发。 ### DblClick ```vb Public Event DblClick() ``` 在控件上双击鼠标时触发。 ### KeyDown ```vb Public Event KeyDown(KeyCode As Integer, Shift As Integer) ``` 按下按键时触发。 ### KeyUp ```vb Public Event KeyUp(KeyCode As Integer, Shift As Integer) ``` 释放按键时触发。 ### KeyPress ```vb Public Event KeyPress(KeyChar As Integer) ``` 按键字符输入时触发。 ### MouseDown ```vb Public Event MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` 按下鼠标按钮时触发。 ### MouseMove ```vb Public Event MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` 移动鼠标时触发。 ### MouseUp ```vb Public Event MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` 释放鼠标按钮时触发。 ### OLECompleteDrag ```vb Public Event OLECompleteDrag(Effect As Long) ``` OLE 拖放操作完成或取消后触发。 ### OLEDragDrop ```vb Public Event OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single) ``` 数据通过 OLE 拖放操作放到控件上时触发。 ### OLEDragOver ```vb Public Event OLEDragOver(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single, State As Integer) ``` OLE 拖放操作期间鼠标移过控件时触发。 ### OLEGiveFeedback ```vb Public Event OLEGiveFeedback(Effect As Long, DefaultCursors As Boolean) ``` OLE 拖放操作中需要更改鼠标光标时触发。 ### OLESetData ```vb Public Event OLESetData(Data As DataObject, DataFormat As Integer) ``` 放置目标请求 OLEDragStart 期间未提供的数据时触发。 ### OLEStartDrag ```vb Public Event OLEStartDrag(Data As DataObject, AllowedEffects As Long) ``` OLE 拖放操作启动时触发。 ## 代码示例 ```vb ' 加载 RTF 文件 RichTextBox1.LoadFile "C:\doc.rtf", RtfLoadSaveFormatRTF ' 设置选区格式 RichTextBox1.SelStart = 0 RichTextBox1.SelLength = 10 RichTextBox1.SelBold = True RichTextBox1.SelColor = vbRed RichTextBox1.SelFontSize = 14 ' 查找文本 Dim pos As Long pos = RichTextBox1.Find("关键字", 0, -1, RtfFindOptionMatchCase) ' 撤销/重做 If RichTextBox1.CanUndo Then RichTextBox1.Undo If RichTextBox1.CanRedo Then RichTextBox1.Redo ' 打印 RichTextBox1.SelPrint Printer.hDC ' 插入 OLE 对象 RichTextBox1.OLEObjectsAddFromPicture LoadPicture("C:\image.bmp") ' 保存为纯文本 RichTextBox1.SaveFile "C:\output.txt", RtfLoadSaveFormatText ``` --- --- url: /zh/vbman/database/advanced.md --- # 高级功能 本文档介绍 cDataBase 类的高级功能和最佳实践，帮助您更好地使用数据库类库。 *** ## ? 目录 * [异步执行](#异步执行) * [连接池管理](#连接池管理) * [批量操作优化](#批量操作优化) * [性能优化技巧](#性能优化技巧) * [错误处理策略](#错误处理策略) * [设计模式应用](#设计模式应用) * [常见问题解决](#常见问题解决) *** ## 异步执行 ### Async 属性 使用 `Async` 属性可以异步执行 SQL 语句，不阻塞主线程。**注意：异步执行仅对 `Exec` 方法有效**，`Query` 和 `Fetch` 不支持异步。 使用 `Async` 属性可以异步执行 SQL 语句，不阻塞主线程。 #### 语法 ```vb Property Get Async() As cDataBase ``` #### 示例 ```vb ' 异步执行 INSERT db.Sql("INSERT INTO logs (message) VALUES ('test')").Async.Exec ' 监听完成事件 Private Sub db_AsyncExecuteComplete(ByVal RecordsAffected As Long, _ ByVal pError As ADODB.Error, _ adStatus As ADODB.EventStatusEnum, _ ByVal pCommand As ADODB.Command, _ ByVal pRecordset As ADODB.Recordset, _ ByVal pConnection As ADODB.Connection) If pError Is Nothing Then Debug.Print "异步执行成功，影响行数: " & RecordsAffected Else Debug.Print "异步执行失败: " & pError.Description End If End Sub ``` ### 异步执行场景 ```vb ' 场景 1：日志记录（不阻塞主流程） Sub LogMessage(sMessage As String) db.Sql("INSERT INTO logs (message, created_at) VALUES (?, ?)") _ .Param("message", sMessage, adVarWChar) _ .Param("created_at", Now, adDate) _ .Async.ExecParam ' 不等待执行完成，继续执行后续代码 End Sub ' 场景 2：批量数据处理 Sub ProcessLargeDataset() ' 主线程继续处理 ProcessData ' 异步保存结果 db.Sql("INSERT INTO results SELECT * FROM temp_table").Async.Exec End Sub ``` *** ## 连接池管理 ### 多数据库连接 使用连接池管理多个数据库连接。 ```vb Dim db As New VBMAN.cDataBase ' 主数据库 db.Connect VBMAN.enumDbType_MsSql, "127.0.0.1,1433", "sa", "pwd", "maindb" ' 日志数据库 Dim dbLog As VBMAN.cDataBase Set dbLog = db.ConnInst("log", False) dbLog.Connect VBMAN.enumDbType_Mysql, "192.168.1.100:3306", "loguser", "pwd", "logdb" ' 缓存数据库 Dim dbCache As VBMAN.cDataBase Set dbCache = db.ConnInst("cache", False) dbCache.Connect VBMAN.enumDbType_MsSql, "127.0.0.1,1433", "sa", "pwd", "cachedb" ' 使用不同的数据库 db.Sql("SELECT * FROM users").Query dbLog.Sql("INSERT INTO logs (msg) VALUES ('test')").Exec dbCache.Sql("SELECT * FROM cache_data").Query ``` ### 动态连接管理 ```vb ' 根据配置动态创建连接 Function GetDatabase(sConfigName As String) As VBMAN.cDataBase Dim dbInst As VBMAN.cDataBase Set dbInst = db.ConnInst(sConfigName, False) ' 根据配置连接不同的数据库 Select Case sConfigName Case "main" dbInst.Connect VBMAN.enumDbType_MsSql, "127.0.0.1,1433", "sa", "pwd", "maindb" Case "backup" dbInst.Connect VBMAN.enumDbType_Mysql, "192.168.1.100:3306", "user", "pwd", "backupdb" Case "readonly" dbInst.Connect VBMAN.enumDbType_MsSql, "127.0.0.1,1433", "readonly", "pwd", "maindb" End Select Set GetDatabase = dbInst End Function ' 使用 Dim dbMain As VBMAN.cDataBase Set dbMain = GetDatabase("main") dbMain.Sql("SELECT * FROM users").Query ``` ### 连接清理 ```vb ' 移除指定连接 db.ConnInstRemove "log" ' 移除所有连接 db.ConnInstRemove "" ``` *** ## 批量操作优化 ### 批量插入优化 ```vb ' 方法 1：使用 BatchInsert（推荐，内部自动使用事务） Sub BatchInsertUsers(colUsers As Collection) If db.BatchInsert("users", colUsers) Then Debug.Print "批量插入成功" End If End Sub ' 方法 2：使用事务 + 循环 Sub BatchInsertUsers2(colUsers As Collection) db.TransBegin Dim i As Long For i = 1 To colUsers.Count Dim dictUser As Dictionary Set dictUser = colUsers(i) Dim sSql As String sSql = "INSERT INTO users (name, age) VALUES ('" & _ db.Escape(dictUser("name")) & "', " & dictUser("age") & ")" If Not db.Sql(sSql).Exec Then db.TransRollback Exit Sub End If Next db.TransCommit End Sub ' 方法 3：使用 VALUES 子句（SQL Server/MySQL） Sub BatchInsertUsers3(colUsers As Collection) Dim sSql As String sSql = "INSERT INTO users (name, age) VALUES " Dim i As Long For i = 1 To colUsers.Count Dim dictUser As Dictionary Set dictUser = colUsers(i) If i > 1 Then sSql = sSql & ", " sSql = sSql & "('" & db.Escape(dictUser("name")) & "', " & dictUser("age") & ")" Next db.Sql(sSql).Exec End Sub ``` ### 批量更新优化 ```vb ' 使用事务批量更新 Sub BatchUpdateUsers(colUpdates As Collection) db.TransBegin Dim i As Long For i = 1 To colUpdates.Count Dim dictUpdate As Dictionary Set dictUpdate = colUpdates(i) If Not db.Sql("UPDATE users SET name = ?, age = ? WHERE id = ?") _ .Param("name", dictUpdate("name"), adVarWChar) _ .Param("age", dictUpdate("age"), adInteger) _ .Param("id", dictUpdate("id"), adInteger) _ .ExecParam Then db.TransRollback Exit Sub End If Next db.TransCommit End Sub ``` *** ## 性能优化技巧 ### 1. 使用索引字段 ```vb ' ? 推荐：使用索引字段作为条件 db.Sql("SELECT * FROM users WHERE id = 1").Query ' ? 不推荐：使用非索引字段 db.Sql("SELECT * FROM users WHERE name = '张三'").Query ``` ### 2. 只查询需要的字段 ```vb ' ? 推荐：只查询需要的字段 db.Sql("SELECT id, name FROM users").Query ' ? 不推荐：查询所有字段 db.Sql("SELECT * FROM users").Query ``` ### 3. 使用合适的游标类型 ```vb ' ? 推荐：只读查询使用 ForwardOnly db.Sql("SELECT * FROM users").Query adOpenForwardOnly, adLockReadOnly ' ? 不推荐：使用默认游标（可能较慢） db.Sql("SELECT * FROM users").Query ``` ### 4. 限制结果集大小 ```vb ' ? 推荐：使用 TOP/LIMIT 限制结果 db.Sql("SELECT TOP 100 * FROM users").Query ' ? 不推荐：查询所有数据 db.Sql("SELECT * FROM users").Query ``` ### 5. 使用分页 ```vb ' ? 推荐：使用分页 db.Sql("SELECT * FROM users").Page(1, 20).Query ' ? 不推荐：一次性查询所有数据 db.Sql("SELECT * FROM users").Query ``` ### 6. 缓存查询结果 ```vb ' 缓存查询结果 Private m_colCachedUsers As Collection Private m_dtCacheTime As Date Function GetUsers() As Collection ' 缓存 5 分钟 If DateDiff("s", m_dtCacheTime, Now) > 300 Or m_colCachedUsers Is Nothing Then If db.Sql("SELECT * FROM users").Fetch Then Set m_colCachedUsers = db.Rows m_dtCacheTime = Now End If End If Set GetUsers = m_colCachedUsers End Function ``` *** ## 错误处理策略 ### 统一错误处理 ```vb ' 统一错误处理函数 Function ExecuteSQL(sSql As String) As Boolean On Error GoTo ErrHandler If db.Sql(sSql).Exec Then ExecuteSQL = True Else LogError "SQL执行失败", db.LastErr ExecuteSQL = False End If Exit Function ErrHandler: LogError "发生异常", Err.Description ExecuteSQL = False End Function ' 错误日志记录 Sub LogError(sOperation As String, sError As String) ' 记录到文件或数据库 Debug.Print Now & " - " & sOperation & ": " & sError End Sub ``` ### 重试机制 ```vb ' 带重试的查询 Function QueryWithRetry(sSql As String, Optional lMaxRetries As Long = 3) As Boolean Dim lRetry As Long For lRetry = 1 To lMaxRetries If db.Sql(sSql).Query Then QueryWithRetry = True Exit Function End If ' 检查连接 If Not db.CheckConnection Then db.Connect VBMAN.enumDbType_MsSql, "127.0.0.1,1433", "sa", "pwd", "mydb" End If ' 等待后重试 Sleep 1000 Next QueryWithRetry = False End Function ``` *** ## 设计模式应用 ### 单例模式 ```vb ' 数据库单例 Private m_DB As VBMAN.cDataBase Function GetDatabase() As VBMAN.cDataBase If m_DB Is Nothing Then Set m_DB = New VBMAN.cDataBase m_DB.Connect VBMAN.enumDbType_MsSql, "127.0.0.1,1433", "sa", "pwd", "mydb" End If Set GetDatabase = m_DB End Function ``` ### 工厂模式 ```vb ' 数据库工厂 Function CreateDatabase(sType As String) As VBMAN.cDataBase Dim db As New VBMAN.cDataBase Select Case sType Case "main" db.Connect VBMAN.enumDbType_MsSql, "127.0.0.1,1433", "sa", "pwd", "maindb" Case "log" db.Connect VBMAN.enumDbType_Mysql, "192.168.1.100:3306", "loguser", "pwd", "logdb" Case "cache" db.Connect VBMAN.enumDbType_MsSql, "127.0.0.1,1433", "sa", "pwd", "cachedb" End Select Set CreateDatabase = db End Function ``` ### 仓储模式 ```vb ' 用户仓储 Class cUserRepository Private m_DB As VBMAN.cDataBase Private Sub Class_Initialize() Set m_DB = New VBMAN.cDataBase m_DB.Connect VBMAN.enumDbType_MsSql, "127.0.0.1,1433", "sa", "pwd", "mydb" End Sub Function GetById(lId As Long) As Dictionary If m_DB.Sql("SELECT * FROM users WHERE id = ?") _ .Param("id", lId, adInteger) _ .QueryParam Then If m_DB.Rows.Count > 0 Then Set GetById = m_DB.Row End If End If End Function Function GetAll() As Collection If m_DB.Sql("SELECT * FROM users").Fetch Then Set GetAll = m_DB.Rows End If End Function Function Save(dictUser As Dictionary) As Boolean If m_DB.Sql("INSERT INTO users (name, age) VALUES (?, ?)") _ .Param("name", dictUser("name"), adVarWChar) _ .Param("age", dictUser("age"), adInteger) _ .ExecParam Then Save = True Else Save = False End If End Function End Class ``` *** ## 常见问题解决 ### Q1: 连接超时 **问题**: 连接数据库时超时。 **解决**: ```vb ' 设置连接超时 db.Conn.ConnectionTimeout = 30 ' 30 秒 db.Connect VBMAN.enumDbType_MsSql, "127.0.0.1,1433", "sa", "pwd", "mydb" ``` ### Q2: 查询超时 **问题**: 查询执行时间过长。 **解决**: ```vb ' 设置命令超时 db.Conn.CommandTimeout = 60 ' 60 秒 db.Sql("SELECT * FROM large_table").Query ``` ### Q3: 内存不足 **问题**: 查询大量数据导致内存不足。 **解决**: ```vb ' 使用分页查询 db.Sql("SELECT * FROM large_table").Page(1, 1000).Query ' 或使用流式处理 If db.Sql("SELECT * FROM large_table").Query Then Do Until db.Rs.EOF ' 处理单条记录 ProcessRecord db.Rs db.Rs.MoveNext Loop End If ``` ### Q4: 并发冲突 **问题**: 多个操作同时执行导致冲突。 **解决**: ```vb ' 使用事务和锁定 db.TransBegin db.Sql("SELECT * FROM users WHERE id = 1").Query adOpenKeyset, adLockPessimistic ' 处理数据 db.Sql("UPDATE users SET ...").Exec db.TransCommit ``` *** ## 最佳实践总结 ### 1. 连接管理 * ? 在需要时连接，使用完毕后断开 * ? 对于频繁操作，保持连接 * ? 使用连接池管理多个连接 ### 2. 查询优化 * ? 使用索引字段作为条件 * ? 只查询需要的字段 * ? 使用分页限制结果集 * ? 使用合适的游标类型 ### 3. 安全防护 * ? 始终使用参数化查询 * ? 验证用户输入 * ? 使用事务保证一致性 ### 4. 错误处理 * ? 始终检查返回值 * ? 记录错误日志 * ? 实现重试机制 ### 5. 代码组织 * ? 使用设计模式 * ? 封装常用操作 * ? 保持代码清晰 *** **最后更新**: 2026-01-21 --- --- url: /zh/emoji/10A0-10FF.md --- # 格鲁吉亚语 (Georgian) 本页面展示了Unicode字符集中，位于U+10A0到U+10FF范围的格鲁吉亚文字符。格鲁吉亚文是格鲁吉亚的官方文字，有独特的书写系统。 | 字符 | Unicode | VB函数值 | 名称 | |:---:|:---:|:---:|:---| | Ⴀ | U+10A0 | ChrW(\&H10A0) | 格鲁吉亚大写字母AN | | Ⴁ | U+10A1 | ChrW(\&H10A1) | 格鲁吉亚大写字母BAN | | Ⴂ | U+10A2 | ChrW(\&H10A2) | 格鲁吉亚大写字母GAN | | Ⴃ | U+10A3 | ChrW(\&H10A3) | 格鲁吉亚大写字母DON | | Ⴄ | U+10A4 | ChrW(\&H10A4) | 格鲁吉亚大写字母EN | | Ⴅ | U+10A5 | ChrW(\&H10A5) | 格鲁吉亚大写字母VIN | | Ⴆ | U+10A6 | ChrW(\&H10A6) | 格鲁吉亚大写字母ZEN | | Ⴇ | U+10A7 | ChrW(\&H10A7) | 格鲁吉亚大写字母TAN | | Ⴈ | U+10A8 | ChrW(\&H10A8) | 格鲁吉亚大写字母IN | | Ⴉ | U+10A9 | ChrW(\&H10A9) | 格鲁吉亚大写字母KAN | | Ⴊ | U+10AA | ChrW(\&H10AA) | 格鲁吉亚大写字母LAS | | Ⴋ | U+10AB | ChrW(\&H10AB) | 格鲁吉亚大写字母MAN | | Ⴌ | U+10AC | ChrW(\&H10AC) | 格鲁吉亚大写字母NAR | | Ⴍ | U+10AD | ChrW(\&H10AD) | 格鲁吉亚大写字母ON | | Ⴎ | U+10AE | ChrW(\&H10AE) | 格鲁吉亚大写字母PAR | | Ⴏ | U+10AF | ChrW(\&H10AF) | 格鲁吉亚大写字母ZHAR | | Ⴐ | U+10B0 | ChrW(\&H10B0) | 格鲁吉亚大写字母RAE | | Ⴑ | U+10B1 | ChrW(\&H10B1) | 格鲁吉亚大写字母SAN | | Ⴒ | U+10B2 | ChrW(\&H10B2) | 格鲁吉亚大写字母TAR | | Ⴓ | U+10B3 | ChrW(\&H10B3) | 格鲁吉亚大写字母UN | | Ⴔ | U+10B4 | ChrW(\&H10B4) | 格鲁吉亚大写字母PHAR | | Ⴕ | U+10B5 | ChrW(\&H10B5) | 格鲁吉亚大写字母KHAR | | Ⴖ | U+10B6 | ChrW(\&H10B6) | 格鲁吉亚大写字母GHAN | | Ⴗ | U+10B7 | ChrW(\&H10B7) | 格鲁吉亚大写字母QAR | | Ⴘ | U+10B8 | ChrW(\&H10B8) | 格鲁吉亚大写字母SHIN | | Ⴙ | U+10B9 | ChrW(\&H10B9) | 格鲁吉亚大写字母CHIN | | Ⴚ | U+10BA | ChrW(\&H10BA) | 格鲁吉亚大写字母CAN | | Ⴛ | U+10BB | ChrW(\&H10BB) | 格鲁吉亚大写字母JIL | | Ⴜ | U+10BC | ChrW(\&H10BC) | 格鲁吉亚大写字母CIL | | Ⴝ | U+10BD | ChrW(\&H10BD) | 格鲁吉亚大写字母CHAR | | Ⴞ | U+10BE | ChrW(\&H10BE) | 格鲁吉亚大写字母XAN | | Ⴟ | U+10BF | ChrW(\&H10BF) | 格鲁吉亚大写字母JHAN | | Ⴠ | U+10C0 | ChrW(\&H10C0) | 格鲁吉亚大写字母HAE | | Ⴡ | U+10C1 | ChrW(\&H10C1) | 格鲁吉亚大写字母HE | | Ⴢ | U+10C2 | ChrW(\&H10C2) | 格鲁吉亚大写字母HIE | | Ⴣ | U+10C3 | ChrW(\&H10C3) | 格鲁吉亚大写字母WE | | Ⴤ | U+10C4 | ChrW(\&H10C4) | 格鲁吉亚大写字母HAR | | Ⴥ | U+10C5 | ChrW(\&H10C5) | 格鲁吉亚大写字母HOE | | ა | U+10D0 | ChrW(\&H10D0) | 格鲁吉亚小写字母AN | | ბ | U+10D1 | ChrW(\&H10D1) | 格鲁吉亚小写字母BAN | | გ | U+10D2 | ChrW(\&H10D2) | 格鲁吉亚小写字母GAN | | დ | U+10D3 | ChrW(\&H10D3) | 格鲁吉亚小写字母DON | | ე | U+10D4 | ChrW(\&H10D4) | 格鲁吉亚小写字母EN | | ვ | U+10D5 | ChrW(\&H10D5) | 格鲁吉亚小写字母VIN | | ზ | U+10D6 | ChrW(\&H10D6) | 格鲁吉亚小写字母ZEN | | თ | U+10D7 | ChrW(\&H10D7) | 格鲁吉亚小写字母TAN | | ი | U+10D8 | ChrW(\&H10D8) | 格鲁吉亚小写字母IN | | კ | U+10D9 | ChrW(\&H10D9) | 格鲁吉亚小写字母KAN | | ლ | U+10DA | ChrW(\&H10DA) | 格鲁吉亚小写字母LAS | | მ | U+10DB | ChrW(\&H10DB) | 格鲁吉亚小写字母MAN | | ნ | U+10DC | ChrW(\&H10DC) | 格鲁吉亚小写字母NAR | | ო | U+10DD | ChrW(\&H10DD) | 格鲁吉亚小写字母ON | | პ | U+10DE | ChrW(\&H10DE) | 格鲁吉亚小写字母PAR | | ჟ | U+10DF | ChrW(\&H10DF) | 格鲁吉亚小写字母ZHAR | | რ | U+10E0 | ChrW(\&H10E0) | 格鲁吉亚小写字母RAE | | ს | U+10E1 | ChrW(\&H10E1) | 格鲁吉亚小写字母SAN | | ტ | U+10E2 | ChrW(\&H10E2) | 格鲁吉亚小写字母TAR | | უ | U+10E3 | ChrW(\&H10E3) | 格鲁吉亚小写字母UN | | ფ | U+10E4 | ChrW(\&H10E4) | 格鲁吉亚小写字母PHAR | | ქ | U+10E5 | ChrW(\&H10E5) | 格鲁吉亚小写字母KHAR | | ღ | U+10E6 | ChrW(\&H10E6) | 格鲁吉亚小写字母GHAN | | ყ | U+10E7 | ChrW(\&H10E7) | 格鲁吉亚小写字母QAR | | შ | U+10E8 | ChrW(\&H10E8) | 格鲁吉亚小写字母SHIN | | ჩ | U+10E9 | ChrW(\&H10E9) | 格鲁吉亚小写字母CHIN | | ც | U+10EA | ChrW(\&H10EA) | 格鲁吉亚小写字母CAN | | ძ | U+10EB | ChrW(\&H10EB) | 格鲁吉亚小写字母JIL | | წ | U+10EC | ChrW(\&H10EC) | 格鲁吉亚小写字母CIL | | ჭ | U+10ED | ChrW(\&H10ED) | 格鲁吉亚小写字母CHAR | | ხ | U+10EE | ChrW(\&H10EE) | 格鲁吉亚小写字母XAN | | ჯ | U+10EF | ChrW(\&H10EF) | 格鲁吉亚小写字母JHAN | | ჰ | U+10F0 | ChrW(\&H10F0) | 格鲁吉亚小写字母HAE | | ჱ | U+10F1 | ChrW(\&H10F1) | 格鲁吉亚小写字母HE | | ჲ | U+10F2 | ChrW(\&H10F2) | 格鲁吉亚小写字母HIE | | ჳ | U+10F3 | ChrW(\&H10F3) | 格鲁吉亚小写字母WE | | ჴ | U+10F4 | ChrW(\&H10F4) | 格鲁吉亚小写字母HAR | | ჵ | U+10F5 | ChrW(\&H10F5) | 格鲁吉亚小写字母HOE | | ჶ | U+10F6 | ChrW(\&H10F6) | 格鲁吉亚小写字母FI | | ჷ | U+10F7 | ChrW(\&H10F7) | 格鲁吉亚小写字母YN | | ჸ | U+10F8 | ChrW(\&H10F8) | 格鲁吉亚小写字母ELIFI | | ჹ | U+10F9 | ChrW(\&H10F9) | 格鲁吉亚小写字母TURNED GAN | | ჺ | U+10FA | ChrW(\&H10FA) | 格鲁吉亚小写字母AIN | | ჽ | U+10FD | ChrW(\&H10FD) | 格鲁吉亚小写字母AEN | | ჾ | U+10FE | ChrW(\&H10FE) | 格鲁吉亚小写字母HARD SIGN | | ჿ | U+10FF | ChrW(\&H10FF) | 格鲁吉亚小写字母LABIAL SIGN | --- --- url: /zh/vbman/database/utilities.md --- # 工具方法 本文档详细介绍 cDataBase 类提供的各种工具方法，用于简化常用数据库操作。 *** ## ? 目录 * [公共属性](#公共属性) * [Count 方法](#count-方法) * [LastInsertId 方法](#lastinsertid-方法) * [TableExists 方法](#tableexists-方法) * [GetTableFields 方法](#gettablefields-方法) * [GetTables 方法](#gettables-方法) * [GetDatabases 方法](#getdatabases-方法) * [GetVersion 方法](#getversion-方法) * [Escape 方法](#escape-方法) * [CheckConnection 方法](#checkconnection-方法) *** ## 公共属性 cDataBase 类暴露以下公共属性（可直接读写）： | 属性 | 类型 | 说明 | | ---------------- | ----------------- | --------------------------------------------- | | `IsConnect` | `Boolean` | 连接状态标记 | | `DatabaseType` | `enumDbType` | 当前数据库类型（连接后自动设置） | | `IsCloneInstance`| `Boolean` | 是否为连接池克隆实例（断开时不关闭共享连接） | | `Rs` | `ADODB.Recordset` | 当前 Recordset | | `Rows` | `cCollection` | 查询结果集（Fetch/FetchParam 后自动填充） | | `Row` | `Dictionary` | 当前第一行数据（Fetch/FetchParam 后自动填充） | | `Conn` | `ADODB.Connection`| ADO 连接对象（WithEvents，支持异步回调） | | `LastErr` | `String` | 最后错误信息（完整描述） | | `LastErrNumber` | `Long` | 最后错误代码 | | `LastErrDescription`| `String` | 最后错误描述 | *** ## Count 方法 ### 语法 统计表中的记录数。 ```vb Function Count(Optional ByVal TableName As String = "") As Long ``` ### 参数说明 | 参数 | 类型 | 说明 | | ----------- | -------- | -------------------------------- | | `TableName` | `String` | 表名（可选，为空时使用当前 SQL） | ### 返回值 返回记录数（`Long` 类型）。 ### 示例 ```vb ' 统计指定表的记录数 Dim lCount As Long lCount = db.Count("users") Debug.Print "用户总数: " & lCount ' 统计当前 SQL 查询结果的记录数 db.Sql("SELECT * FROM users WHERE age > 18") lCount = db.Count() ' 使用当前 SQL Debug.Print "成年用户数: " & lCount ``` ### 实现原理 ```vb ' 如果指定了表名 SELECT COUNT(*) AS cnt FROM users ' 如果使用当前 SQL SELECT COUNT(*) AS cnt FROM (SELECT * FROM users WHERE age > 18) AS T ``` *** ## LastInsertId 方法 ### 语法 获取最后插入的自增主键 ID。 ```vb Function LastInsertId() As Variant ``` ### 返回值 返回最后插入的 ID（`Variant` 类型）。 ### 支持的数据库 | 数据库 | 实现方式 | | ---------- | ------------------ | | SQL Server | `SCOPE_IDENTITY()` | | MySQL | `LAST_INSERT_ID()` | | Access | `@@IDENTITY` | ### 示例 ```vb ' 插入数据 If db.Sql("INSERT INTO users (name, age) VALUES ('张三', 25)").Exec Then ' 获取最后插入的 ID Dim lId As Variant lId = db.LastInsertId Debug.Print "新用户 ID: " & lId End If ``` ### 注意事项 1. **必须在 INSERT 后立即调用** ```vb ' ? 正确 db.Sql("INSERT INTO users (name) VALUES ('张三')").Exec Dim lId As Variant lId = db.LastInsertId ' ? 错误：中间有其他操作 db.Sql("INSERT INTO users (name) VALUES ('张三')").Exec db.Sql("SELECT * FROM users").Query ' 这会重置 ID Dim lId As Variant lId = db.LastInsertId ' 可能获取不到正确的 ID ``` 2. **仅支持自增主键** ```vb ' 表必须有自增主键 CREATE TABLE users ( id INT IDENTITY(1,1) PRIMARY KEY, -- SQL Server name NVARCHAR(50) ) ``` *** ## TableExists 方法 ### 语法 判断表是否存在。 ```vb Function TableExists(ByVal TableName As String) As Boolean ``` ### 参数说明 | 参数 | 类型 | 说明 | | ----------- | -------- | ------------ | | `TableName` | `String` | 表名（必需） | ### 返回值 * `True` - 表存在 * `False` - 表不存在 ### 支持的数据库 | 数据库 | 实现方式 | | ---------- | --------------------------- | | SQL Server | `INFORMATION_SCHEMA.TABLES` | | MySQL | `INFORMATION_SCHEMA.TABLES` | | Access | `MSysObjects` | ### 示例 ```vb ' 检查表是否存在 If db.TableExists("users") Then Debug.Print "users 表存在" Else Debug.Print "users 表不存在" ' 创建表 db.Sql("CREATE TABLE users (id INT PRIMARY KEY, name NVARCHAR(50))").Exec End If ``` ### 使用场景 ```vb ' 场景 1：创建表前检查 If Not db.TableExists("users") Then db.Sql("CREATE TABLE users (...)").Exec End If ' 场景 2：删除表前检查 If db.TableExists("temp_table") Then db.Sql("DROP TABLE temp_table").Exec End If ``` *** ## GetTableFields 方法 ### 语法 获取表的字段列表。 ```vb Function GetTableFields(ByVal TableName As String) As Collection ``` ### 参数说明 | 参数 | 类型 | 说明 | | ----------- | -------- | ------------ | | `TableName` | `String` | 表名（必需） | ### 返回值 返回字段名集合（`Collection` 类型）。 ### 支持的数据库 | 数据库 | 实现方式 | | ---------- | ---------------------------- | | SQL Server | `INFORMATION_SCHEMA.COLUMNS` | | MySQL | `INFORMATION_SCHEMA.COLUMNS` | | Access | `MSysObjects` | ### 示例 ```vb ' 获取字段列表 Dim colFields As Collection Set colFields = db.GetTableFields("users") ' 遍历字段 Dim i As Long For i = 1 To colFields.Count Debug.Print "字段 " & i & ": " & colFields(i) Next ``` ### 使用场景 ```vb ' 场景 1：动态生成 SQL Function BuildSelectSQL(sTableName As String) As String Dim colFields As Collection Set colFields = db.GetTableFields(sTableName) Dim sFields As String Dim i As Long For i = 1 To colFields.Count If sFields <> "" Then sFields = sFields & ", " sFields = sFields & colFields(i) Next BuildSelectSQL = "SELECT " & sFields & " FROM " & sTableName End Function ' 场景 2：验证字段是否存在 Function FieldExists(sTableName As String, sFieldName As String) As Boolean Dim colFields As Collection Set colFields = db.GetTableFields(sTableName) Dim i As Long For i = 1 To colFields.Count If colFields(i) = sFieldName Then FieldExists = True Exit Function End If Next FieldExists = False End Function ``` *** ## GetTables 方法 ### 语法 获取数据库中的表名列表。 ```vb Function GetTables(Optional ByVal DatabaseName As String = "") As Collection ``` ### 参数说明 | 参数 | 类型 | 说明 | | -------------- | -------- | -------------------------------------- | | `DatabaseName` | `String` | 数据库名（可选，为空时使用当前数据库） | ### 返回值 返回表名集合（`Collection` 类型）。 ### 支持的数据库 | 数据库 | 实现方式 | | ---------- | --------------------------- | | SQL Server | `INFORMATION_SCHEMA.TABLES` | | MySQL | `INFORMATION_SCHEMA.TABLES` | | Access | `MSysObjects` | ### 示例 ```vb ' 获取当前数据库的表列表 Dim colTables As Collection Set colTables = db.GetTables() ' 遍历表名 Dim i As Long For i = 1 To colTables.Count Debug.Print "表 " & i & ": " & colTables(i) Next ' 获取指定数据库的表列表（SQL Server/MySQL） Set colTables = db.GetTables("mydb") ``` ### 使用场景 ```vb ' 场景 1：列出所有表 Sub ListAllTables() Dim colTables As Collection Set colTables = db.GetTables() Dim i As Long For i = 1 To colTables.Count Debug.Print colTables(i) Next End Sub ' 场景 2：备份所有表 Sub BackupAllTables() Dim colTables As Collection Set colTables = db.GetTables() Dim i As Long For i = 1 To colTables.Count Dim sTableName As String sTableName = colTables(i) db.Sql("SELECT * INTO " & sTableName & "_backup FROM " & sTableName).Exec Next End Sub ``` *** ## GetDatabases 方法 ### 语法 获取数据库服务器中的数据库列表。 ```vb Function GetDatabases() As Collection ``` ### 返回值 返回数据库名集合（`Collection` 类型）。 ### 支持的数据库 | 数据库 | 实现方式 | | ---------- | ---------------- | | SQL Server | `sys.databases` | | MySQL | `SHOW DATABASES` | ### 示例 ```vb ' 获取数据库列表 Dim colDatabases As Collection Set colDatabases = db.GetDatabases() ' 遍历数据库名 Dim i As Long For i = 1 To colDatabases.Count Debug.Print "数据库 " & i & ": " & colDatabases(i) Next ``` ### 使用场景 ```vb ' 场景 1：列出所有数据库 Sub ListAllDatabases() Dim colDatabases As Collection Set colDatabases = db.GetDatabases() Dim i As Long For i = 1 To colDatabases.Count Debug.Print colDatabases(i) Next End Sub ' 场景 2：切换数据库 Sub SwitchDatabase(sDatabaseName As String) ' 检查数据库是否存在 Dim colDatabases As Collection Set colDatabases = db.GetDatabases() Dim i As Long Dim bExists As Boolean bExists = False For i = 1 To colDatabases.Count If colDatabases(i) = sDatabaseName Then bExists = True Exit For End If Next If bExists Then db.Sql("USE " & sDatabaseName).Exec Else Debug.Print "数据库不存在: " & sDatabaseName End If End Sub ``` *** ## GetVersion 方法 ### 语法 获取数据库版本信息。 ```vb Function GetVersion() As String ``` ### 返回值 返回版本字符串（`String` 类型）。 ### 示例 ```vb ' 获取数据库版本 Dim sVersion As String sVersion = db.GetVersion Debug.Print "数据库版本: " & sVersion ``` ### 使用场景 ```vb ' 场景 1：检查数据库版本 Sub CheckDatabaseVersion() Dim sVersion As String sVersion = db.GetVersion Debug.Print "当前数据库版本: " & sVersion End Sub ' 场景 2：版本兼容性检查 Function IsVersionCompatible(sMinVersion As String) As Boolean Dim sVersion As String sVersion = db.GetVersion ' 比较版本逻辑... IsVersionCompatible = True End Function ``` *** ## Escape 方法 ### 语法 转义 SQL 字符串中的特殊字符（防止 SQL 注入）。 ```vb Function Escape(ByVal Str As String) As String ``` ### 参数说明 | 参数 | 类型 | 说明 | | ----- | -------- | ---------------------- | | `Str` | `String` | 要转义的字符串（必需） | ### 返回值 返回转义后的字符串（`String` 类型）。 ### 实现原理 将单引号 `'` 转义为两个单引号 `''`。 ### 示例 ```vb ' 转义字符串 Dim sName As String sName = "O'Brien" Dim sEscaped As String sEscaped = db.Escape(sName) ' 结果: "O''Brien" ' 使用转义后的字符串 db.Sql("SELECT * FROM users WHERE name = '" & sEscaped & "'").Query ``` ### 注意事项 **推荐使用参数化查询而不是 Escape 方法**： ```vb ' ? 推荐：使用参数化查询 db.Sql("SELECT * FROM users WHERE name = ?") _ .Param("name", "O'Brien", adVarWChar) _ .QueryParam ' ?? 可以使用：使用 Escape（但不如参数化查询安全） db.Sql("SELECT * FROM users WHERE name = '" & db.Escape("O'Brien") & "'").Query ``` *** ## CheckConnection 方法 ### 语法 检查连接状态并尝试重连。 ```vb Function CheckConnection() As Boolean ``` ### 返回值 * `True` - 连接正常或重连成功 * `False` - 连接断开且重连失败 ### 功能 1. 检查连接状态 2. 如果断开，尝试重新连接 3. 更新连接标记 ### 示例 ```vb ' 检查连接 If Not db.CheckConnection Then Debug.Print "连接已断开，尝试重连..." ' 重新连接 db.Connect VBMAN.enumDbType_MsSql, "127.0.0.1,1433", "sa", "pwd", "mydb" End If ``` ### 使用场景 ```vb ' 场景 1：定期检查连接 Private Sub Timer1_Timer() If Not db.CheckConnection Then Debug.Print "连接断开，需要重新连接" End If End Sub ' 场景 2：操作前检查连接 Sub ExecuteQuery() ' 检查连接 If Not db.CheckConnection Then Debug.Print "连接不可用" Exit Sub End If ' 执行查询 db.Sql("SELECT * FROM users").Query End Sub ``` *** ## 综合示例 ### 示例 1：数据库信息查看器 ```vb Sub ShowDatabaseInfo() ' 显示数据库版本 Debug.Print "数据库版本: " & db.GetVersion ' 显示数据库列表 Dim colDatabases As Collection Set colDatabases = db.GetDatabases() Debug.Print "数据库列表:" Dim i As Long For i = 1 To colDatabases.Count Debug.Print " - " & colDatabases(i) Next ' 显示表列表 Dim colTables As Collection Set colTables = db.GetTables() Debug.Print "表列表:" For i = 1 To colTables.Count Debug.Print " - " & colTables(i) ' 显示每个表的字段 Dim colFields As Collection Set colFields = db.GetTableFields(colTables(i)) Dim j As Long For j = 1 To colFields.Count Debug.Print " * " & colFields(j) Next Next End Sub ``` ### 示例 2：表结构比较 ```vb Function CompareTableStructure(sTable1 As String, sTable2 As String) As Boolean Dim colFields1 As Collection Dim colFields2 As Collection Set colFields1 = db.GetTableFields(sTable1) Set colFields2 = db.GetTableFields(sTable2) ' 比较字段数量 If colFields1.Count <> colFields2.Count Then CompareTableStructure = False Exit Function End If ' 比较字段名 Dim i As Long For i = 1 To colFields1.Count If colFields1(i) <> colFields2(i) Then CompareTableStructure = False Exit Function End If Next CompareTableStructure = True End Function ``` *** **最后更新**: 2026-01-21 --- --- url: /zh/packages/vbccr/bars/toolbar.md description: 工具栏控件（ToolBar） - VBCCR 开发手册，基于源码的完整 API 参考 --- # 工具栏控件（ToolBar） 提供可自定义的工具栏，支持扁平/标准样式、下拉按钮、按钮菜单、用户自定义和OLE拖放。 ## 枚举 ### TbrStyleConstants 工具栏样式常量。 | 常量 | 值 | 说明 | |------|-----|------| | TbrStyleStandard | 0 | 标准工具栏样式 | | TbrStyleFlat | 1 | 扁平工具栏样式 | ### TbrTextAlignConstants 按钮文本对齐方式常量。 | 常量 | 值 | 说明 | |------|-----|------| | TbrTextAlignBottom | 0 | 文本显示在按钮底部 | | TbrTextAlignRight | 1 | 文本显示在按钮右侧 | ### TbrOrientationConstants 工具栏方向常量。 | 常量 | 值 | 说明 | |------|-----|------| | TbrOrientationHorizontal | 0 | 水平方向 | | TbrOrientationVertical | 1 | 垂直方向 | ### TbrButtonStyleConstants 按钮样式常量。 | 常量 | 值 | 说明 | |------|-----|------| | TbrButtonDefault | 0 | 默认按钮样式 | | TbrButtonCheck | 1 | 复选按钮样式 | | TbrButtonCheckGroup | 2 | 复选组按钮样式（同组互斥） | | TbrButtonSeparator | 3 | 分隔符 | | TbrButtonDropDown | 4 | 下拉按钮样式 | | TbrButtonWholeDropDown | 5 | 整体下拉按钮样式 | ### TbrButtonValueConstants 按钮状态值常量。 | 常量 | 值 | 说明 | |------|-----|------| | TbrButtonUnpressed | 0 | 未按下状态 | | TbrButtonPressed | 1 | 按下状态 | ## 属性 ### Name ```vb Public Property Get Name() As String ``` 返回在代码中标识对象的名称。 ### Tag ```vb Public Property Get Tag() As String Public Property Let Tag(ByVal Value As String) ``` 存储程序所需的额外数据。 ### Parent ```vb Public Property Get Parent() As Object ``` 返回对象所在的对象。 ### Container ```vb Public Property Get Container() As Object Public Property Set Container(ByVal Value As Object) ``` 返回/设置对象的容器。 ### Left ```vb Public Property Get Left() As Single Public Property Let Left(ByVal Value As Single) ``` 返回/设置对象与其容器左边缘的距离。 ### Top ```vb Public Property Get Top() As Single Public Property Let Top(ByVal Value As Single) ``` 返回/设置对象与其容器顶边缘的距离。 ### Width ```vb Public Property Get Width() As Single Public Property Let Width(ByVal Value As Single) ``` 返回/设置对象的宽度。 ### Height ```vb Public Property Get Height() As Single Public Property Let Height(ByVal Value As Single) ``` 返回/设置对象的高度。 ### Visible ```vb Public Property Get Visible() As Boolean Public Property Let Visible(ByVal Value As Boolean) ``` 返回/设置对象是否可见。 ### ToolTipText ```vb Public Property Get ToolTipText() As String Public Property Let ToolTipText(ByVal Value As String) ``` 返回/设置鼠标悬停时显示的提示文本。 ### WhatsThisHelpID ```vb Public Property Get WhatsThisHelpID() As Long Public Property Let WhatsThisHelpID(ByVal Value As Long) ``` 返回/设置关联的上下文帮助ID。 ### Align ```vb Public Property Get Align() As Integer Public Property Let Align(ByVal Value As Integer) ``` 返回/设置控件在其窗体上的对齐方式。 ### DragIcon ```vb Public Property Get DragIcon() As IPictureDisp Public Property Let DragIcon(ByVal Value As IPictureDisp) Public Property Set DragIcon(ByVal Value As IPictureDisp) ``` 返回/设置拖放操作中显示的图标。 ### DragMode ```vb Public Property Get DragMode() As Integer Public Property Let DragMode(ByVal Value As Integer) ``` 返回/设置拖动模式（手动或自动）。 ### hWnd ```vb Public Property Get hWnd() As LongPtr ``` 返回控件句柄。 ### hWndUserControl ```vb Public Property Get hWndUserControl() As LongPtr ``` 返回UserControl句柄。 ### Font ```vb Public Property Get Font() As StdFont Public Property Let Font(ByVal NewFont As StdFont) Public Property Set Font(ByVal NewFont As StdFont) ``` 返回/设置字体。 ### VisualStyles ```vb Public Property Get VisualStyles() As Boolean Public Property Let VisualStyles(ByVal Value As Boolean) ``` 返回/设置是否启用视觉样式。需要comctl32.dll 6.0或更高版本。 ### Enabled ```vb Public Property Get Enabled() As Boolean Public Property Let Enabled(ByVal Value As Boolean) ``` 返回/设置对象是否能响应用户事件。 ### OLEDropMode ```vb Public Property Get OLEDropMode() As OLEDropModeConstants Public Property Let OLEDropMode(ByVal Value As OLEDropModeConstants) ``` 返回/设置对象是否可以作为OLE放置目标。 ### MousePointer ```vb Public Property Get MousePointer() As CCMousePointerConstants Public Property Let MousePointer(ByVal Value As CCMousePointerConstants) ``` 返回/设置鼠标悬停时显示的指针类型。参见通用枚举。 ### MouseIcon ```vb Public Property Get MouseIcon() As IPictureDisp Public Property Let MouseIcon(ByVal Value As IPictureDisp) Public Property Set MouseIcon(ByVal Value As IPictureDisp) ``` 返回/设置自定义鼠标图标。 ### MouseTrack ```vb Public Property Get MouseTrack() As Boolean Public Property Let MouseTrack(ByVal Value As Boolean) ``` 返回/设置是否在鼠标进入或离开控件时触发事件。 ### RightToLeft ```vb Public Property Get RightToLeft() As Boolean Public Property Let RightToLeft(ByVal Value As Boolean) ``` 返回/设置从右到左显示方向。 ### RightToLeftLayout ```vb Public Property Get RightToLeftLayout() As Boolean Public Property Let RightToLeftLayout(ByVal Value As Boolean) ``` 返回/设置从右到左布局。 ### RightToLeftMode ```vb Public Property Get RightToLeftMode() As CCRightToLeftModeConstants Public Property Let RightToLeftMode(ByVal Value As CCRightToLeftModeConstants) ``` 返回/设置从右到左模式。参见通用枚举。 ### ImageList ```vb Public Property Get ImageList() As Variant Public Property Let ImageList(ByVal Value As Variant) Public Property Set ImageList(ByVal Value As Variant) ``` 返回/设置关联的ImageList控件。可以是对象引用、字符串键名或LongPtr句柄。 ### DisabledImageList ```vb Public Property Get DisabledImageList() As Variant Public Property Let DisabledImageList(ByVal Value As Variant) Public Property Set DisabledImageList(ByVal Value As Variant) ``` 返回/设置按钮禁用状态使用的ImageList控件。 ### HotImageList ```vb Public Property Get HotImageList() As Variant Public Property Let HotImageList(ByVal Value As Variant) Public Property Set HotImageList(ByVal Value As Variant) ``` 返回/设置按钮热点状态使用的ImageList控件。 ### PressedImageList ```vb Public Property Get PressedImageList() As Variant Public Property Let PressedImageList(ByVal Value As Variant) Public Property Set PressedImageList(ByVal Value As Variant) ``` 返回/设置按钮按下状态使用的ImageList控件。 ### BackColor ```vb Public Property Get BackColor() As OLE_COLOR Public Property Let BackColor(ByVal Value As OLE_COLOR) ``` 返回/设置背景色。 ### Style ```vb Public Property Get Style() As TbrStyleConstants Public Property Let Style(ByVal Value As TbrStyleConstants) ``` 返回/设置工具栏样式。 ### TextAlignment ```vb Public Property Get TextAlignment() As TbrTextAlignConstants Public Property Let TextAlignment(ByVal Value As TbrTextAlignConstants) ``` 返回/设置按钮文本对齐方式。 ### Orientation ```vb Public Property Get Orientation() As TbrOrientationConstants Public Property Let Orientation(ByVal Value As TbrOrientationConstants) ``` 返回/设置工具栏方向。 ### Divider ```vb Public Property Get Divider() As Boolean Public Property Let Divider(ByVal Value As Boolean) ``` 返回/设置是否显示分隔线。 ### ShowTips ```vb Public Property Get ShowTips() As Boolean Public Property Let ShowTips(ByVal Value As Boolean) ``` 返回/设置是否显示工具提示。 ### Wrappable ```vb Public Property Get Wrappable() As Boolean Public Property Let Wrappable(ByVal Value As Boolean) ``` 返回/设置按钮是否自动换行。 ### AllowCustomize ```vb Public Property Get AllowCustomize() As Boolean Public Property Let AllowCustomize(ByVal Value As Boolean) ``` 返回/设置是否允许用户自定义工具栏。 ### AltDrag ```vb Public Property Get AltDrag() As Boolean Public Property Let AltDrag(ByVal Value As Boolean) ``` 返回/设置是否允许Alt+拖动来自定义工具栏。 ### DoubleBuffer ```vb Public Property Get DoubleBuffer() As Boolean Public Property Let DoubleBuffer(ByVal Value As Boolean) ``` 返回/设置是否启用双缓冲绘制。 ### ButtonHeight ```vb Public Property Get ButtonHeight() As Single Public Property Let ButtonHeight(ByVal Value As Single) ``` 返回/设置按钮高度。 ### ButtonWidth ```vb Public Property Get ButtonWidth() As Single Public Property Let ButtonWidth(ByVal Value As Single) ``` 返回/设置按钮宽度。 ### MinButtonWidth ```vb Public Property Get MinButtonWidth() As Single Public Property Let MinButtonWidth(ByVal Value As Single) ``` 返回/设置最小按钮宽度。 ### MaxButtonWidth ```vb Public Property Get MaxButtonWidth() As Single Public Property Let MaxButtonWidth(ByVal Value As Single) ``` 返回/设置最大按钮宽度。 ### InsertMarkColor ```vb Public Property Get InsertMarkColor() As OLE_COLOR Public Property Let InsertMarkColor(ByVal Value As OLE_COLOR) ``` 返回/设置插入标记颜色。 ### Transparent ```vb Public Property Get Transparent() As Boolean Public Property Let Transparent(ByVal Value As Boolean) ``` 返回/设置工具栏是否透明。 ### HotTracking ```vb Public Property Get HotTracking() As Boolean Public Property Let HotTracking(ByVal Value As Boolean) ``` 返回/设置是否启用热点跟踪。 ### HideClippedButtons ```vb Public Property Get HideClippedButtons() As Boolean Public Property Let HideClippedButtons(ByVal Value As Boolean) ``` 返回/设置是否隐藏被裁剪的按钮。 ### AnchorHot ```vb Public Property Get AnchorHot() As Boolean Public Property Let AnchorHot(ByVal Value As Boolean) ``` 返回/设置是否锚定热点。 ### MaxTextRows ```vb Public Property Get MaxTextRows() As Integer Public Property Let MaxTextRows(ByVal Value As Integer) ``` 返回/设置最大文本行数。 ### Buttons ```vb Public Property Get Buttons() As TbrButtons ``` 返回按钮集合。 ## 方法 ### OLEDrag ```vb Public Sub OLEDrag() ``` 启动OLE拖放操作。 ### Drag ```vb Public Sub Drag(Optional ByRef Action As Variant) ``` 开始、结束或取消拖动操作。 ### ZOrder ```vb Public Sub ZOrder(Optional ByRef Position As Variant) ``` 设置Z顺序。 ### Refresh ```vb Public Sub Refresh() ``` 强制完全重绘对象。 ## 事件 ### Click ```vb Public Event Click() ``` 用户单击控件时触发。 ### DblClick ```vb Public Event DblClick() ``` 用户双击控件时触发。 ### Resize ```vb Public Event Resize() ``` 控件大小改变时触发。 ### BeginCustomization ```vb Public Event BeginCustomization() ``` 开始自定义工具栏时触发。 ### InitCustomizationDialog ```vb Public Event InitCustomizationDialog(ByVal hDlg As LongPtr, ByRef HideHelpButton As Boolean) ``` 初始化自定义对话框时触发。hDlg为对话框句柄，HideHelpButton控制是否隐藏帮助按钮。 ### CustomizationChange ```vb Public Event CustomizationChange() ``` 自定义工具栏发生改变时触发。 ### ResetCustomizations ```vb Public Event ResetCustomizations(ByRef CloseDialog As Boolean) ``` 重置自定义时触发。CloseDialog控制是否关闭对话框。 ### CustomizationHelp ```vb Public Event CustomizationHelp() ``` 用户在自定义对话框中点击帮助时触发。 ### EndCustomization ```vb Public Event EndCustomization() ``` 结束自定义工具栏时触发。 ### ButtonClick ```vb Public Event ButtonClick(ByVal Button As TbrButton) ``` 用户单击按钮时触发。 ### ButtonDrag ```vb Public Event ButtonDrag(ByVal Button As TbrButton, ByVal MouseButton As Integer) ``` 用户拖动按钮时触发。 ### ButtonHotChanged ```vb Public Event ButtonHotChanged(ByVal Button As TbrButton, ByVal Hot As Boolean) ``` 按钮热点状态改变时触发。 ### ButtonDropDown ```vb Public Event ButtonDropDown(ByVal Button As TbrButton) ``` 下拉按钮被点击时触发。 ### ButtonMenuClick ```vb Public Event ButtonMenuClick(ByVal ButtonMenu As TbrButtonMenu) ``` 下拉菜单项被点击时触发。 ### ButtonMenuClick2 ```vb Public Event ButtonMenuClick2(ByVal Button As TbrButton, ByVal ID As Long) ``` 下拉菜单项被点击时触发，同时提供所属按钮和菜单项ID。 ### ButtonMouseEnter ```vb Public Event ButtonMouseEnter(ByVal Button As TbrButton) ``` 鼠标进入按钮区域时触发。 ### ButtonMouseLeave ```vb Public Event ButtonMouseLeave(ByVal Button As TbrButton) ``` 鼠标离开按钮区域时触发。 ### MouseDown ```vb Public Event MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` 按下鼠标按钮时触发。 ### MouseMove ```vb Public Event MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` 移动鼠标时触发。 ### MouseUp ```vb Public Event MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` 释放鼠标按钮时触发。 ### MouseEnter ```vb Public Event MouseEnter() ``` 鼠标进入控件区域时触发。 ### MouseLeave ```vb Public Event MouseLeave() ``` 鼠标离开控件区域时触发。 ### OLECompleteDrag ```vb Public Event OLECompleteDrag(Effect As Long) ``` OLE拖放操作完成时触发。 ### OLEDragDrop ```vb Public Event OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single) ``` OLE拖放操作放置时触发。 ### OLEDragOver ```vb Public Event OLEDragOver(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single, State As Integer) ``` OLE拖放操作悬停时触发。 ### OLEGiveFeedback ```vb Public Event OLEGiveFeedback(Effect As Long, DefaultCursors As Boolean) ``` OLE拖放操作给反馈时触发。 ### OLESetData ```vb Public Event OLESetData(Data As DataObject, DataFormat As Integer) ``` OLE拖放操作设置数据时触发。 ### OLEStartDrag ```vb Public Event OLEStartDrag(Data As DataObject, AllowedEffects As Long) ``` OLE拖放操作开始时触发。 ## 子对象 ### TbrButton 类 工具栏按钮对象。 #### TbrButton 属性 #### Index ```vb Public Property Get Index() As Long ``` 按钮在集合中的索引。 #### Key ```vb Public Property Get Key() As String Public Property Let Key(ByVal Value As String) ``` 按钮的唯一标识键。 #### Tag ```vb Public Property Get Tag() As Variant Public Property Let Tag(ByVal Value As Variant) ``` 额外数据。 #### ID ```vb Public Property Get ID() As Long ``` 按钮ID。 #### Caption ```vb Public Property Get Caption() As String Public Property Let Caption(ByVal Value As String) ``` 按钮标题。 #### Style ```vb Public Property Get Style() As TbrButtonStyleConstants Public Property Let Style(ByVal Value As TbrButtonStyleConstants) ``` 按钮样式。 #### Image ```vb Public Property Get Image() As Variant Public Property Let Image(ByVal Value As Variant) ``` 按钮图像。 #### ImageIndex ```vb Public Property Get ImageIndex() As Long ``` 图像索引。 #### ToolTipText ```vb Public Property Get ToolTipText() As String Public Property Let ToolTipText(ByVal Value As String) ``` 工具提示文本。 #### Description ```vb Public Property Get Description() As String Public Property Let Description(ByVal Value As String) ``` 按钮描述。 #### Value ```vb Public Property Get Value() As TbrButtonValueConstants Public Property Let Value(ByVal Value As TbrButtonValueConstants) ``` 按钮值（按下/未按下状态）。 #### Enabled ```vb Public Property Get Enabled() As Boolean Public Property Let Enabled(ByVal Value As Boolean) ``` 是否可用。 #### Visible ```vb Public Property Get Visible() As Boolean Public Property Let Visible(ByVal Value As Boolean) ``` 是否可见。 #### MixedState ```vb Public Property Get MixedState() As Boolean Public Property Let MixedState(ByVal Value As Boolean) ``` 是否处于混合状态（三态复选框）。 #### HighLighted ```vb Public Property Get HighLighted() As Boolean Public Property Let HighLighted(ByVal Value As Boolean) ``` 是否高亮显示。 #### NoImage ```vb Public Property Get NoImage() As Boolean Public Property Let NoImage(ByVal Value As Boolean) ``` 是否不显示图像。 #### NoPrefix ```vb Public Property Get NoPrefix() As Boolean Public Property Let NoPrefix(ByVal Value As Boolean) ``` 是否不处理助记符前缀（&）。 #### AutoSize ```vb Public Property Get AutoSize() As Boolean Public Property Let AutoSize(ByVal Value As Boolean) ``` 是否自动调整大小。 #### CustomWidth ```vb Public Property Get CustomWidth() As Single Public Property Let CustomWidth(ByVal Value As Single) ``` 自定义宽度。 #### ForeColor ```vb Public Property Get ForeColor() As OLE_COLOR Public Property Let ForeColor(ByVal Value As OLE_COLOR) ``` 前景色。 #### Position ```vb Public Property Get Position() As Long Public Property Let Position(ByVal Value As Long) ``` 按钮位置。 #### Hot ```vb Public Property Get Hot() As Boolean ``` 是否处于热点状态。 #### Left ```vb Public Property Get Left() As Single ``` 按钮左边距。 #### Top ```vb Public Property Get Top() As Single ``` 按钮顶边距。 #### Width ```vb Public Property Get Width() As Single ``` 按钮宽度。 #### Height ```vb Public Property Get Height() As Single ``` 按钮高度。 #### ButtonMenus ```vb Public Property Get ButtonMenus() As TbrButtonMenus ``` 下拉菜单集合。 #### hMenu ```vb Public Property Get hMenu() As LongPtr ``` 菜单句柄。 ### TbrButtonMenu 类 按钮下拉菜单项对象。 #### TbrButtonMenu 属性 #### Index ```vb Public Property Get Index() As Long ``` 菜单项索引。 #### Key ```vb Public Property Get Key() As String Public Property Let Key(ByVal Value As String) ``` 唯一标识键。 #### Tag ```vb Public Property Get Tag() As Variant Public Property Let Tag(ByVal Value As Variant) ``` 额外数据。 #### Text ```vb Public Property Get Text() As String Public Property Let Text(ByVal Value As String) ``` 菜单项文本。 #### Enabled ```vb Public Property Get Enabled() As Boolean Public Property Let Enabled(ByVal Value As Boolean) ``` 是否可用。 #### Visible ```vb Public Property Get Visible() As Boolean Public Property Let Visible(ByVal Value As Boolean) ``` 是否可见。 #### Checked ```vb Public Property Get Checked() As Boolean Public Property Let Checked(ByVal Value As Boolean) ``` 是否选中。 #### Separator ```vb Public Property Get Separator() As Boolean Public Property Let Separator(ByVal Value As Boolean) ``` 是否为分隔符。 #### Picture ```vb Public Property Get Picture() As IPictureDisp Public Property Set Picture(ByVal Value As IPictureDisp) ``` 菜单项图标。 #### Parent ```vb Public Property Get Parent() As TbrButton ``` 所属按钮。 ### TbrButtonMenus 类 按钮下拉菜单项集合。 #### TbrButtonMenus 成员 #### NewEnum ```vb Public Function NewEnum() As IUnknown ``` 枚举器（隐藏）。 #### Add ```vb Public Function Add(Optional ByVal Index As Variant, Optional ByVal Key As Variant, Optional ByVal Text As Variant) As TbrButtonMenu ``` 添加菜单项。 #### Item ```vb Public Function Item(ByVal Index As Variant) As TbrButtonMenu ``` 获取菜单项（默认成员）。 #### Exists ```vb Public Function Exists(ByVal Index As Variant) As Boolean ``` 检查菜单项是否存在。 #### Count ```vb Public Property Get Count() As Long ``` 菜单项数量。 #### Clear ```vb Public Sub Clear() ``` 清除所有菜单项。 #### Remove ```vb Public Sub Remove(ByVal Index As Variant) ``` 移除菜单项。 ### TbrButtons 类 工具栏按钮集合。 #### TbrButtons 成员 #### NewEnum ```vb Public Function NewEnum() As IUnknown ``` 枚举器（隐藏）。 #### Add ```vb Public Function Add(Optional ByVal Index As Variant, Optional ByVal Key As Variant, Optional ByVal Caption As Variant, Optional ByVal Style As Variant, Optional ByVal Image As Variant) As TbrButton ``` 添加按钮。 #### Item ```vb Public Function Item(ByVal Index As Variant) As TbrButton ``` 获取按钮（默认成员）。 #### Exists ```vb Public Function Exists(ByVal Index As Variant) As Boolean ``` 检查按钮是否存在。 #### Count ```vb Public Property Get Count() As Long ``` 按钮数量。 #### Clear ```vb Public Sub Clear() ``` 清除所有按钮。 #### Remove ```vb Public Sub Remove(ByVal Index As Variant) ``` 移除按钮。 ### TbrButtonProperties 类 按钮内部属性对象（Friend访问）。 #### FInit ```vb Friend Property Get FInit() As Boolean Friend Property Let FInit(ByVal Value As Boolean) ``` 内部初始化标志。 #### ForeColor ```vb Public Property Get ForeColor() As OLE_COLOR Public Property Let ForeColor(ByVal Value As OLE_COLOR) ``` 前景色。 ## 代码示例 ### 基本用法 ```vb ' 创建工具栏并添加按钮 With ToolBar1.Buttons .Add , "New", "新建", tbrButtonDefault, 1 .Add , "Open", "打开", tbrButtonDefault, 2 .Add , , , tbrButtonSeparator .Add , "Bold", "加粗", tbrButtonCheck, 3 End With ' 为按钮添加下拉菜单 Dim btn As TbrButton Set btn = ToolBar1.Buttons.Add(, "Font", "字体", tbrButtonDropDown, 4) With btn.ButtonMenus .Add , "Arial", "Arial" .Add , "Courier", "Courier New" .Add , , , , , True ' 分隔符 .Add , "Tahoma", "Tahoma" End With ' 处理按钮点击 Private Sub ToolBar1_ButtonClick(ByVal Button As TbrButton) Select Case Button.Key Case "New": MsgBox "新建文件" Case "Open": MsgBox "打开文件" Case "Bold": MsgBox "加粗: " & Button.Value End Select End Sub ' 处理下拉菜单点击 Private Sub ToolBar1_ButtonMenuClick(ByVal ButtonMenu As TbrButtonMenu) MsgBox "选择字体: " & ButtonMenu.Text End Sub ``` --- --- url: /zh/biz/cs-auther/shared.md --- # 共享模块说明 `share/` 目录下的文件同时被客户端和服务端引用，确保双方通信协议、数据格式、公共逻辑的一致性。 *** ## Common.bas — 公共模块 这是整个项目的**核心枢纽模块**，负责通信封装、路由分发、接收处理。 ### 全局变量 ```vb Public Router As New cCollection ' 业务路由容器 Public MiddleWares As New cCollection ' 中间件容器（服务端使用） Public MiddleWaresWhiteList As New cCollection ' 中间件白名单 Public UserToken As String ' 当前客户端的登录凭证 Public IsServer As Boolean ' 标识当前运行环境是否为服务端 ``` *** ### SendTo / SendToAll — 数据发送 ```vb Public Sub SendTo(Inst As cWinsock, ByVal Action As String, Optional Data As Variant, Optional ByVal IsAll As Boolean) ``` **功能**: 构造标准 JSON 数据包并通过 TCP 发送。 **参数**: | 参数 | 说明 | |------|------| | `Inst` | `cWinsock` 实例 | | `Action` | 路由地址，如 `"User/Login"` | | `Data` | 业务数据对象（可选，默认空集合） | | `IsAll` | 是否为广播模式（`True` = 发送给所有客户端） | **构造的 JSON 结构**: ```vb With New cJson .Item("action") = Action .Item("token") = UserToken ' 自动带上当前凭证 .RootItem.Add "data", Data If IsAll Then Inst.SendToAll .Encode(, , True), wcpUtf8 Else Inst.SendData .Encode(, , True), wcpUtf8 End If End With ``` **SendToAll** 是服务端的广播快捷方法： ```vb Public Sub SendToAll(Inst As cWinsock, ByVal Action As String, Optional Data As Variant) SendTo Inst, Action, Data, True End Sub ``` *** ### SendMsgbox / SendToast — 消息推送 ```vb Public Sub SendMsgbox(Inst As cWinsock, ByVal Content As String, Optional ByVal Title As String) ``` 向客户端发送弹窗消息： ```json { "action": "Message/ShowMsgbox", "data": { "Content": "...", "Title": "..." } } ``` ```vb Public Sub SendToast(Inst As cWinsock, ByVal Content As String, Optional ByVal Delay As Long = 3000, Optional ByVal Title As String) ``` 向客户端发送 Toast 通知： ```json { "action": "Message/ShowToast", "data": { "Content": "...", "Delay": 3000, "Title": "..." } } ``` *** ### HandleReciver — 数据接收与路由分发 ```vb Public Sub HandleReciver(Client As VBMANLIB.cWinsock, ByVal bytesTotal As Long) ``` 这是整个 C/S 系统的**核心分发器**，所有 TCP 数据到达后都经过此函数处理。 **处理流程**: ``` 1. 从 Socket 读取字节数据 2. UTF-8 解码为字符串 3. JSON 解析 4. 提取 action 字段，按 "/" 分割为 [类名, 方法名] 5. 提取 data 字段（强制为对象类型） 6. 更新全局 UserToken 7. 【中间件检查】 - 如果是 Message/* → 跳过 - 如果在白名单 → 跳过 - 否则遍历所有中间件执行 Entry - 任一中间件返回 False → 发送错误信息并退出 8. 【路由调用】 - CallByName Router.Item(类名), 方法名, VbMethod, Client, Data 9. 异常捕获 - 业务代码出错 → 向客户端发送 Err.Description ``` **关键代码解析**: ```vb ' 从 Socket 取数据并 UTF-8 解码 Dim Arr() As Byte: Client.GetData Arr, vbArray .Decode VBMAN.ToolsUtf8.Decode(Arr) ' 解析路由 Dim Action As Variant: Action = Split(.Root("action"), "/") ' data 必须是对象类型 Dim Data As New cJson: Data.Decode .Root("data") ' 中间件链式检查 For i = 1 To MiddleWares.Count Succ = MiddleWares(i).Entry(Client, .Self, LastError) If Succ = False Then Common.SendMsgbox Client, LastError, "中间件拦截" Exit Sub End If Next ' 动态调用业务方法 CallByName Router.Item(Action(0)), Action(1), VbMethod, Client, Data ``` *** ### Password — 统一密码加密 ```vb Public Function Password(ByVal Pwd As String) As String Password = VBMAN.Password.Create(Pwd, "") End Function ``` 客户端发送密码前、服务端验证密码前，都通过此函数进行哈希处理，确保密码不以明文传输和存储。 > 可通过第二个参数传入盐值，增强安全性。 *** ## cFileClient.cls / cFileServer.cls — 文件传输类 位于 `share/` 目录的文件传输核心类，为客户端和服务端提供**分片文件传输**能力。 > **详细文档**: 参见 [filetransfer.md](./filetransfer.md) ### 架构特点 ``` ┌─────────────────┐ TCP:801 ┌─────────────────┐ │ cFileClient │ ◄────────────────────► │ cFileServer │ │ (客户端) │ 独立文件传输通道 │ (服务端) │ └─────────────────┘ └─────────────────┘ ``` * **独立通道**: 文件传输使用独立的 TCP 连接（默认端口 801），与主消息通道分离 * **分片传输**: 大文件自动分片（默认 32KB/片），支持进度监控 * **双向传输**: 客户端可上传，服务端可主动下发 * **自动归档**: 服务端通过 `bFileManage` 自动将接收的文件按用户/年月分类存储 ### cFileClient 核心方法 ```vb ' 连接到文件服务器 Public Sub StartConnectTo(ByVal Server As String, Optional ByVal Port As Long = 803) ' 发送文件到服务端 Public Function SendToServer(ByVal FileName As String) As Boolean ' 事件：发送进度 Event OnSending(ByVal FileName As String, ByVal CurrentChunk As Long, ByVal TotalChunks As Long, ByVal Percent As Long) ' 事件：发送完成 Event OnSendFinish(ByVal FileName As String) ``` ### cFileServer 核心方法 ```vb ' 启动文件服务 Public Sub StartMe(Optional Port As Long = 801, Optional IP As String = "0.0.0.0") ' 发送文件给指定用户 Public Function SendToClient(ByVal User As String, ByVal FileName As String) As Boolean ' 事件：客户端上传进度 Event OnClientSending(ByVal User As String, ByVal FileName As String, ByVal CurrentChunk As Long, ByVal TotalChunks As Long, ByVal Percent As Long) ' 事件：客户端上传完成 Event OnClientSendFinish(ByVal User As String, ByVal FileName As String, ByVal FilePath As String) ``` *** ## cMessage.cls — 消息处理类 这是一个两端共用的**消息显示适配器**，根据运行环境自动选择不同的消息展示方式。 ### ShowMsgbox ```vb Public Sub ShowMsgbox(Inst As cWinsock, Data As cJson) If Common.IsServer = True Then ' 服务端避免使用 MsgBox 阻塞，改用 Toast VBMAN.Toast.Show Data("Content"), 60000, Data("Title") Exit Sub End If MsgBox Data("Content"), , Data("Title") End Sub ``` | 环境 | 行为 | |------|------| | 客户端 | 调用系统 `MsgBox` 弹窗 | | 服务端 | 使用 `VBMAN.Toast` 显示非阻塞通知（60秒停留） | ### ShowToast ```vb Public Sub ShowToast(Inst As cWinsock, Data As cJson) VBMAN.Toast.Show Data("Content"), Data("Delay"), Data("Title") End Sub ``` 两端统一使用 VBMAN 的 Toast 组件显示轻量通知。 *** ## 共享模块的设计意义 1. **协议一致性**: 客户端和服务端使用完全相同的 `SendTo` 和 `HandleReciver`，确保 JSON 结构一致 2. **代码复用**: `cMessage` 避免了两端分别实现消息显示逻辑 3. **维护便利**: 修改通信协议只需改 `Common.bas` 一处 4. **扩展性**: 新增共享工具类只需放入 `share/` 目录，在两端 `.vbp` 中引用即可 --- --- url: /zh/emoji/0A80-0AFF.md --- # 古吉拉特文 (Gujarati) 本页面展示了Unicode字符集中，位于U+0A80到U+0AFF范围的古吉拉特文字符。古吉拉特文是印度古吉拉特邦的官方文字，用于书写古吉拉特语。 | 字符 | Unicode | VB函数值 | 名称 | |:---:|:---:|:---:|:---| | ઁ | U+0A81 | ChrW(\&H0A81) | 古吉拉特文标记CANDRABINDU | | ં | U+0A82 | ChrW(\&H0A82) | 古吉拉特文标记ANUSVARA | | ઃ | U+0A83 | ChrW(\&H0A83) | 古吉拉特文标记VISARGA | | અ | U+0A85 | ChrW(\&H0A85) | 古吉拉特文字母A | | આ | U+0A86 | ChrW(\&H0A86) | 古吉拉特文字母AA | | ઇ | U+0A87 | ChrW(\&H0A87) | 古吉拉特文字母I | | ઈ | U+0A88 | ChrW(\&H0A88) | 古吉拉特文字母II | | ઉ | U+0A89 | ChrW(\&H0A89) | 古吉拉特文字母U | | ઊ | U+0A8A | ChrW(\&H0A8A) | 古吉拉特文字母UU | | ઋ | U+0A8B | ChrW(\&H0A8B) | 古吉拉特文字母VOCALIC R | --- --- url: /zh/emoji/2440-245F.md --- # 光学识别符 (U+2440 - U+245F) 本节包含用于光学字符识别(OCR)的专用符号。 | 字符 | Unicode | VB函数值 | 名称 | |:---:|:---:|:---:|:---| | ⑀ | U+2440 | ChrW(\&H2440) | OCR 连字符 | | ⑁ | U+2441 | ChrW(\&H2441) | OCR 叉号 | | ⑂ | U+2442 | ChrW(\&H2442) | OCR 划线 | | ⑃ | U+2443 | ChrW(\&H2443) | OCR 圈号 | | ⑄ | U+2444 | ChrW(\&H2444) | OCR 钩号 | | ⑅ | U+2445 | ChrW(\&H2445) | OCR 双叉号 | | ⑆ | U+2446 | ChrW(\&H2446) | OCR 分支符号 | | ⑇ | U+2447 | ChrW(\&H2447) | OCR 编号符号 | | ⑈ | U+2448 | ChrW(\&H2448) | OCR 手写字符 | | ⑉ | U+2449 | ChrW(\&H2449) | OCR 双线号 | | ⑊ | U+244A | ChrW(\&H244A) | OCR 双圈号 | --- --- url: /zh/emoji/0250-02AF.md --- # 国际音标扩展 本文档包含了Unicode基本多文种平面中的国际音标扩展字符，范围为U+0250至U+02AF。这些字符主要用于语音学记号，是国际音标字母表（IPA）的补充部分。 | 字符 | Unicode | VB函数值 | 名称 | |:---:|:---:|:---:|:---| | ɐ | U+0250 | ChrW(\&H0250) | 小写字母转向a | | ɑ | U+0251 | ChrW(\&H0251) | 小写字母alpha | | ɒ | U+0252 | ChrW(\&H0252) | 小写字母转向alpha | | ɓ | U+0253 | ChrW(\&H0253) | 小写字母b带钩 | | ɔ | U+0254 | ChrW(\&H0254) | 小写字母开放o | | ɕ | U+0255 | ChrW(\&H0255) | 小写字母c带卷舌 | | ɖ | U+0256 | ChrW(\&H0256) | 小写字母d带尾 | | ɗ | U+0257 | ChrW(\&H0257) | 小写字母d带钩 | | ɘ | U+0258 | ChrW(\&H0258) | 小写字母反向e | | ə | U+0259 | ChrW(\&H0259) | 小写字母schwa | | ɚ | U+025A | ChrW(\&H025A) | 小写字母schwa带钩 | | ɛ | U+025B | ChrW(\&H025B) | 小写字母开放e | | ɜ | U+025C | ChrW(\&H025C) | 小写字母反向开放e | | ɝ | U+025D | ChrW(\&H025D) | 小写字母反向开放e带钩 | | ɞ | U+025E | ChrW(\&H025E) | 小写字母闭合反向开放e | | ɟ | U+025F | ChrW(\&H025F) | 小写字母无点j | | ɠ | U+0260 | ChrW(\&H0260) | 小写字母g带钩 | | ɡ | U+0261 | ChrW(\&H0261) | 小写字母脚本g | | ɢ | U+0262 | ChrW(\&H0262) | 小写字母小型大写G | | ɣ | U+0263 | ChrW(\&H0263) | 小写字母gamma | | ɤ | U+0264 | ChrW(\&H0264) | 小写字母ram's horn | | ɥ | U+0265 | ChrW(\&H0265) | 小写字母转向h | | ɦ | U+0266 | ChrW(\&H0266) | 小写字母h带钩 | | ɧ | U+0267 | ChrW(\&H0267) | 小写字母衣钩 | | ɨ | U+0268 | ChrW(\&H0268) | 小写字母i带笔划 | | ɩ | U+0269 | ChrW(\&H0269) | 小写字母iota | | ɪ | U+026A | ChrW(\&H026A) | 小写字母小型大写I | | ɫ | U+026B | ChrW(\&H026B) | 小写字母l带尾 | | ɬ | U+026C | ChrW(\&H026C) | 小写字母belt-l | | ɭ | U+026D | ChrW(\&H026D) | 小写字母l带卷舌 | | ɮ | U+026E | ChrW(\&H026E) | 小写字母lezh | | ɯ | U+026F | ChrW(\&H026F) | 小写字母转向m | | ɰ | U+0270 | ChrW(\&H0270) | 小写字母转向m带长腿 | | ɱ | U+0271 | ChrW(\&H0271) | 小写字母m带钩 | | ɲ | U+0272 | ChrW(\&H0272) | 小写字母n带左钩 | | ɳ | U+0273 | ChrW(\&H0273) | 小写字母n带卷舌 | | ɴ | U+0274 | ChrW(\&H0274) | 小写字母小型大写N | | ɵ | U+0275 | ChrW(\&H0275) | 小写字母禁止o | | ɶ | U+0276 | ChrW(\&H0276) | 小写字母小型大写OE | | ɷ | U+0277 | ChrW(\&H0277) | 小写字母omega | | ɸ | U+0278 | ChrW(\&H0278) | 小写字母phi | | ɹ | U+0279 | ChrW(\&H0279) | 小写字母转向r | | ɺ | U+027A | ChrW(\&H027A) | 小写字母转向r带长腿 | | ɻ | U+027B | ChrW(\&H027B) | 小写字母转向r带钩 | | ɼ | U+027C | ChrW(\&H027C) | 小写字母r带长腿 | | ɽ | U+027D | ChrW(\&H027D) | 小写字母r带尾 | | ɾ | U+027E | ChrW(\&H027E) | 小写字母r带鱼钩 | | ɿ | U+027F | ChrW(\&H027F) | 小写字母反向r带鱼钩 | | ʀ | U+0280 | ChrW(\&H0280) | 小写字母小型大写R | | ʁ | U+0281 | ChrW(\&H0281) | 小写字母小型大写倒置R | | ʂ | U+0282 | ChrW(\&H0282) | 小写字母s带钩 | | ʃ | U+0283 | ChrW(\&H0283) | 小写字母esh | | ʄ | U+0284 | ChrW(\&H0284) | 小写字母无点j带笔划 | | ʅ | U+0285 | ChrW(\&H0285) | 小写字母方框l | | ʆ | U+0286 | ChrW(\&H0286) | 小写字母esh带卷舌 | | ʇ | U+0287 | ChrW(\&H0287) | 小写字母转向t | | ʈ | U+0288 | ChrW(\&H0288) | 小写字母t带卷舌 | | ʉ | U+0289 | ChrW(\&H0289) | 小写字母u带横线 | | ʊ | U+028A | ChrW(\&H028A) | 小写字母upsilon | | ʋ | U+028B | ChrW(\&H028B) | 小写字母v带钩 | | ʌ | U+028C | ChrW(\&H028C) | 小写字母转向v | | ʍ | U+028D | ChrW(\&H028D) | 小写字母转向w | | ʎ | U+028E | ChrW(\&H028E) | 小写字母转向y | | ʏ | U+028F | ChrW(\&H028F) | 小写字母小型大写Y | | ʐ | U+0290 | ChrW(\&H0290) | 小写字母z带卷舌 | | ʑ | U+0291 | ChrW(\&H0291) | 小写字母z带卷舌和钩 | | ʒ | U+0292 | ChrW(\&H0292) | 小写字母ezh | | ʓ | U+0293 | ChrW(\&H0293) | 小写字母ezh带卷舌 | | ʔ | U+0294 | ChrW(\&H0294) | 小写字母声门塞音 | | ʕ | U+0295 | ChrW(\&H0295) | 小写字母咽化符号 | | ʖ | U+0296 | ChrW(\&H0296) | 小写字母倒置声门塞音 | | ʗ | U+0297 | ChrW(\&H0297) | 小写字母伸舌音符 | | ʘ | U+0298 | ChrW(\&H0298) | 小写字母双唇咔嗒音 | | ʙ | U+0299 | ChrW(\&H0299) | 小写字母小型大写B | | ʚ | U+029A | ChrW(\&H029A) | 小写字母闭合开放e | | ʛ | U+029B | ChrW(\&H029B) | 小写字母小型大写G带钩 | | ʜ | U+029C | ChrW(\&H029C) | 小写字母小型大写H | | ʝ | U+029D | ChrW(\&H029D) | 小写字母j带交叉尾 | | ʞ | U+029E | ChrW(\&H029E) | 小写字母转向k | | ʟ | U+029F | ChrW(\&H029F) | 小写字母小型大写L | | ʠ | U+02A0 | ChrW(\&H02A0) | 小写字母q带钩 | | ʡ | U+02A1 | ChrW(\&H02A1) | 小写字母声门塞音带笔划 | | ʢ | U+02A2 | ChrW(\&H02A2) | 小写字母反向声门塞音带笔划 | | ʣ | U+02A3 | ChrW(\&H02A3) | 小写字母dz连字 | | ʤ | U+02A4 | ChrW(\&H02A4) | 小写字母dezh连字 | | ʥ | U+02A5 | ChrW(\&H02A5) | 小写字母dz连字带卷舌 | | ʦ | U+02A6 | ChrW(\&H02A6) | 小写字母ts连字 | | ʧ | U+02A7 | ChrW(\&H02A7) | 小写字母tesh连字 | | ʨ | U+02A8 | ChrW(\&H02A8) | 小写字母tc连字带卷舌 | | ʩ | U+02A9 | ChrW(\&H02A9) | 小写字母feng连字 | | ʪ | U+02AA | ChrW(\&H02AA) | 小写字母ls连字 | | ʫ | U+02AB | ChrW(\&H02AB) | 小写字母lz连字 | | ʬ | U+02AC | ChrW(\&H02AC) | 小写字母双击音 | | ʭ | U+02AD | ChrW(\&H02AD) | 小写字母双击音lateral | | ʮ | U+02AE | ChrW(\&H02AE) | 小写字母h带下突 | | ʯ | U+02AF | ChrW(\&H02AF) | 小写字母转向h带下突 | --- --- url: /zh/packages/vbccr/ranges/slider.md description: 滑块控件（Slider） - VBCCR 开发手册，基于源码的完整 API 参考 --- # 滑块控件（Slider） 提供可自定义的滑块控件，支持水平/垂直方向、刻度样式、选择范围、自绘和OLE拖放。 ## 枚举 ### SldOrientationConstants 控件方向常量。 | 常量 | 值 | 说明 | |------|-----|------| | SldOrientationHorizontal | 0 | 水平方向 | | SldOrientationVertical | 1 | 垂直方向 | ### SldTipSideConstants 提示文本位置常量。 | 常量 | 值 | 说明 | |------|-----|------| | SldTipSideAboveLeft | 0 | 提示显示在上方/左侧 | | SldTipSideBelowRight | 1 | 提示显示在下方/右侧 | ### SldTickStyleConstants 刻度样式常量。 | 常量 | 值 | 说明 | |------|-----|------| | SldTickStyleBottomRight | 0 | 底部/右侧刻度 | | SldTickStyleTopLeft | 1 | 顶部/左侧刻度 | | SldTickStyleBoth | 2 | 两侧刻度 | | SldTickStyleNone | 3 | 无刻度 | ### SldDrawModeConstants 绘制模式常量。 | 常量 | 值 | 说明 | |------|-----|------| | SldDrawModeNormal | 0 | 正常绘制 | | SldDrawModeOwnerDraw | 1 | 自绘模式 | ### SldOwnerDrawItemConstants 自绘项常量。 | 常量 | 值 | 说明 | |------|-----|------| | SldOwnerDrawItemTics | 1 | 刻度线 | | SldOwnerDrawItemThumb | 2 | 滑块 | | SldOwnerDrawItemChannel | 3 | 通道 | ## 属性 ### Name ```vb Public Property Get Name() As String ``` 返回在代码中标识对象的名称。 ### Tag ```vb Public Property Get Tag() As String Public Property Let Tag(ByVal Value As String) ``` 存储程序所需的额外数据。 ### Parent ```vb Public Property Get Parent() As Object ``` 返回对象所在的对象。 ### Container ```vb Public Property Get Container() As Object Public Property Set Container(ByVal Value As Object) ``` 返回/设置对象的容器。 ### Left ```vb Public Property Get Left() As Single Public Property Let Left(ByVal Value As Single) ``` 返回/设置对象与其容器左边缘的距离。 ### Top ```vb Public Property Get Top() As Single Public Property Let Top(ByVal Value As Single) ``` 返回/设置对象与其容器顶边缘的距离。 ### Width ```vb Public Property Get Width() As Single Public Property Let Width(ByVal Value As Single) ``` 返回/设置对象的宽度。 ### Height ```vb Public Property Get Height() As Single Public Property Let Height(ByVal Value As Single) ``` 返回/设置对象的高度。 ### Visible ```vb Public Property Get Visible() As Boolean Public Property Let Visible(ByVal Value As Boolean) ``` 返回/设置对象是否可见。 ### ToolTipText ```vb Public Property Get ToolTipText() As String Public Property Let ToolTipText(ByVal Value As String) ``` 返回/设置鼠标悬停时显示的提示文本。 ### HelpContextID ```vb Public Property Get HelpContextID() As Long Public Property Let HelpContextID(ByVal Value As Long) ``` 返回/设置关联的上下文帮助ID。 ### WhatsThisHelpID ```vb Public Property Get WhatsThisHelpID() As Long Public Property Let WhatsThisHelpID(ByVal Value As Long) ``` 返回/设置关联的上下文帮助ID。 ### DragIcon ```vb Public Property Get DragIcon() As IPictureDisp Public Property Let DragIcon(ByVal Value As IPictureDisp) Public Property Set DragIcon(ByVal Value As IPictureDisp) ``` 返回/设置拖放操作中显示的图标。 ### DragMode ```vb Public Property Get DragMode() As Integer Public Property Let DragMode(ByVal Value As Integer) ``` 返回/设置拖动模式。 ### hWnd ```vb Public Property Get hWnd() As LongPtr ``` 返回控件句柄。 ### hWndUserControl ```vb Public Property Get hWndUserControl() As LongPtr ``` 返回UserControl句柄。 ### VisualStyles ```vb Public Property Get VisualStyles() As Boolean Public Property Let VisualStyles(ByVal Value As Boolean) ``` 返回/设置是否启用视觉样式。需要comctl32.dll 6.0或更高版本。 ### BackColor ```vb Public Property Get BackColor() As OLE_COLOR Public Property Let BackColor(ByVal Value As OLE_COLOR) ``` 返回/设置背景色。 ### Enabled ```vb Public Property Get Enabled() As Boolean Public Property Let Enabled(ByVal Value As Boolean) ``` 返回/设置对象是否能响应用户事件。 ### OLEDropMode ```vb Public Property Get OLEDropMode() As OLEDropModeConstants Public Property Let OLEDropMode(ByVal Value As OLEDropModeConstants) ``` 返回/设置对象是否可以作为OLE放置目标。 ### MousePointer ```vb Public Property Get MousePointer() As CCMousePointerConstants Public Property Let MousePointer(ByVal Value As CCMousePointerConstants) ``` 返回/设置鼠标悬停时显示的指针类型。参见通用枚举。 ### MouseIcon ```vb Public Property Get MouseIcon() As IPictureDisp Public Property Let MouseIcon(ByVal Value As IPictureDisp) Public Property Set MouseIcon(ByVal Value As IPictureDisp) ``` 返回/设置自定义鼠标图标。 ### MouseTrack ```vb Public Property Get MouseTrack() As Boolean Public Property Let MouseTrack(ByVal Value As Boolean) ``` 返回/设置是否在鼠标进入或离开控件时触发事件。 ### RightToLeft ```vb Public Property Get RightToLeft() As Boolean Public Property Let RightToLeft(ByVal Value As Boolean) ``` 返回/设置从右到左显示方向。 ### RightToLeftLayout ```vb Public Property Get RightToLeftLayout() As Boolean Public Property Let RightToLeftLayout(ByVal Value As Boolean) ``` 返回/设置从右到左布局。 ### RightToLeftMode ```vb Public Property Get RightToLeftMode() As CCRightToLeftModeConstants Public Property Let RightToLeftMode(ByVal Value As CCRightToLeftModeConstants) ``` 返回/设置从右到左模式。参见通用枚举。 ### Min ```vb Public Property Get Min() As Long Public Property Let Min(ByVal Value As Long) ``` 返回/设置最小值。 ### Max ```vb Public Property Get Max() As Long Public Property Let Max(ByVal Value As Long) ``` 返回/设置最大值。 ### Value ```vb Public Property Get Value() As Long Public Property Let Value(ByVal NewValue As Long) ``` 返回/设置当前值。 ### TickFrequency ```vb Public Property Get TickFrequency() As Long Public Property Let TickFrequency(ByVal Value As Long) ``` 返回/设置刻度频率。 ### Orientation ```vb Public Property Get Orientation() As SldOrientationConstants Public Property Let Orientation(ByVal Value As SldOrientationConstants) ``` 返回/设置控件方向。 ### SmallChange ```vb Public Property Get SmallChange() As Long Public Property Let SmallChange(ByVal Value As Long) ``` 返回/设置按下箭头键时的变化量。 ### LargeChange ```vb Public Property Get LargeChange() As Long Public Property Let LargeChange(ByVal Value As Long) ``` 返回/设置按下PageUp/PageDown或点击通道时的变化量。 ### TickStyle ```vb Public Property Get TickStyle() As SldTickStyleConstants Public Property Let TickStyle(ByVal Value As SldTickStyleConstants) ``` 返回/设置刻度样式。 ### ShowTip ```vb Public Property Get ShowTip() As Boolean Public Property Let ShowTip(ByVal Value As Boolean) ``` 返回/设置是否显示值提示。 ### TipSide ```vb Public Property Get TipSide() As SldTipSideConstants Public Property Let TipSide(ByVal Value As SldTipSideConstants) ``` 返回/设置提示显示位置。 ### SelectRange ```vb Public Property Get SelectRange() As Boolean Public Property Let SelectRange(ByVal Value As Boolean) ``` 返回/设置是否启用选择范围。 ### SelStart ```vb Public Property Get SelStart() As Long Public Property Let SelStart(ByVal Value As Long) ``` 返回/设置选择范围的起始位置。 ### SelLength ```vb Public Property Get SelLength() As Long Public Property Let SelLength(ByVal Value As Long) ``` 返回/设置选择范围的长度。 ### Transparent ```vb Public Property Get Transparent() As Boolean Public Property Let Transparent(ByVal Value As Boolean) ``` 返回/设置控件背景是否透明。 ### HideThumb ```vb Public Property Get HideThumb() As Boolean Public Property Let HideThumb(ByVal Value As Boolean) ``` 返回/设置是否隐藏滑块。 ### Reversed ```vb Public Property Get Reversed() As Boolean Public Property Let Reversed(ByVal Value As Boolean) ``` 返回/设置是否反转滑块方向。 ### DrawMode ```vb Public Property Get DrawMode() As SldDrawModeConstants Public Property Let DrawMode(ByVal Value As SldDrawModeConstants) ``` 返回/设置绘制模式。 ### ThumbLeft ```vb Public Property Get ThumbLeft() As Single ``` 返回滑块左边距。 ### ThumbTop ```vb Public Property Get ThumbTop() As Single ``` 返回滑块顶边距。 ### ThumbWidth ```vb Public Property Get ThumbWidth() As Single ``` 返回滑块宽度。 ### ThumbHeight ```vb Public Property Get ThumbHeight() As Single ``` 返回滑块高度。 ### ChannelLeft ```vb Public Property Get ChannelLeft() As Single ``` 返回通道左边距。 ### ChannelTop ```vb Public Property Get ChannelTop() As Single ``` 返回通道顶边距。 ### ChannelWidth ```vb Public Property Get ChannelWidth() As Single ``` 返回通道宽度。 ### ChannelHeight ```vb Public Property Get ChannelHeight() As Single ``` 返回通道高度。 ## 方法 ### Refresh ```vb Public Sub Refresh() ``` 强制完全重绘对象。 ### ClearSel ```vb Public Sub ClearSel() ``` 清除选择范围。 ### GetNumTicks ```vb Public Function GetNumTicks() As Long ``` 返回刻度数量。 ### GetTickPosition ```vb Public Function GetTickPosition(ByVal Index As Long) As Single ``` 返回指定刻度的位置。 ### OLEDrag ```vb Public Sub OLEDrag() ``` 启动OLE拖放操作。 ### Drag ```vb Public Sub Drag(Optional ByRef Action As Variant) ``` 开始、结束或取消拖动操作。 ### SetFocus ```vb Public Sub SetFocus() ``` 将焦点移至控件。 ### ZOrder ```vb Public Sub ZOrder(Optional ByRef Position As Variant) ``` 设置Z顺序。 ## 事件 ### Click ```vb Public Event Click() ``` 用户单击控件时触发。 ### Scroll ```vb Public Event Scroll() ``` 用户拖动滑块时触发。 ### Change ```vb Public Event Change() ``` 值改变后触发。 ### ContextMenu ```vb Public Event ContextMenu(ByVal X As Single, ByVal Y As Single) ``` 右键点击控件时触发。 ### ModifyTipText ```vb Public Event ModifyTipText(ByRef Text As String) ``` 提示文本即将显示时触发，可修改提示文本。 ### ItemDraw ```vb Public Event ItemDraw(ByVal Item As SldOwnerDrawItemConstants, ByRef Cancel As Boolean, ByVal ItemState As Long, ByVal hDC As Long, ByVal Left As Long, ByVal Top As Long, ByVal Right As Long, ByVal Bottom As Long) ``` 自绘项时触发。Item为自绘项类型，Cancel可取消默认绘制，hDC为设备上下文。 ### PreviewKeyDown ```vb Public Event PreviewKeyDown(ByVal KeyCode As Integer, ByRef IsInputKey As Boolean) ``` 按键前预览。IsInputKey为True表示该键为输入键。 ### PreviewKeyUp ```vb Public Event PreviewKeyUp(ByVal KeyCode As Integer, ByRef IsInputKey As Boolean) ``` 按键释放前预览。 ### KeyDown ```vb Public Event KeyDown(KeyCode As Integer, Shift As Integer) ``` 按下键盘键时触发。 ### KeyUp ```vb Public Event KeyUp(KeyCode As Integer, Shift As Integer) ``` 释放键盘键时触发。 ### KeyPress ```vb Public Event KeyPress(KeyChar As Integer) ``` 按下并释放ANSI键时触发。 ### MouseDown ```vb Public Event MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` 按下鼠标按钮时触发。 ### MouseMove ```vb Public Event MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` 移动鼠标时触发。 ### MouseUp ```vb Public Event MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` 释放鼠标按钮时触发。 ### MouseEnter ```vb Public Event MouseEnter() ``` 鼠标进入控件区域时触发。 ### MouseLeave ```vb Public Event MouseLeave() ``` 鼠标离开控件区域时触发。 ### OLECompleteDrag ```vb Public Event OLECompleteDrag(Effect As Long) ``` OLE拖放操作完成时触发。 ### OLEDragDrop ```vb Public Event OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single) ``` OLE拖放操作放置时触发。 ### OLEDragOver ```vb Public Event OLEDragOver(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single, State As Integer) ``` OLE拖放操作悬停时触发。 ### OLEGiveFeedback ```vb Public Event OLEGiveFeedback(Effect As Long, DefaultCursors As Boolean) ``` OLE拖放操作给反馈时触发。 ### OLESetData ```vb Public Event OLESetData(Data As DataObject, DataFormat As Integer) ``` OLE拖放操作设置数据时触发。 ### OLEStartDrag ```vb Public Event OLEStartDrag(Data As DataObject, AllowedEffects As Long) ``` OLE拖放操作开始时触发。 ## 代码示例 ### 基本用法 ```vb ' 设置滑块控件 With Slider1 .Min = 0 .Max = 100 .Value = 50 .TickFrequency = 10 .SmallChange = 1 .LargeChange = 10 .SelectRange = True .SelStart = 20 .SelLength = 60 End With ' 响应值变化 Private Sub Slider1_Change() Debug.Print "当前值: " & Slider1.Value End Sub ' 自定义提示文本 Private Sub Slider1_ModifyTipText(ByRef Text As String) Text = "进度: " & Slider1.Value & "%" End Sub ``` --- --- url: /zh/emoji/20A0-20CF.md --- # 货币符号 (Currency Symbols) 本页面展示了Unicode字符集中，位于U+20A0到U+20CF范围的货币符号。这些符号代表了世界各地的不同货币。 | 字符 | Unicode | VB函数值 | 名称 | |:---:|:---:|:---:|:---| | ₠ | U+20A0 | ChrW(\&H20A0) | 欧元通用符号 | | ₡ | U+20A1 | ChrW(\&H20A1) | 哥斯达黎加科朗 | | ₢ | U+20A2 | ChrW(\&H20A2) | 克鲁赛罗符号 | | ₣ | U+20A3 | ChrW(\&H20A3) | 法郎符号 | | ₤ | U+20A4 | ChrW(\&H20A4) | 里拉符号 | | ₥ | U+20A5 | ChrW(\&H20A5) | 密尔雷斯符号 | | ₦ | U+20A6 | ChrW(\&H20A6) | 奈拉符号 | | ₧ | U+20A7 | ChrW(\&H20A7) | 比塞塔符号 | | ₨ | U+20A8 | ChrW(\&H20A8) | 卢比符号 | | ₩ | U+20A9 | ChrW(\&H20A9) | 韩元符号 | | ₪ | U+20AA | ChrW(\&H20AA) | 新谢克尔符号 | | ₫ | U+20AB | ChrW(\&H20AB) | 越南盾符号 | | € | U+20AC | ChrW(\&H20AC) | 欧元符号 | | ₭ | U+20AD | ChrW(\&H20AD) | 基普符号 | | ₮ | U+20AE | ChrW(\&H20AE) | 图格里克符号 | | ₯ | U+20AF | ChrW(\&H20AF) | 德拉克马符号 | | ₰ | U+20B0 | ChrW(\&H20B0) | 德国便士符号 | | ₱ | U+20B1 | ChrW(\&H20B1) | 菲律宾比索符号 | | ₲ | U+20B2 | ChrW(\&H20B2) | 巴拉圭瓜拉尼符号 | | ₳ | U+20B3 | ChrW(\&H20B3) | 澳大利亚先令符号 | | ₴ | U+20B4 | ChrW(\&H20B4) | 格里夫纳符号 | | ₵ | U+20B5 | ChrW(\&H20B5) | 塞地符号 | | ₶ | U+20B6 | ChrW(\&H20B6) | 利夫尔符号 | | ₷ | U+20B7 | ChrW(\&H20B7) | 斯佩斯米洛符号 | | ₸ | U+20B8 | ChrW(\&H20B8) | 坚戈符号 | | ₹ | U+20B9 | ChrW(\&H20B9) | 印度卢比符号 | | ₺ | U+20BA | ChrW(\&H20BA) | 土耳其里拉符号 | | ₻ | U+20BB | ChrW(\&H20BB) | 白马地符号 | | ₼ | U+20BC | ChrW(\&H20BC) | 马纳特符号 | | ₽ | U+20BD | ChrW(\&H20BD) | 卢布符号 | --- --- url: /zh/vbman/redis/basic-operations.md --- # 基础命令 ## Auth - 认证 使用密码认证 Redis 服务器： ```vb ' 使用密码认证 If oRedis.Auth("mypassword") Then Debug.Print "认证成功" Else Debug.Print "认证失败: " & oRedis.LastError End If ``` ## SelectDb - 选择数据库 Redis 支持多个数据库（默认为 0-15）： ```vb ' 切换到数据库 1 If oRedis.SelectDb(1) Then Debug.Print "已切换到数据库 1" End If ' 或直接设置属性 oRedis.DbIndex = 2 ' 切换到数据库 2 ``` **示例：多数据库使用** ```vb ' 在数据库 0 中存储用户数据 oRedis.SelectDb 0 oRedis.Set_ "user:1", "张三" oRedis.Set_ "user:2", "李四" ' 在数据库 1 中存储配置数据 oRedis.SelectDb 1 oRedis.Set_ "config:appname", "MyApp" oRedis.Set_ "config:version", "1.0.0" ' 切换回数据库 0 oRedis.SelectDb 0 ``` ## Ping - 测试连接 测试与 Redis 服务器的连接： ```vb Dim sResult As String sResult = oRedis.Ping() Debug.Print sResult ' 输出: PONG ``` **用途：** * 检查连接是否仍然活跃 * 监控服务器响应时间 * 心跳检测 ## Info - 获取服务器信息 ### 获取所有信息 ```vb Dim sInfo As String sInfo = oRedis.Info() Debug.Print sInfo ``` ### 获取特定部分的信息 ```vb ' 获取服务器信息 sInfo = oRedis.Info("server") Debug.Print sInfo ' 获取内存信息 sInfo = oRedis.Info("memory") ' 获取持久化信息 sInfo = oRedis.Info("persistence") ' 获取统计信息 sInfo = oRedis.Info("stats") ' 获取复制信息 sInfo = oRedis.Info("replication") ``` ## FlushDb - 清空当前数据库 清空当前数据库中的所有键： ```vb If oRedis.FlushDb() Then Debug.Print "数据库已清空" Else Debug.Print "清空失败: " & oRedis.LastError End If ``` **警告：此操作不可逆，请谨慎使用！** ## 基础键操作 ### Del - 删除键 ```vb ' 删除单个键 oRedis.Del "name" ' 删除多个键 oRedis.Del "key1", "key2", "key3" ``` ### Exists - 检查键是否存在 ```vb ' 检查单个键 If oRedis.Exists("name") > 0 Then Debug.Print "键存在" End If ' 检查多个键 Dim lCount As Long lCount = oRedis.Exists("key1", "key2", "key3") Debug.Print "存在 " & lCount & " 个键" ``` ### Keys - 查找键 ```vb ' 查找所有键 Dim vKeys As Variant vKeys = oRedis.Keys("*") ' 查找以 "user:" 开头的键 vKeys = oRedis.Keys("user:*") ' 查找以 "session" 结尾的键 vKeys = oRedis.Keys("*session") ' 输出所有键 Dim i As Long If IsArray(vKeys) Then For i = 0 To UBound(vKeys) Debug.Print vKeys(i) Next End If ``` **注意：** `KEYS` 命令在生产环境中应谨慎使用，因为它会扫描整个数据库，可能影响性能。 ## 过期时间管理 ### Expire - 设置过期时间 ```vb ' 设置键的过期时间（秒） oRedis.Expire "name", 300 ' 5分钟后过期 ' 设置会话过期时间为 1 小时 oRedis.Expire "session:123", 3600 ``` ### TTL - 获取剩余生存时间 ```vb Dim lTTL As Long lTTL = oRedis.TTL("name") If lTTL = -1 Then Debug.Print "键永不过期" ElseIf lTTL = -2 Then Debug.Print "键不存在" Else Debug.Print "剩余 " & lTTL & " 秒" End If ``` **TTL 返回值说明：** * `-2`：键不存在 * `-1`：键存在但没有设置过期时间 * `>= 0`：键的剩余生存时间（秒） ## 示例：完整的键管理 ```vb Sub Example_KeyManagement() Dim oRedis As New cRedisClient If Not oRedis.Connect() Then Debug.Print "连接失败: " & oRedis.LastError Exit Sub End If ' 设置键值 oRedis.Set_ "user:1001", "张三" oRedis.Set_ "user:1002", "李四" oRedis.Set_ "config:timeout", "30" ' 设置过期时间 oRedis.Expire "user:1001", 3600 ' 1小时 oRedis.Expire "user:1002", 7200 ' 2小时 ' 查找所有用户键 Dim vKeys As Variant vKeys = oRedis.Keys("user:*") Debug.Print "用户键数量: " & (UBound(vKeys) + 1) ' 检查键是否存在 If oRedis.Exists("user:1001") > 0 Then Debug.Print "用户 1001 存在，剩余时间: " & oRedis.TTL("user:1001") & " 秒" End If ' 清理配置键 oRedis.Del "config:timeout" ' 断开连接 oRedis.DisConnect End Sub ``` --- --- url: /zh/vbman/Toast/technical.md --- # 技术细节 本文档详细说明 cToast 组件的内部实现原理和技术细节。 ## 目录 * [内部架构](#内部架构) * [窗体实现](#窗体实现) * [堆叠算法](#堆叠算法) * [事件机制](#事件机制) * [生命周期管理](#生命周期管理) * [性能优化](#性能优化) *** ## 内部架构 ### 类结构图 ``` cToast (核心管理类) ├── 9个方位集合 (Collection) │ ├── CollCenter (居中) │ ├── CollCenterTop (居上) │ ├── CollCenterBottom (居下) │ ├── CollLeftTop (左上) │ ├── CollLeftBottom (左下) │ ├── CollLeftCenter (左中) │ ├── CollRightTop (右上) │ ├── CollRightBottom (右下) │ └── CollRightCenter (右中) ├── 全局Key集合 │ └── m_AllKeys (所有弹窗的TagName) ├── 配置属性 │ ├── m_Pos (当前位置) │ ├── m_State (当前状态) │ ├── m_Theme (当前主题) │ ├── m_Index (堆叠索引) │ ├── m_Tag (TagName) │ └── m_ManualStack (是否手动堆叠) ├── 两个窗体 │ ├── FToastCenter (居中窗体) │ └── FToastDrawer (侧边窗体) └── 事件 ├── OnToastCountChange (数量变化) └── OnCloseAll (批量关闭) ``` ### 核心成员变量 ```vb ' 配置属性 Private m_Pos As EnumPos ' 当前显示位置 Private m_State As EnumState ' 当前状态主题 Private m_Theme As EnumTheme ' 当前颜色主题 Private m_Index As Long ' 堆叠索引 Private m_Tag As String ' TagName Private m_ManualStack As Boolean ' 是否手动调用InstIndex ' 9个方位集合 Private CollCenter As Collection Private CollCenterTop As Collection Private CollCenterBottom As Collection Private CollLeftTop As Collection Private CollLeftBottom As Collection Private CollLeftCenter As Collection Private CollRightTop As Collection Private CollRightBottom As Collection Private CollRightCenter As Collection ' 全局Key集合 Private m_AllKeys As Collection ``` ### 初始化流程 ```vb Private Sub Class_Initialize() ' 设置默认值 m_Pos = Center m_State = Info m_Theme = Light m_Index = -1 m_Tag = "" m_ManualStack = False ' 初始化所有集合 Set CollCenter = New Collection Set CollCenterTop = New Collection Set CollCenterBottom = New Collection Set CollLeftTop = New Collection Set CollLeftBottom = New Collection Set CollLeftCenter = New Collection Set CollRightTop = New Collection Set CollRightBottom = New Collection Set CollRightCenter = New Collection Set m_AllKeys = New Collection End Sub ``` *** ## 窗体实现 ### 窗体选择逻辑 根据 `m_Pos` 参数自动选择使用哪个窗体： ```vb Public Function Show(...) As cToast If IsCenter(m_Pos) Then ' 使用 FToastCenter Set Inst = New FToastCenter Else ' 使用 FToastDrawer Set Inst = New FToastDrawer End If ' ... End Function ``` **判断函数（mToast.bas）：** ```vb Public Function IsLeft(ByVal p As Long) As Boolean IsLeft = p < 20 End Function Public Function IsCenter(ByVal p As Long) As Boolean IsCenter = p >= 20 And p < 30 End Function Public Function IsRight(ByVal p As Long) As Boolean IsRight = p >= 30 End Function ``` ### FToastCenter（居中窗体） **特点：** * 无边框窗口 * 包含底部颜色条 * 自动宽度计算 * 屏幕居中或垂直堆叠 **核心实现：** ```vb Public Sub ShowMe(ByVal Content As String, Optional ByVal Delay As Long = 3000, Optional ByVal Title As String = "") ' 自动宽度计算 Dim w As Long w = Len(Content) * 240 + 1400 If w < 160 * 15 Then w = 160 * 15 If w > Screen.Width Then w = Screen.Width * 0.9 Me.Width = w ' 设置文本 If Title <> "" Then Title = "[" & Title & "] " Text1.Text = Title & Content ' 设置计时器 Timer1.Interval = Delay If Delay > 0 Then Timer1.Enabled = True ' 计算位置 Dim CenterX As Long, CenterY As Long, YPos As Long CenterX = (Screen.Width - Me.Width) \ 2 \ Screen.TwipsPerPixelX If TopVal > 0 Then YPos = TopVal \ Screen.TwipsPerPixelY Else CenterY = (Screen.Height - Me.Height) \ 2 \ Screen.TwipsPerPixelY YPos = CenterY End If ' 显示窗口（无焦点 + 顶置） SetWindowPos Me.hwnd, HWND_TOPMOST, CenterX, YPos, 0, 0, SWP_NOSIZE Or SWP_NOACTIVATE Or SWP_SHOWWINDOW ' 初始化阴影 Sad.ShowBorders Me.hwnd, False End Sub ``` ### FToastDrawer（侧边窗体） **特点：** * 无边框窗口 * 包含侧边颜色条（左侧或右侧） * 包含标题和内容两个文本框 * 支持左右对齐颜色条 **核心实现：** ```vb Public Sub ShowMe(ByVal Content As String, Optional ByVal Delay As Long = 3000, Optional ByVal Title As String = "提示") ' 设置文本 Text1.Text = Title Text2.Text = Content ' 设置计时器 Timer1.Interval = Delay If Delay > 0 Then Timer1.Enabled = True ' 设置颜色条位置 If IsLeft(PosVal) = True Then Picture1.Align = 4 ' 右对齐 End If If IsRight(PosVal) = True Then Picture1.Align = 3 ' 左对齐 End If ' 计算位置 Dim ShowTop As Long If TopVal = 0 Then ShowTop = (Screen.Height - Me.Height) \ 2 Else ShowTop = TopVal End If Me.Move LeftVal, ShowTop ' 显示窗口 SetWindowPos Me.hwnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE Or SWP_NOACTIVATE Or SWP_SHOWWINDOW ' 初始化阴影 Sad.ShowBorders Me.hwnd, False End Sub ``` ### 无焦点窗口实现 ```vb Private Sub Form_Load() ' 设置无焦点样式 + 禁用窗口 SetWindowLong Me.hwnd, GWL_EXSTYLE, GetWindowLong(Me.hwnd, GWL_EXSTYLE) Or WS_EX_NOACTIVATE SetWindowLong Me.hwnd, GWL_STYLE, GetWindowLong(Me.hwnd, GWL_STYLE) Or WS_DISABLED End Sub ``` **API声明：** ```vb Private Const WS_EX_NOACTIVATE = &H8000000 Private Const WS_DISABLED = &H8000000 Private Const GWL_EXSTYLE = -20 Private Const GWL_STYLE = -16 Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long ``` *** ## 堆叠算法 ### 自动堆叠管理 cToast 通过 `m_ManualStack` 标记判断是否启用自动堆叠： ```vb ' Show 方法中的自动堆叠逻辑 If Not m_ManualStack Then ' 用户没有手动调用InstIndex，且集合已有实例，自动堆叠 If Coll.Count > 0 Then m_Index = Coll.Count End If End If ``` ### 堆叠位置计算 **顶部位置（顺序堆叠）：** ```vb ' i=0 在最上方（y 最小），依次向下 TopVal = 800 + (ItemHeight * i) ``` **底部位置（倒序堆叠）：** ```vb ' i=0 在最底部，依次向上 TopVal = Screen.Height - Me.Height - 800 - (i * ItemHeight) ``` **参数说明：** * `800`：距离屏幕边缘的间距 * `ItemHeight`：每个弹窗的高度 + 200（间距） * `Screen.Height`：屏幕高度 ### 堆叠示意图 **顶部顺序堆叠：** ``` 屏幕顶部 (y=0) ↓ 800 ← 弹窗1 (i=0) ↓ +Height+200 ↓ 800+Height+200*1 ← 弹窗2 (i=1) ↓ +Height+200 ↓ 800+Height+200*2 ← 弹窗3 (i=2) ``` **底部倒序堆叠：** ``` 屏幕底部 (y=Screen.Height) ↑ -800-Height ← 弹窗1 (i=0) ↑ -Height-200 ↑ -800-Height-200*1 ← 弹窗2 (i=1) ↑ -Height-200 ↑ -800-Height-200*2 ← 弹窗3 (i=2) ``` ### 手动堆叠控制 ```vb Public Function InstIndex(ByVal i As Long) As cToast Set InstIndex = Me ' 居中/覆盖位置不支持堆叠 If m_Pos = Center Or m_Pos = LeftCenter Or m_Pos = RightCenter Then Exit Function m_Index = i m_ManualStack = True End Function ``` **使用示例：** ```vb ' 手动指定堆叠位置 Toast.Pos(RightTop).InstIndex(2).Show "第3条", 0 ' 指定在索引2位置 ``` *** ## 事件机制 ### 窗体初始化和回调 **cToast 端：** ```vb Public Function Show(...) As cToast ' 创建实例 If IsCenter(m_Pos) Then Set Inst = New FToastCenter Else Set Inst = New FToastDrawer End If ' 初始化窗体 With Inst .Init Me, TagName ' 传入Parent和TagName .Pos m_Pos .State m_State .Theme m_Theme If m_Index >= 0 Then .InstIndex m_Index .ShowMe Content, Delay, Title End With ' 存入集合 Coll.Add Inst, TagName m_AllKeys.Add TagName, TagName ' 触发数量变化事件 RaiseEvent OnToastCountChange(TagName, False, m_AllKeys.Count) ' 重置状态 ResetState End Function ``` **窗体端（FToastCenter/FToastDrawer）：** ```vb Public Sub Init(ByRef Parent As cToast, ByVal TagName As String) Set m_ParentToast = Parent m_TagName = TagName End Sub ``` ### 窗体销毁回调 **窗体端：** ```vb Private Sub Form_Unload(Cancel As Integer) ' 通知父级 cToast 此窗体正在销毁 If Not m_ParentToast Is Nothing Then If m_TagName <> "" Then m_ParentToast.UnloadToastForm m_TagName End If Set m_ParentToast = Nothing End If Set Sad = Nothing End Sub ``` **cToast 端：** ```vb Friend Sub UnloadToastForm(ByVal TagName As String) ' 遍历所有方位集合查找并移除 Dim Coll As Collection Dim i As Integer For i = 1 To 9 Select Case i Case 1: Set Coll = CollCenter Case 2: Set Coll = CollCenterTop Case 3: Set Coll = CollCenterBottom Case 4: Set Coll = CollLeftTop Case 5: Set Coll = CollLeftBottom Case 6: Set Coll = CollLeftCenter Case 7: Set Coll = CollRightTop Case 8: Set Coll = CollRightBottom Case 9: Set Coll = CollRightCenter End Select ' 尝试移除 Coll.Remove TagName Next i ' 从 Keys 集合中移除 m_AllKeys.Remove TagName ' 触发数量变化事件 RaiseEvent OnToastCountChange(TagName, True, m_AllKeys.Count) End Sub ``` ### 鼠标悬停暂停机制 **窗体端：** ```vb Private Sub Text1_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single) ' 鼠标进入文本框，暂停计时器 If Not m_ParentToast Is Nothing And m_TagName <> "" Then m_ParentToast.PauseToast m_TagName End If End Sub Private Sub Form_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single) ' 检测鼠标是否离开窗体区域 If x < 0 Or y < 0 Or x > Me.ScaleWidth Or y > Me.ScaleHeight Then If Not m_ParentToast Is Nothing And m_TagName <> "" Then m_ParentToast.ResumeToast m_TagName End If End If End Sub ``` **cToast 端：** ```vb Friend Sub PauseToast(ByVal TagName As String) Dim Inst As Object Set Inst = FindInstance(TagName) If Not Inst Is Nothing Then On Error Resume Next Inst.PauseTimer On Error GoTo 0 End If End Sub Friend Sub ResumeToast(ByVal TagName As String) Dim Inst As Object Set Inst = FindInstance(TagName) If Not Inst Is Nothing Then On Error Resume Next Inst.ResumeTimer On Error GoTo 0 End If End Sub Private Function FindInstance(ByVal Name As String) As Object Dim Coll As Collection Dim i As Integer For i = 1 To 9 Select Case i Case 1: Set Coll = CollCenter Case 2: Set Coll = CollCenterTop Case 3: Set Coll = CollCenterBottom Case 4: Set Coll = CollLeftTop Case 5: Set Coll = CollLeftBottom Case 6: Set Coll = CollLeftCenter Case 7: Set Coll = CollRightTop Case 8: Set Coll = CollRightBottom Case 9: Set Coll = CollRightCenter End Select On Error Resume Next Dim Inst As Object Set Inst = Coll(Name) On Error GoTo 0 If Not Inst Is Nothing Then Set FindInstance = Inst Exit Function End If Next i Set FindInstance = Nothing End Function ``` **窗体端的Timer控制：** ```vb Public Sub PauseTimer() Timer1.Enabled = False End Sub Public Sub ResumeTimer() If Timer1.Interval > 0 Then Timer1.Enabled = True End If End Sub ``` *** ## 生命周期管理 ### 弹窗创建流程 ``` 1. 用户调用 cToast.Show() ↓ 2. 检查 TagName 是否重复 ↓ 3. 根据 Pos 选择窗体类型（FToastCenter/FToastDrawer） ↓ 4. 创建窗体实例 ↓ 5. 调用窗体.Init(Me, TagName) 保存父级引用 ↓ 6. 设置窗体属性（Pos, State, Theme, InstIndex） ↓ 7. 调用窗体.ShowMe() 显示窗口 ↓ 8. 将窗体实例存入对应集合（以TagName为Key） ↓ 9. 将TagName存入全局Key集合 ↓ 10. 触发 OnToastCountChange 事件 ↓ 11. 重置 cToast 配置状态（保留Pos） ``` ### 弹窗销毁流程 **正常关闭（Timer到期或手动CloseMe）：** ``` 1. 窗体.Timer1_Timer() 触发或用户调用 CloseMe() ↓ 2. 调用 Unload Me ↓ 3. 触发 Form_Unload ↓ 4. 调用 m_ParentToast.UnloadToastForm(TagName) ↓ 5. cToast 从所有集合中移除该实例 ↓ 6. 从 m_AllKeys 中移除 TagName ↓ 7. 触发 OnToastCountChange 事件 ↓ 8. 释放阴影对象 Sad ↓ 9. 释放父级引用 m_ParentToast ↓ 10. 窗体完全销毁 ``` **批量关闭（CloseAll）：** ``` 1. 用户调用 cToast.CloseAll() ↓ 2. 记录关闭前数量 closedCount = m_AllKeys.Count ↓ 3. 遍历所有9个集合 ↓ 4. 逐个调用窗体的 CloseMe() ↓ 5. 清空所有集合 ↓ 6. 清空 m_AllKeys ↓ 7. 触发一次 OnCloseAll(closedCount) 事件 ↓ 8. 每个窗体的 Form_Unload 也会触发 UnloadToastForm ↓ 9. 但由于集合已清空，不会重复触发 OnToastCountChange ``` ### 状态重置机制 每次 `Show` 调用后会重置部分配置状态： ```vb Private Sub ResetState() ' 保留m_Pos作为下次的默认位置，其他重置 m_State = Info m_Theme = Light m_Index = -1 m_Tag = "" m_ManualStack = False Set m_InstRef = Nothing Set m_ParentToast = Nothing End Sub ``` **设计原因：** * `m_Pos` 保留，方便在同一位置显示多个弹窗 * 其他配置重置，避免影响下一次显示 *** ## 性能优化 ### 集合索引优化 使用 `m_AllKeys` 集合快速获取所有弹窗名称： ```vb Public Property Get ActiveKeys() As Collection Set ActiveKeys = m_AllKeys End Property ``` **优势：** * 避免遍历9个集合 * O(1) 查询复杂度 * 实时反映当前状态 ### 事件触发优化 批量关闭时只触发一次 `OnCloseAll` 事件： ```vb Public Function CloseAll() As Boolean Dim closedCount As Long closedCount = m_AllKeys.Count ' 关闭所有集合 CloseCollection CollCenter CloseCollection CollCenterTop ' ... 其他集合 ' 清空 Keys 集合 Set m_AllKeys = New Collection ' 只触发一次 OnCloseAll 事件 If closedCount > 0 Then RaiseEvent OnCloseAll(closedCount) End If End Function ``` **避免的问题：** * 频繁触发 `OnToastCountChange` 事件 * UI多次刷新 * 性能损耗 ### 窗体资源管理 及时释放窗体资源： ```vb Private Sub Form_Unload(Cancel As Integer) If Not m_ParentToast Is Nothing Then If m_TagName <> "" Then m_ParentToast.UnloadToastForm m_TagName End If Set m_ParentToast = Nothing End If Set Sad = Nothing ' 释放阴影对象 End Sub ``` ### 自动宽度计算 FToastCenter 根据内容自动计算宽度： ```vb Dim w As Long w = Len(Content) * 240 + 1400 If w < 160 * 15 Then w = 160 * 15 If w > Screen.Width Then w = Screen.Width * 0.9 Me.Width = w ``` **优化点：** * 最小宽度：160 \* 15 = 2400 twips * 最大宽度：屏幕宽度的90% * 字符宽度系数：240 twips/字符 *** ## 相关技术 ### 阴影效果 使用 `cShadow` 类实现窗口阴影： ```vb Private Sub Form_Load() Set Sad = New cShadow With Sad .BackColor = vbBlack .BorderRadius = 0 .BorderWidth = 0 .ShadowColor = &H0& .ShadowOffsetX = 0 .ShadowOffsetY = 0 .ShadowSize = 5 End With Sad.ShowBorders Me.hwnd, False End Sub ``` ### API 调用 **SetWindowPos：** ```vb Private 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 Const HWND_TOPMOST = -1 Private Const SWP_NOACTIVATE = &H10 Private Const SWP_NOMOVE = &H2 Private Const SWP_NOSIZE = &H1 Private Const SWP_SHOWWINDOW = &H40 ``` **使用示例：** ```vb SetWindowPos Me.hwnd, HWND_TOPMOST, CenterX, YPos, 0, 0, SWP_NOSIZE Or SWP_NOACTIVATE Or SWP_SHOWWINDOW ``` *** ## 扩展建议 ### 未来可能的扩展 1. **内容更新功能** ```vb Public Function Update(ByVal Name As String, ByVal NewContent As String) As Boolean ' 更新已显示弹窗的内容 End Function ``` 2. **进度条支持** ```vb Public Function Progress(ByVal Name As String, ByVal Value As Long, ByVal Max As Long) As Boolean ' 更新进度条 End Function ``` 3. **自定义图标** ```vb Public Function Icon(ByVal Name As String, ByVal IconPath As String) As cToast ' 设置自定义图标 End Function ``` 4. **动画效果** ```vb Public Enum EnumAnimation None = 0 FadeIn = 1 SlideIn = 2 ScaleIn = 3 End Enum Public Function Animation(ByVal anim As EnumAnimation) As cToast ' 设置动画效果 End Function ``` 5. **位置查询** ```vb Public Function GetPosition(ByVal Name As String) As EnumPos ' 查询指定弹窗的位置 End Function ``` 6. **对于手动关闭（Delay=0）的窗体提供用户可操作的关闭按钮。** --- --- url: /zh/emoji/2190-21FF.md --- # 箭头 (Arrows) 本页面展示了Unicode字符集中，位于U+2190到U+21FF范围的箭头符号。这些符号用于表示各种方向和关系。 | 字符 | Unicode | VB函数值 | 名称 | |:---:|:---:|:---:|:---| | ← | U+2190 | ChrW(\&H2190) | 左箭头 | | ↑ | U+2191 | ChrW(\&H2191) | 上箭头 | | → | U+2192 | ChrW(\&H2192) | 右箭头 | | ↓ | U+2193 | ChrW(\&H2193) | 下箭头 | | ↔ | U+2194 | ChrW(\&H2194) | 左右箭头 | | ↕ | U+2195 | ChrW(\&H2195) | 上下箭头 | | ↖ | U+2196 | ChrW(\&H2196) | 左上箭头 | | ↗ | U+2197 | ChrW(\&H2197) | 右上箭头 | | ↘ | U+2198 | ChrW(\&H2198) | 右下箭头 | | ↙ | U+2199 | ChrW(\&H2199) | 左下箭头 | | ↚ | U+219A | ChrW(\&H219A) | 带斜线的左箭头 | | ↛ | U+219B | ChrW(\&H219B) | 带斜线的右箭头 | | ↜ | U+219C | ChrW(\&H219C) | 波浪形左箭头 | | ↝ | U+219D | ChrW(\&H219D) | 波浪形右箭头 | | ↞ | U+219E | ChrW(\&H219E) | 左双箭头 | | ↟ | U+219F | ChrW(\&H219F) | 上双箭头 | | ↠ | U+21A0 | ChrW(\&H21A0) | 右双箭头 | | ↡ | U+21A1 | ChrW(\&H21A1) | 下双箭头 | | ↢ | U+21A2 | ChrW(\&H21A2) | 左箭头带尾 | | ↣ | U+21A3 | ChrW(\&H21A3) | 右箭头带尾 | | ↤ | U+21A4 | ChrW(\&H21A4) | 左箭头带竖线 | | ↥ | U+21A5 | ChrW(\&H21A5) | 上箭头带横线 | | ↦ | U+21A6 | ChrW(\&H21A6) | 右箭头带竖线 | | ↧ | U+21A7 | ChrW(\&H21A7) | 下箭头带横线 | | ↨ | U+21A8 | ChrW(\&H21A8) | 上下箭头带基线 | | ↩ | U+21A9 | ChrW(\&H21A9) | 左箭头带弯钩 | | ↪ | U+21AA | ChrW(\&H21AA) | 右箭头带弯钩 | | ↫ | U+21AB | ChrW(\&H21AB) | 左箭头带循环 | | ↬ | U+21AC | ChrW(\&H21AC) | 右箭头带循环 | | ↭ | U+21AD | ChrW(\&H21AD) | 左右波浪箭头 | | ↮ | U+21AE | ChrW(\&H21AE) | 带斜线的左右箭头 | | ↯ | U+21AF | ChrW(\&H21AF) | 下之字形箭头 | | ↰ | U+21B0 | ChrW(\&H21B0) | 上箭头带左弯钩 | | ↱ | U+21B1 | ChrW(\&H21B1) | 上箭头带右弯钩 | | ↲ | U+21B2 | ChrW(\&H21B2) | 下箭头带左弯钩 | | ↳ | U+21B3 | ChrW(\&H21B3) | 下箭头带右弯钩 | | ↴ | U+21B4 | ChrW(\&H21B4) | 右箭头带下角 | | ↵ | U+21B5 | ChrW(\&H21B5) | 下箭头带左角 | | ↶ | U+21B6 | ChrW(\&H21B6) | 逆时针箭头上方弧 | | ↷ | U+21B7 | ChrW(\&H21B7) | 顺时针箭头上方弧 | | ↸ | U+21B8 | ChrW(\&H21B8) | 西北箭头到长横线 | | ↹ | U+21B9 | ChrW(\&H21B9) | 左右箭头到竖线 | | ↺ | U+21BA | ChrW(\&H21BA) | 逆时针开放圆圈箭头 | | ↻ | U+21BB | ChrW(\&H21BB) | 顺时针开放圆圈箭头 | | ↼ | U+21BC | ChrW(\&H21BC) | 左半箭头 | | ↽ | U+21BD | ChrW(\&H21BD) | 左半箭头下方 | | ↾ | U+21BE | ChrW(\&H21BE) | 上半箭头 | | ↿ | U+21BF | ChrW(\&H21BF) | 上半箭头右方 | | ⇀ | U+21C0 | ChrW(\&H21C0) | 右半箭头 | | ⇁ | U+21C1 | ChrW(\&H21C1) | 右半箭头下方 | | ⇂ | U+21C2 | ChrW(\&H21C2) | 下半箭头 | | ⇃ | U+21C3 | ChrW(\&H21C3) | 下半箭头右方 | | ⇄ | U+21C4 | ChrW(\&H21C4) | 右箭头上方左箭头 | | ⇅ | U+21C5 | ChrW(\&H21C5) | 上箭头左方下箭头 | | ⇆ | U+21C6 | ChrW(\&H21C6) | 左箭头上方右箭头 | | ⇇ | U+21C7 | ChrW(\&H21C7) | 双左箭头 | | ⇈ | U+21C8 | ChrW(\&H21C8) | 双上箭头 | | ⇉ | U+21C9 | ChrW(\&H21C9) | 双右箭头 | | ⇊ | U+21CA | ChrW(\&H21CA) | 双下箭头 | | ⇋ | U+21CB | ChrW(\&H21CB) | 左弧形箭头上方右弧形箭头 | | ⇌ | U+21CC | ChrW(\&H21CC) | 右弧形箭头上方左弧形箭头 | | ⇍ | U+21CD | ChrW(\&H21CD) | 带斜线的双左箭头 | | ⇎ | U+21CE | ChrW(\&H21CE) | 带斜线的双向箭头 | | ⇏ | U+21CF | ChrW(\&H21CF) | 带斜线的双右箭头 | | ⇐ | U+21D0 | ChrW(\&H21D0) | 双线左箭头 | | ⇑ | U+21D1 | ChrW(\&H21D1) | 双线上箭头 | | ⇒ | U+21D2 | ChrW(\&H21D2) | 双线右箭头 | | ⇓ | U+21D3 | ChrW(\&H21D3) | 双线下箭头 | | ⇔ | U+21D4 | ChrW(\&H21D4) | 双线左右箭头 | | ⇕ | U+21D5 | ChrW(\&H21D5) | 双线上下箭头 | | ⇖ | U+21D6 | ChrW(\&H21D6) | 双线左上箭头 | | ⇗ | U+21D7 | ChrW(\&H21D7) | 双线右上箭头 | | ⇘ | U+21D8 | ChrW(\&H21D8) | 双线右下箭头 | | ⇙ | U+21D9 | ChrW(\&H21D9) | 双线左下箭头 | | ⇚ | U+21DA | ChrW(\&H21DA) | 三线左箭头 | | ⇛ | U+21DB | ChrW(\&H21DB) | 三线右箭头 | | ⇜ | U+21DC | ChrW(\&H21DC) | 左波浪箭头 | | ⇝ | U+21DD | ChrW(\&H21DD) | 右波浪箭头 | | ⇞ | U+21DE | ChrW(\&H21DE) | 上箭头带双横线 | | ⇟ | U+21DF | ChrW(\&H21DF) | 下箭头带双横线 | | ⇠ | U+21E0 | ChrW(\&H21E0) | 虚线左箭头 | | ⇡ | U+21E1 | ChrW(\&H21E1) | 虚线上箭头 | | ⇢ | U+21E2 | ChrW(\&H21E2) | 虚线右箭头 | | ⇣ | U+21E3 | ChrW(\&H21E3) | 虚线下箭头 | | ⇤ | U+21E4 | ChrW(\&H21E4) | 左箭头到竖线 | | ⇥ | U+21E5 | ChrW(\&H21E5) | 右箭头到竖线 | | ⇦ | U+21E6 | ChrW(\&H21E6) | 白色左箭头 | | ⇧ | U+21E7 | ChrW(\&H21E7) | 白色上箭头 | | ⇨ | U+21E8 | ChrW(\&H21E8) | 白色右箭头 | | ⇩ | U+21E9 | ChrW(\&H21E9) | 白色下箭头 | | ⇪ | U+21EA | ChrW(\&H21EA) | 白色上箭头从横线 | | ⇫ | U+21EB | ChrW(\&H21EB) | 白色上箭头在圆圈内 | | ⇬ | U+21EC | ChrW(\&H21EC) | 白色上箭头在圆中带横线 | | ⇭ | U+21ED | ChrW(\&H21ED) | 上箭头带横杠 | | ⇮ | U+21EE | ChrW(\&H21EE) | 上箭头带双横杠 | | ⇯ | U+21EF | ChrW(\&H21EF) | 下箭头带横杠 | | ⇰ | U+21F0 | ChrW(\&H21F0) | 右箭头带小圆圈 | | ⇱ | U+21F1 | ChrW(\&H21F1) | 西北箭头到角 | | ⇲ | U+21F2 | ChrW(\&H21F2) | 东南箭头到角 | | ⇳ | U+21F3 | ChrW(\&H21F3) | 上下白色箭头 | | ⇴ | U+21F4 | ChrW(\&H21F4) | 右箭头带小圈 | | ⇵ | U+21F5 | ChrW(\&H21F5) | 下箭头左方上箭头 | | ⇶ | U+21F6 | ChrW(\&H21F6) | 三个右箭头 | | ⇷ | U+21F7 | ChrW(\&H21F7) | 带垂直笔划的左箭头 | | ⇸ | U+21F8 | ChrW(\&H21F8) | 带垂直笔划的右箭头 | | ⇹ | U+21F9 | ChrW(\&H21F9) | 带垂直笔划的左右箭头 | | ⇺ | U+21FA | ChrW(\&H21FA) | 带双垂直笔划的左箭头 | | ⇻ | U+21FB | ChrW(\&H21FB) | 带双垂直笔划的右箭头 | | ⇼ | U+21FC | ChrW(\&H21FC) | 带双垂直笔划的左右箭头 | | ⇽ | U+21FD | ChrW(\&H21FD) | 开放左箭头 | | ⇾ | U+21FE | ChrW(\&H21FE) | 开放右箭头 | | ⇿ | U+21FF | ChrW(\&H21FF) | 开放左右箭头 | --- --- url: /zh/emoji/0300-036F.md --- # 结合用读音符号 本文档包含了Unicode基本多文种平面中的结合用读音符号，范围为U+0300至U+036F。这些字符是一组用于组合到其他字符上的变音标记，用于表示声调、重音和其他语音特征。 | 字符 | Unicode | VB函数值 | 名称 | |:---:|:---:|:---:|:---| | ̀ | U+0300 | ChrW(\&H0300) | 结合重音符 | | ́ | U+0301 | ChrW(\&H0301) | 结合锐音符 | | ̂ | U+0302 | ChrW(\&H0302) | 结合扬抑符 | | ̃ | U+0303 | ChrW(\&H0303) | 结合波浪符 | | ̄ | U+0304 | ChrW(\&H0304) | 结合长音符 | | ̅ | U+0305 | ChrW(\&H0305) | 结合上横线 | | ̆ | U+0306 | ChrW(\&H0306) | 结合短音符 | | ̇ | U+0307 | ChrW(\&H0307) | 结合点上符 | | ̈ | U+0308 | ChrW(\&H0308) | 结合分音符 | | ̉ | U+0309 | ChrW(\&H0309) | 结合钩上符 | | ̊ | U+030A | ChrW(\&H030A) | 结合圆圈上符 | | ̋ | U+030B | ChrW(\&H030B) | 结合双锐音符 | | ̌ | U+030C | ChrW(\&H030C) | 结合抑音符 | | ̍ | U+030D | ChrW(\&H030D) | 结合纵线上符 | | ̎ | U+030E | ChrW(\&H030E) | 结合双纵线上符 | | ̏ | U+030F | ChrW(\&H030F) | 结合双重音符 | | ̐ | U+0310 | ChrW(\&H0310) | 结合烟囱符 | | ̑ | U+0311 | ChrW(\&H0311) | 结合倒置短音符 | | ̒ | U+0312 | ChrW(\&H0312) | 结合抬起逗号符 | | ̓ | U+0313 | ChrW(\&H0313) | 结合逗号上符 | | ̔ | U+0314 | ChrW(\&H0314) | 结合反逗号上符 | | ̕ | U+0315 | ChrW(\&H0315) | 结合逗号上右符 | | ̖ | U+0316 | ChrW(\&H0316) | 结合重音符下 | | ̗ | U+0317 | ChrW(\&H0317) | 结合锐音符下 | | ̘ | U+0318 | ChrW(\&H0318) | 结合左舌根符 | | ̙ | U+0319 | ChrW(\&H0319) | 结合右舌根符 | | ̚ | U+031A | ChrW(\&H031A) | 结合左角符 | | ̛ | U+031B | ChrW(\&H031B) | 结合角符 | | ̜ | U+031C | ChrW(\&H031C) | 结合左半环下符 | | ̝ | U+031D | ChrW(\&H031D) | 结合升调符 | | ̞ | U+031E | ChrW(\&H031E) | 结合降调符 | | ̟ | U+031F | ChrW(\&H031F) | 结合加号下符 | | ̠ | U+0320 | ChrW(\&H0320) | 结合减号下符 | | ̡ | U+0321 | ChrW(\&H0321) | 结合腭化符 | | ̢ | U+0322 | ChrW(\&H0322) | 结合卷舌符 | | ̣ | U+0323 | ChrW(\&H0323) | 结合点下符 | | ̤ | U+0324 | ChrW(\&H0324) | 结合分音符下 | | ̥ | U+0325 | ChrW(\&H0325) | 结合环下符 | | ̦ | U+0326 | ChrW(\&H0326) | 结合逗号下符 | | ̧ | U+0327 | ChrW(\&H0327) | 结合下加符 | | ̨ | U+0328 | ChrW(\&H0328) | 结合下尾形符 | | ̩ | U+0329 | ChrW(\&H0329) | 结合纵线下符 | | ̪ | U+032A | ChrW(\&H032A) | 结合桥形下符 | | ̫ | U+032B | ChrW(\&H032B) | 结合倒角符 | | ̬ | U+032C | ChrW(\&H032C) | 结合抑音符下 | | ̭ | U+032D | ChrW(\&H032D) | 结合环境符下 | | ̮ | U+032E | ChrW(\&H032E) | 结合短音符下 | | ̯ | U+032F | ChrW(\&H032F) | 结合拱形下符 | | ̰ | U+0330 | ChrW(\&H0330) | 结合波浪符下 | | ̱ | U+0331 | ChrW(\&H0331) | 结合横线下符 | | ̲ | U+0332 | ChrW(\&H0332) | 结合下划线 | | ̳ | U+0333 | ChrW(\&H0333) | 结合双下划线 | | ̴ | U+0334 | ChrW(\&H0334) | 结合波浪线中符 | | ̵ | U+0335 | ChrW(\&H0335) | 结合短横线中符 | | ̶ | U+0336 | ChrW(\&H0336) | 结合长横线中符 | | ̷ | U+0337 | ChrW(\&H0337) | 结合短斜线中符 | | ̸ | U+0338 | ChrW(\&H0338) | 结合长斜线中符 | | ̹ | U+0339 | ChrW(\&H0339) | 结合右半环下符 | | ̺ | U+033A | ChrW(\&H033A) | 结合倒桥形下符 | | ̻ | U+033B | ChrW(\&H033B) | 结合方框下符 | | ̼ | U+033C | ChrW(\&H033C) | 结合波形下符 | | ̽ | U+033D | ChrW(\&H033D) | 结合叉号上符 | | ̾ | U+033E | ChrW(\&H033E) | 结合纵向波浪线上符 | | ̿ | U+033F | ChrW(\&H033F) | 结合双横线上符 | | ̀ | U+0340 | ChrW(\&H0340) | 结合重音符（废弃） | | ́ | U+0341 | ChrW(\&H0341) | 结合锐音符（废弃） | | ͂ | U+0342 | ChrW(\&H0342) | 结合希腊语周音符 | | ̓ | U+0343 | ChrW(\&H0343) | 结合希腊语逗号上符 | | ̈́ | U+0344 | ChrW(\&H0344) | 结合希腊语分音锐音符 | | ͅ | U+0345 | ChrW(\&H0345) | 结合希腊语iota下标 | | ͆ | U+0346 | ChrW(\&H0346) | 结合桥形上符 | | ͇ | U+0347 | ChrW(\&H0347) | 结合等号符下 | | ͈ | U+0348 | ChrW(\&H0348) | 结合双纵线下符 | | ͉ | U+0349 | ChrW(\&H0349) | 结合左角下符 | | ͊ | U+034A | ChrW(\&H034A) | 结合不带点的右角上符 | | ͋ | U+034B | ChrW(\&H034B) | 结合同音符和锐音符 | | ͌ | U+034C | ChrW(\&H034C) | 结合同音符和抑音符 | | ͍ | U+034D | ChrW(\&H034D) | 结合向左箭头下符 | | ͎ | U+034E | ChrW(\&H034E) | 结合向右箭头下符 | | ͏ | U+034F | ChrW(\&H034F) | 组合用图形连接符 | | ͐ | U+0350 | ChrW(\&H0350) | 结合向右箭头上符 | | ͑ | U+0351 | ChrW(\&H0351) | 结合左半环上符 | | ͒ | U+0352 | ChrW(\&H0352) | 结合花形音调符 | | ͓ | U+0353 | ChrW(\&H0353) | 结合叉号下符 | | ͔ | U+0354 | ChrW(\&H0354) | 结合左箭头下符 | | ͕ | U+0355 | ChrW(\&H0355) | 结合右箭头下符 | | ͖ | U+0356 | ChrW(\&H0356) | 结合右弧形箭头上符 | | ͗ | U+0357 | ChrW(\&H0357) | 结合右半环上符 | | ͘ | U+0358 | ChrW(\&H0358) | 结合点上右符 | | ͙ | U+0359 | ChrW(\&H0359) | 结合星号下符 | | ͚ | U+035A | ChrW(\&H035A) | 结合双环上符 | | ͛ | U+035B | ChrW(\&H035B) | 结合齿音符 | | ͜ | U+035C | ChrW(\&H035C) | 结合双短音符 | | ͝ | U+035D | ChrW(\&H035D) | 结合双短音符上符 | | ͞ | U+035E | ChrW(\&H035E) | 结合双短音符上符 | | ͟ | U+035F | ChrW(\&H035F) | 结合双平直音符下 | | ͠ | U+0360 | ChrW(\&H0360) | 结合双波浪符 | | ͡ | U+0361 | ChrW(\&H0361) | 结合双倒短音符 | | ͢ | U+0362 | ChrW(\&H0362) | 结合双箭头下符 | | ͣ | U+0363 | ChrW(\&H0363) | 结合拉丁小写字母a | | ͤ | U+0364 | ChrW(\&H0364) | 结合拉丁小写字母e | | ͥ | U+0365 | ChrW(\&H0365) | 结合拉丁小写字母i | | ͦ | U+0366 | ChrW(\&H0366) | 结合拉丁小写字母o | | ͧ | U+0367 | ChrW(\&H0367) | 结合拉丁小写字母u | | ͨ | U+0368 | ChrW(\&H0368) | 结合拉丁小写字母c | | ͩ | U+0369 | ChrW(\&H0369) | 结合拉丁小写字母d | | ͪ | U+036A | ChrW(\&H036A) | 结合拉丁小写字母h | | ͫ | U+036B | ChrW(\&H036B) | 结合拉丁小写字母m | | ͬ | U+036C | ChrW(\&H036C) | 结合拉丁小写字母r | | ͭ | U+036D | ChrW(\&H036D) | 结合拉丁小写字母t | | ͮ | U+036E | ChrW(\&H036E) | 结合拉丁小写字母v | | ͯ | U+036F | ChrW(\&H036F) | 结合拉丁小写字母x | --- --- url: /zh/packages/vbccr/ranges/progressbar.md description: 进度条控件（ProgressBar） - VBCCR 开发手册，基于源码的完整 API 参考 --- # 进度条控件（ProgressBar） 封装 msctls\_progress32 系统进度条控件，用于显示操作进度，支持标准、平滑、跑马灯等滚动模式及任务栏进度显示。 ## 枚举 ### PrbOrientationConstants | 常量 | 值 | 说明 | |------|-----|------| | PrbOrientationHorizontal | 0 | 水平方向 | | PrbOrientationVertical | 1 | 垂直方向 | ### PrbScrollingConstants | 常量 | 值 | 说明 | |------|-----|------| | PrbScrollingStandard | 0 | 标准模式 | | PrbScrollingSmooth | 1 | 平滑滚动 | | PrbScrollingMarquee | 2 | 跑马灯模式 | ### PrbStateConstants | 常量 | 值 | 说明 | |------|-----|------| | PrbStateNormal | 1 | 正常状态 | | PrbStateError | 2 | 错误状态（红色） | | PrbStatePaused | 3 | 暂停状态（黄色） | ### CCMousePointerConstants 参见通用枚举。 ## 属性 ### Min ```vb Property Get Min() As Long Property Let Min(ByVal Value As Long) ``` 最小值。 ### Max ```vb Property Get Max() As Long Property Let Max(ByVal Value As Long) ``` 最大值。 ### Value ```vb Property Get Value() As Long Property Let Value(ByVal Value As Long) ``` 当前值。 ### Step ```vb Property Get Step() As Long Property Let Step(ByVal Value As Long) ``` 步进增量。 ### StepAutoReset ```vb Property Get StepAutoReset() As Boolean Property Let StepAutoReset(ByVal Value As Boolean) ``` StepIt 到达最大值时是否自动重置为最小值。 ### MarqueeAnimation ```vb Property Get MarqueeAnimation() As Boolean Property Let MarqueeAnimation(ByVal Value As Boolean) ``` 是否启用跑马灯动画。仅在 Scrolling 为 PrbScrollingMarquee 时有效。 ### MarqueeSpeed ```vb Property Get MarqueeSpeed() As Long Property Let MarqueeSpeed(ByVal Value As Long) ``` 跑马灯动画速度（毫秒）。仅在 Scrolling 为 PrbScrollingMarquee 时有效。 ### Orientation ```vb Property Get Orientation() As PrbOrientationConstants Property Let Orientation(ByVal Value As PrbOrientationConstants) ``` 进度条方向。 ### Scrolling ```vb Property Get Scrolling() As PrbScrollingConstants Property Let Scrolling(ByVal Value As PrbScrollingConstants) ``` 滚动模式。 ### SmoothReverse ```vb Property Get SmoothReverse() As Boolean Property Let SmoothReverse(ByVal Value As Boolean) ``` 是否启用平滑反转效果。需要 comctl32.dll 6.0 或更高版本。 ### BackColor ```vb Property Get BackColor() As OLE_COLOR Property Let BackColor(ByVal Value As OLE_COLOR) ``` 背景颜色。 ### ForeColor ```vb Property Get ForeColor() As OLE_COLOR Property Let ForeColor(ByVal Value As OLE_COLOR) ``` 前景颜色。 ### State ```vb Property Get State() As PrbStateConstants Property Let State(ByVal Value As PrbStateConstants) ``` 进度条状态（正常/错误/暂停）。 ### ShowInTaskBar ```vb Property Get ShowInTaskBar() As Boolean Property Let ShowInTaskBar(ByVal Value As Boolean) ``` 是否在任务栏上显示进度。需要 Windows 7 或更高版本。 ### Text ```vb Property Get Text() As String Property Let Text(ByVal Value As String) ``` 覆盖在进度条上的文本，支持占位符：`{0}` 为当前值，`{1}` 为最小值，`{2}` 为最大值，`{3}` 为百分比值。 ### TextColor ```vb Property Get TextColor() As OLE_COLOR Property Let TextColor(ByVal Value As OLE_COLOR) ``` 覆盖文本的颜色。 ### BorderStyle ```vb Property Get BorderStyle() As Integer Property Let BorderStyle(ByVal Value As Integer) ``` 边框样式（vbBSNone 或 vbFixedSingle）。 ### VisualStyles ```vb Property Get VisualStyles() As Boolean Property Let VisualStyles(ByVal Value As Boolean) ``` 是否启用视觉样式。 ### hWnd ```vb Property Get hWnd() As LongPtr ``` 进度条控件的窗口句柄。 ### hWndUserControl ```vb Property Get hWndUserControl() As LongPtr ``` 用户控件的窗口句柄。 ### Font ```vb Property Get Font() As StdFont Property Let Font(ByVal NewFont As StdFont) Property Set Font(ByVal NewFont As StdFont) ``` 字体。 ### Enabled ```vb Property Get Enabled() As Boolean Property Let Enabled(ByVal Value As Boolean) ``` 是否可用。 ### MousePointer ```vb Property Get MousePointer() As CCMousePointerConstants Property Let MousePointer(ByVal Value As CCMousePointerConstants) ``` 鼠标指针样式。参见通用枚举。 ### MouseIcon ```vb Property Get MouseIcon() As IPictureDisp Property Let MouseIcon(ByVal Value As IPictureDisp) Property Set MouseIcon(ByVal Value As IPictureDisp) ``` 自定义鼠标图标。 ### MouseTrack ```vb Property Get MouseTrack() As Boolean Property Let MouseTrack(ByVal Value As Boolean) ``` 是否启用鼠标进入/离开跟踪。 ### Name ```vb Property Get Name() As String ``` 控件名称。只读。 ### Tag ```vb Property Get Tag() As String Property Let Tag(ByVal Value As String) ``` 自定义数据。 ### Parent ```vb Property Get Parent() As Object ``` 父对象。只读。 ### Container ```vb Property Get Container() As Object Property Set Container(ByVal Value As Object) ``` 容器对象。 ### Left ```vb Property Get Left() As Single Property Let Left(ByVal Value As Single) ``` 左边距。 ### Top ```vb Property Get Top() As Single Property Let Top(ByVal Value As Single) ``` 顶边距。 ### Width ```vb Property Get Width() As Single Property Let Width(ByVal Value As Single) ``` 宽度。 ### Height ```vb Property Get Height() As Single Property Let Height(ByVal Value As Single) ``` 高度。 ### Visible ```vb Property Get Visible() As Boolean Property Let Visible(ByVal Value As Boolean) ``` 是否可见。 ### ToolTipText ```vb Property Get ToolTipText() As String Property Let ToolTipText(ByVal Value As String) ``` 工具提示文本。 ### HelpContextID ```vb Property Get HelpContextID() As Long Property Let HelpContextID(ByVal Value As Long) ``` 帮助上下文 ID。 ### WhatsThisHelpID ```vb Property Get WhatsThisHelpID() As Long Property Let WhatsThisHelpID(ByVal Value As Long) ``` "这是什么"帮助 ID。 ### DragIcon ```vb Property Get DragIcon() As IPictureDisp Property Let DragIcon(ByVal Value As IPictureDisp) Property Set DragIcon(ByVal Value As IPictureDisp) ``` 拖拽图标。 ### DragMode ```vb Property Get DragMode() As Integer Property Let DragMode(ByVal Value As Integer) ``` 拖拽模式。 ## 方法 ### StepIt ```vb Public Sub StepIt() ``` 按 Step 属性指定的增量推进当前位置。 ### Increment ```vb Public Sub Increment(ByVal Delta As Long) ``` 按指定增量推进当前位置。 ### Drag ```vb Public Sub Drag([ByRef Action As Variant]) ``` 开始、结束或取消拖放操作。 ### SetFocus ```vb Public Sub SetFocus() ``` 将焦点移至控件。 ### ZOrder ```vb Public Sub ZOrder([ByRef Position As Variant]) ``` 设置控件的 Z 顺序。 ### OLEDrag ```vb Public Sub OLEDrag() ``` 启动 OLE 拖放操作。 ### Refresh ```vb Public Sub Refresh() ``` 强制重绘控件。 ## 事件 ### Change ```vb Public Event Change() ``` Value 属性值发生改变时触发。 ### Click ```vb Public Event Click() ``` 单击控件时触发。 ### DblClick ```vb Public Event DblClick() ``` 双击控件时触发。 ### MouseDown ```vb Public Event MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` 按下鼠标按钮时触发。 ### MouseUp ```vb Public Event MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` 释放鼠标按钮时触发。 ### MouseMove ```vb Public Event MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` 移动鼠标时触发。 ### MouseEnter ```vb Public Event MouseEnter() ``` 鼠标进入控件时触发。 ### MouseLeave ```vb Public Event MouseLeave() ``` 鼠标离开控件时触发。 ### KeyDown ```vb Public Event KeyDown(KeyCode As Integer, Shift As Integer) ``` 按下按键时触发。 ### KeyUp ```vb Public Event KeyUp(KeyCode As Integer, Shift As Integer) ``` 释放按键时触发。 ### KeyPress ```vb Public Event KeyPress(KeyChar As Integer) ``` 按键字符输入时触发。 ## 代码示例 ```vb ' 标准进度条 ProgressBar1.Min = 0 ProgressBar1.Max = 100 ProgressBar1.Value = 0 ProgressBar1.Step = 10 ProgressBar1.StepIt ' 带文本覆盖的进度条 ProgressBar1.Min = 0 ProgressBar1.Max = 1000 ProgressBar1.Text = "正在处理 {3}%" ProgressBar1.TextColor = vbWhite ' 跑马灯模式（不确定进度） ProgressBar1.Scrolling = PrbScrollingMarquee ProgressBar1.MarqueeAnimation = True ProgressBar1.MarqueeSpeed = 30 ' 任务栏进度显示（Windows 7+） ProgressBar1.ShowInTaskBar = True ProgressBar1.State = PrbStateNormal ``` --- --- url: /zh/vbman/websocket/advanced.md --- # 进阶应用 本指南介绍 WebSocket 类库的高级功能和最佳实践。 *** ## 📡 消息分片传输 ### 概念 WebSocket 允许将大消息分成多个帧发送： ``` 第一帧: FIN=0, OpCode=TEXT/BINARY (消息开始) 后续帧: FIN=0, OpCode=CONTINUATION 最后一帧: FIN=1, OpCode=CONTINUATION ``` ### 服务端处理分片 ```vb Private Sub ProcessDataFrame(ByVal Client As cWebSocketServerClient, _ ByRef Payload() As Byte, _ ByVal OpCode As WsOpCode, _ ByVal IsFinal As Boolean) If IsFinal And Not Client.IsFragmented Then ' 完整的单帧消息 DeliverClientMessage Client, Payload, OpCode Else ' 开始或继续分片消息 Client.IsFragmented = True Client.FragmentOpCode = OpCode Client.FragmentBuffer.Clear On Error Resume Next If UBound(Payload) >= 0 Then Client.FragmentBuffer.Append Payload End If On Error GoTo 0 If IsFinal Then DeliverFragmentedMessage Client End If End If End Sub Private Sub DeliverFragmentedMessage(ByVal Client As cWebSocketServerClient) Dim baData() As Byte baData = Client.GetFragmentedData DeliverClientMessage Client, baData, Client.FragmentOpCode Client.ClearFragmentBuffer End Sub ``` ### 客户端发送分片 ```vb ' 分片发送大消息 Public Sub SendLargeMessage(ByVal sMessage As String) Dim baPayload() As Byte baPayload = StringToUTF8(sMessage) Dim lChunkSize As Long lChunkSize = 4096 ' 每帧 4KB Dim lTotal As Long lTotal = UBound(baPayload) + 1 Dim oFrame As New cWebSocketFrame Dim i As Long Dim lOffset As Long Do While lOffset < lTotal Dim lSize As Long lSize = lChunkSize If lOffset + lSize > lTotal Then lSize = lTotal - lOffset End If Dim baChunk() As Byte ReDim baChunk(lSize - 1) As Byte CopyMemory baChunk(0), baPayload(lOffset), lSize Dim baFrame() As Byte Dim bIsFinal As Boolean bIsFinal = (lOffset + lSize >= lTotal) If lOffset = 0 Then ' 第一帧 baFrame = oFrame.BuildFrame(baChunk, WS_OPCODE_TEXT, True, bIsFinal) Else ' 后续帧 baFrame = oFrame.BuildFrame(baChunk, WS_OPCODE_CONTINUATION, True, bIsFinal) End If m_Socket.SendData baFrame lOffset = lOffset + lSize Loop End Sub ``` *** ## 🔄 自动重连机制 ### 客户端自动重连 ```vb Option Explicit Private WithEvents m_Client As cWebSocketClient Private WithEvents tmrReconnect As Timer Private m_bAutoReconnect As Boolean Private m_sServerURL As String Private m_lMaxRetries As Long Private m_lRetryCount As Long Private Sub Form_Load() Set m_Client = New cWebSocketClient Set tmrReconnect = New Timer m_bAutoReconnect = True m_sServerURL = "ws://127.0.0.1:8080" m_lMaxRetries = 5 m_lRetryCount = 0 tmrReconnect.Interval = 5000 ' 5 秒 ConnectToServer End Sub Private Sub ConnectToServer() If m_Client.State = WS_STATE_CLOSED Then Debug.Print "正在连接... (" & (m_lRetryCount + 1) & "/" & m_lMaxRetries & ")" On Error Resume Next m_Client.Connect m_sServerURL On Error GoTo 0 End If End Sub Private Sub m_Client_OnOpen() Debug.Print "已连接" m_lRetryCount = 0 tmrReconnect.Enabled = False End Sub Private Sub m_Client_OnClose(ByVal Code As WsCloseCode, ByVal Reason As String) Debug.Print "连接关闭: " & Reason If m_bAutoReconnect And Code <> WS_CLOSE_NORMAL Then m_lRetryCount = m_lRetryCount + 1 If m_lRetryCount < m_lMaxRetries Then Debug.Print "5 秒后重连..." tmrReconnect.Enabled = True Else Debug.Print "已达到最大重试次数" MsgBox "无法连接到服务器，请稍后重试", vbExclamation End If End If End Sub Private Sub tmrReconnect_Timer() tmrReconnect.Enabled = False ConnectToServer End Sub ``` *** ## 📡 心跳保活 ### 客户端自动 Ping ```vb Option Explicit Private WithEvents m_Client As cWebSocketClient Private WithEvents tmrPing As Timer Private m_bAutoPing As Boolean Private m_lPingInterval As Long Private Sub Form_Load() Set m_Client = New cWebSocketClient Set tmrPing = New Timer m_bAutoPing = True m_lPingInterval = 30000 ' 30 秒 tmrPing.Interval = m_lPingInterval End Sub Private Sub m_Client_OnOpen() If m_bAutoPing Then tmrPing.Enabled = True Debug.Print "心跳已启用，间隔: " & m_lPingInterval & " ms" End If End Sub Private Sub tmrPing_Timer() If m_Client.State = WS_STATE_OPEN Then ' 发送 Ping（带时间戳用于测量延迟） Dim lTimestamp As Long lTimestamp = GetTickCount() Dim baData(3) As Byte baData(0) = (lTimestamp And &HFF000000) \ &H1000000 baData(1) = (lTimestamp And &HFF0000) \ &H10000 baData(2) = (lTimestamp And &HFF00&) \ &H100& baData(3) = lTimestamp And &HFF& m_Client.SendPing baData Debug.Print "Ping 已发送" End If End Sub Private Sub m_Client_OnPong(Data() As Byte) If UBound(Data) >= 3 Then Dim lSendTime As Long lSendTime = CLng(Data(0)) * 256& ^ 3 + CLng(Data(1)) * 256& ^ 2 + _ CLng(Data(2)) * 256& + CLng(Data(3)) Dim lLatency As Long lLatency = GetTickCount() - lSendTime Debug.Print "Pong 收到，延迟: " & lLatency & " ms" End If End Sub ``` *** ## 🔐 认证与授权 ### 客户端 Token 认证 ```vb Public Sub ConnectWithToken(ByVal ServerURL As String, ByVal Token As String) ' 在 URL 中添加 Token Dim sURL As String sURL = ServerURL & "?token=" & Token m_Client.Connect sURL End Sub ' 或者通过握手后发送 Private Sub m_Client_OnOpen() ' 发送认证信息 Dim sAuth As String sAuth = "{""type"":""auth"", ""token"":""abc123""}" m_Client.SendText sAuth End Sub ``` ### 服务端认证验证 ```vb Private Sub m_Server_OnClientConnect(ByVal ClientID As String, ByVal RemoteAddress As String, ByVal RemotePort As Long) ' 获取 Token（假设在 URL 查询参数中） ' 注意：需要扩展握手逻辑以获取查询参数 Dim sToken As String sToken = GetTokenFromHandshake(m_Server, ClientID) If Not ValidateToken(sToken) Then Debug.Print "认证失败: " & ClientID m_Server.DisconnectClient ClientID, WS_CLOSE_POLICY_VIOLATION, "无效的 Token" Exit Sub End If ' 认证成功 Debug.Print "认证成功: " & ClientID End Sub Private Function ValidateToken(ByVal Token As String) As Boolean ' 验证 Token（示例） If LenB(Token) = 0 Then ValidateToken = False Exit Function End If ' 检查数据库或配置 ' ... ValidateToken = True End Function ``` *** ## 📦 自定义协议 ### 协议定义 ```vb ' 自定义消息类型 Private Const MSG_TYPE_CHAT As Long = 1 Private Const MSG_TYPE_JOIN As Long = 2 Private Const MSG_TYPE_LEAVE As Long = 3 Private Const MSG_TYPE_SYSTEM As Long = 4 ' 消息头结构 Private Type tMessageHeader Type As Long ' 消息类型 Length As Long ' 消息长度 SenderID As String ' 发送者 ID End Type ``` ### 构建自定义消息 ```vb Public Function BuildCustomMessage(ByVal MsgType As Long, ByVal SenderID As String, ByVal Content As String) As Byte() Dim baContent() As Byte baContent = StringToUTF8(Content) ' 构建头 Dim oBuffer As New cByteBuffer oBuffer.AppendByte (MsgType And &HFF000000) \ &H1000000 oBuffer.AppendByte (MsgType And &HFF0000) \ &H10000 oBuffer.AppendByte (MsgType And &HFF00&) \ &H100& oBuffer.AppendByte (MsgType And &HFF&) Dim lLen As Long lLen = UBound(baContent) + 1 oBuffer.AppendByte (lLen And &HFF000000) \ &H1000000 oBuffer.AppendByte (lLen And &HFF0000) \ &H10000 oBuffer.AppendByte (lLen And &HFF00&) \ &H100& oBuffer.AppendByte (lLen And &HFF&) ' 添加 SenderID 长度和内容 Dim baSenderID() As Byte baSenderID = StringToUTF8(SenderID) oBuffer.AppendByte (UBound(baSenderID) + 1) If UBound(baSenderID) >= 0 Then oBuffer.Append baSenderID End If ' 添加内容 If UBound(baContent) >= 0 Then oBuffer.Append baContent End If BuildCustomMessage = oBuffer.ToArray End Function ``` ### 解析自定义消息 ```vb Public Sub ParseCustomMessage(ByVal Data() As Byte) Dim oBuffer As New cByteBuffer oBuffer.Append Data ' 读取类型 Dim lType As Long lType = CLng(oBuffer.PeekByte(0)) * 256& ^ 3 + _ CLng(oBuffer.PeekByte(1)) * 256& ^ 2 + _ CLng(oBuffer.PeekByte(2)) * 256& + _ CLng(oBuffer.PeekByte(3)) oBuffer.Consume 4 ' 读取长度 Dim lLength As Long lLength = CLng(oBuffer.PeekByte(0)) * 256& ^ 3 + _ CLng(oBuffer.PeekByte(1)) * 256& ^ 2 + _ CLng(oBuffer.PeekByte(2)) * 256& + _ CLng(oBuffer.PeekByte(3)) oBuffer.Consume 4 ' 读取 SenderID Dim lSenderLen As Byte lSenderLen = oBuffer.PeekByte(0) oBuffer.Consume 1 Dim baSenderID() As Byte ReDim baSenderID(lSenderLen - 1) As Byte If lSenderLen > 0 Then Dim i As Long For i = 0 To lSenderLen - 1 baSenderID(i) = oBuffer.PeekByte(i) Next i oBuffer.Consume lSenderLen End If Dim sSenderID As String sSenderID = UTF8ToString(baSenderID) ' 读取内容 Dim baContent() As Byte If lLength > 0 Then ReDim baContent(lLength - 1) As Byte For i = 0 To lLength - 1 baContent(i) = oBuffer.PeekByte(i) Next i End If Dim sContent As String sContent = UTF8ToString(baContent) ' 处理消息 Select Case lType Case MSG_TYPE_CHAT HandleChatMessage sSenderID, sContent Case MSG_TYPE_JOIN HandleJoinMessage sSenderID Case MSG_TYPE_LEAVE HandleLeaveMessage sSenderID Case MSG_TYPE_SYSTEM HandleSystemMessage sContent End Select End Sub ``` *** ## 📊 性能优化 ### 1. 批量发送 ```vb ' ❌ 不好：多次调用 SendText For i = 0 To 100 m_Client.SendText "Message " & i Next i ' ✅ 好：拼接后一次发送 Dim sMessages As String For i = 0 To 100 sMessages = sMessages & "Message " & i & vbLf Next i m_Client.SendText sMessages ``` ### 2. 使用事件而非轮询 ```vb ' ✅ 好：使用事件 Private Sub m_Client_OnTextMessage(ByVal Message As String) ProcessMessage Message End Sub ' ❌ 不好：轮询检查 Private Sub Timer1_Timer() If m_Client.State = WS_STATE_OPEN Then ' 轮询数据（不推荐） End If End Sub ``` ### 3. 限制广播频率 ```vb Private WithEvents tmrBroadcast As Timer Private m_sBroadcastQueue As String Private Sub QueueBroadcast(ByVal Message As String) m_sBroadcastQueue = m_sBroadcastQueue & Message & vbLf End Sub Private Sub tmrBroadcast_Timer() If LenB(m_sBroadcastQueue) > 0 Then m_Server.BroadcastText m_sBroadcastQueue m_sBroadcastQueue = "" End If End Sub ``` *** ## 🐛 错误处理最佳实践 ### 统一错误处理 ```vb ' 日志模块 Public Sub LogError(ByVal ModuleName As String, ByVal Procedure As String, ByVal Description As String) Dim sLog As String sLog = "[" & Format$(Now, "yyyy-mm-dd hh:nn:ss") & "] " sLog = sLog & ModuleName & "." & Procedure & ": " & Description Debug.Print sLog ' 写入文件 Dim iFile As Integer iFile = FreeFile Open "error.log" For Append As #iFile Print #iFile, sLog Close #iFile End Sub ' 使用示例 Private Sub m_Client_OnError(ByVal Description As String) LogError "frmClient", "OnError", Description End Sub ``` ### 连接状态检查 ```vb Public Sub SendMessageSafe(ByVal Message As String) If m_Client Is Nothing Then Debug.Print "客户端未初始化" Exit Sub End If Select Case m_Client.State Case WS_STATE_OPEN ' 可以发送 m_Client.SendText Message Case WS_STATE_CONNECTING Debug.Print "正在连接，请稍后" Case WS_STATE_CLOSING Debug.Print "连接正在关闭" Case WS_STATE_CLOSED Debug.Print "连接已关闭" End Select End Sub ``` *** ## 🔍 调试技巧 ### 日志输出 ```vb Private Sub DebugFrame(oFrame As cWebSocketFrame) Debug.Print "=== WebSocket 帧 ===" Debug.Print "FIN: " & oFrame.FIN Debug.Print "OpCode: " & oFrame.OpCode Debug.Print "HasMask: " & oFrame.HasMask Debug.Print "PayloadLength: " & oFrame.PayloadLength Debug.Print "HeaderLength: " & oFrame.HeaderLength Debug.Print "TotalFrameLength: " & oFrame.TotalFrameLength Debug.Print "IsValid: " & oFrame.IsValid Debug.Print "===================" End Sub ``` ### 消息跟踪 ```vb Private Sub LogMessage(ByVal ClientID As String, ByVal Direction As String, ByVal Message As String) Dim sLog As String sLog = Format$(Now, "hh:nn:ss") & " [" & Direction & "] " & ClientID & ": " & Message txtLog.Text = txtLog.Text & sLog & vbCrLf txtLog.SelStart = Len(txtLog.Text) ' 保存到文件 Dim iFile As Integer iFile = FreeFile Open "messages.log" For Append As #iFile Print #iFile, sLog Close #iFile End Sub ' 使用 LogMessage ClientID, "OUT", Message LogMessage ClientID, "IN", Message ``` *** ## 📚 参考资料 * [RFC 6455 - WebSocket Protocol](https://tools.ietf.org/html/rfc6455) * [MDN WebSockets API](https://developer.mozilla.org/zh-CN/docs/Web/API/WebSocket) * [WebSocket 在线测试工具](https://www.piesocket.com/websocket-tester) *** **最后更新**: 2026-01-10 --- --- url: /zh/cases/featured-cases.md description: VBMAN 精选用户案例展示 --- 优秀案例持续征集中，快来提交您的作品吧！ ## 案例 #001：轻量物联网云平台 **作者**：技术宅老白 **核心模块**：cHttpServer **项目简介**： 基于 VBMAN HttpServer 构建的轻量级 IoT 数据存储服务。拼个 URL 就能读写数据，无需 SDK，30秒跑通。支持 ESP32/Arduino/Python/cURL 等多语言调用，读操作全免费。 **技术亮点**： * VBMAN `cHttpServer` 路由系统实现 REST 风格 API * 原生 CORS 支持，前端可直接跨域调用 * JSON 响应格式 + 数据持久化存储 * 多语言客户端全覆盖（JS/ESP32/Python/cURL） **应用场景**： 物联网传感器上云、设备远程控制、智能家居数据中枢、项目原型快速验证 **详情链接**：[查看完整案例](/cases/case-iot-cloud) *** ## 案例 #002：智能工厂设备监控系统 【占位案例，非实际】 **作者**：智能制造团队 **项目简介**： 基于 VBMAN WEB 服务器和 WebSocket 功能，为某汽车零部件工厂开发了设备状态实时监控系统。系统可同时监控50+台生产设备的运行状态，实现故障预警、生产数据统计、远程控制等功能。 **技术亮点**： * VBMAN WebSocket 服务器实现设备实时数据推送 * 支持多客户端同时在线监控 * 集成 Modbus 协议读取 PLC 数据 * VBMAN2 WebView2 实现可视化大屏展示 **应用场景**： 工业4.0智能制造、设备远程运维、生产数据可视化 *** ## 案例 #003：学校图书借阅管理系统 【占位案例，非实际】 **作者**：老张编程 **项目简介**： 使用 VBMAN 为某小学开发了图书借阅管理系统的 Web 版本。系统支持图书入库、借还管理、读者管理、借阅统计等功能，大大提高了图书馆管理效率。 **技术亮点**： * VBMAN WEB 服务器提供 RESTful API * VBMAN JSON 模块处理数据交互 * 支持 Excel 导入导出借阅记录 * 二维码扫描快速借还书 **应用场景**： 学校图书馆、社区图书馆、企业图书角 *** ## 案例 #004：在线考试系统 【占位案例，非实际】 **作者**：教育软件开发者 **项目简介**： 基于 VBMAN 开发的在线考试系统，支持题库管理、试卷生成、在线考试、自动阅卷等功能。已在3所培训机构投入使用，累计服务考生5000+人次。 **技术亮点**： * VBMAN 处理并发考试请求 * 支持多种题型（单选、多选、填空、简答） * VBMAN2 WebView2 实现富文本编辑器 * 防作弊机制（限制切屏、答题计时） **应用场景**： 在线教育、职业培训、企业内训考试 *** *更多优秀案例即将展示，欢迎提交您的作品！* --- --- url: /zh/vbman/httpserver/static-files.md --- # 静态文件服务 ## 简介 HttpServer 内置静态文件服务功能，当配置 `WebRoot` 后，会自动处理静态资源请求，无需编写控制器。 ::: warning 版本变更说明 自 **vbman 1.0.0.419** 起，`WebRoot` 从 `Start()` 方法中独立为链式函数。旧版写法 `Server.Start 8080, "C:\WebRoot"` 不再支持，请改为 `Server.WebRoot("C:\WebRoot").Start 8080`。 ::: ## 快速配置 ```vb Private Sub Form_Load() Set Server = New cHttpServer ' 配置静态文件根目录 Server.WebRoot("C:\WebRoot").Start 8080 Debug.Print "静态文件服务: http://localhost:8080/" End Sub ``` ## 目录结构示例 ``` C:\WebRoot\ ├── index.html # 首页 ├── favicon.ico # 网站图标 ├── css\ │ ├── style.css │ └── theme.css ├── js\ │ ├── app.js │ └── utils.js ├── images\ │ ├── logo.png │ └── banner.jpg └── upload\ └── avatar.png ``` ## 请求映射 | 请求 URL | 映射到文件 | | ------------------ | ---------------------------- | | `/` | `C:\WebRoot\index.html` | | `/css/style.css` | `C:\WebRoot\css\style.css` | | `/js/app.js` | `C:\WebRoot\js\app.js` | | `/images/logo.png` | `C:\WebRoot\images\logo.png` | ## 支持的 MIME 类型 ```vb ' 系统自动识别以下文件类型的 Content-Type ' 文本类型 text/html -> .html, .htm text/css -> .css text/javascript -> .js text/plain -> .txt ' 图片类型 image/png -> .png image/jpeg -> .jpg, .jpeg gif/image -> .gif image/svg+xml -> .svg image/x-icon -> .ico ' 应用类型 application/json -> .json application/xml -> .xml application/pdf -> .pdf ' 字体类型 font/woff2 -> .woff2 font/woff -> .woff ``` ## 默认文档机制 当请求路径对应一个目录时（如访问根路径 `/`），HttpServer 会自动查找默认文档，按优先级逐一尝试： | 优先级 | 默认文档 | | ------ | -------------- | | 1 | `index.html` | | 2 | `index.htm` | | 3 | `default.html` | | 4 | `default.htm` | ### 处理流程 ``` 请求 "/" 或 "/subdir/" │ ▼ 检查 WebRoot + 路径 是否为目录 │ ├─> 是目录 → 遍历默认文档列表 │ ├─> index.html 存在? → 返回文件 ✅ │ ├─> index.htm 存在? → 返回文件 ✅ │ ├─> default.html 存在? → 返回文件 ✅ │ ├─> default.htm 存在? → 返回文件 ✅ │ └─> 都不存在 → 返回 403 "Directory listing not allowed" 🔒 │ └─> 不是目录 → 返回 404 ``` ### 添加自定义默认文档 ```vb Private Sub Form_Load() Set Server = New cHttpServer ' 添加自定义默认文档（如 home.html） Server.AddDefaultDocument "home.html" ' 重复添加会自动忽略，不会重复入列 Server.WebRoot("C:\WebRoot").Start 8080 End Sub ``` 添加后，默认文档查找顺序变为：`index.html → index.htm → default.html → default.htm → home.html` ### 目录重定向 当请求路径对应物理目录但不以 `/` 结尾时，HttpServer 会自动 302 重定向到带 `/` 的路径： ``` 请求 /subdir (对应物理目录) → 302 重定向到 /subdir/ → 再按默认文档机制查找 /subdir/index.html 等 ``` > **注意**：根路径 `/` 不需要重定向，直接进入默认文档查找。 ### 与路由的优先级关系 如果为根路径 `/` 注册了手动路由，路由优先执行，不会进入默认文档查找： ```vb ' 路由优先：根路径由控制器处理 Call Server.Router.Add("/", "Home@Index") ' 此时访问 "/" → 调用 Home.Index，不查找 index.html ``` ## 优先级说明 静态文件优先于路由匹配： ``` 请求 /index.html │ ├──> 检查 C:\WebRoot\index.html 是否存在 │ ├─> 存在 -> 返回静态文件 │ └─> 不存在 -> 进入路由匹配 │ └──> 匹配路由 /index.html ``` ## 混合模式（静态文件 + API） ```vb Private Sub Form_Load() Set Server = New cHttpServer ' ========== 配置路由 ========== ' API 控制器 Call Server.Router.Reg("Api", New cApiController) Call Server.Router.Add("/api/users", "Api@Users", OnlyGet) Call Server.Router.Add("/api/data", "Api@Data", OnlyGet) ' 业务控制器 Call Server.Router.Reg("User", New cUserController) Call Server.Router.Add("/user/login", "User@Login", OnlyPost) ' ========== 启动服务 ========== ' WebRoot 用于静态文件，API 请求会进入路由 Server.WebRoot("C:\WebRoot").Start 8080 Debug.Print "服务启动成功" Debug.Print " 前端: http://localhost:8080/" Debug.Print " API: http://localhost:8080/api/users" End Sub ``` ## 单页应用 (SPA) 支持 对于 React/Vue/Angular 等 SPA，需要配置所有路由都返回 index.html： ```vb ' cSpaController.cls Public Sub Index(ctx As cHttpServerContext) ' 返回 index.html 让前端路由处理 ctx.Response.File "/index.html" End Sub ' 注册路由 Private Sub Form_Load() Set Server = New cHttpServer ' API 路由 Call Server.Router.Reg("Api", New cApiController) Call Server.Router.Add("/api/*", "Api@Handle") ' SPA 路由：所有非 API 请求返回 index.html Call Server.Router.Reg("Spa", New cSpaController) Call Server.Router.Add("/*", "Spa@Index") Server.WebRoot("C:\WebRoot").Start 8080 End Sub ``` ## 文件上传目录 ```vb ' 上传文件保存到静态目录 Public Sub Upload(ctx As cHttpServerContext) ' 保存上传的文件 Dim savePath As String savePath = ctx.Server.WebRoot & "\upload\" & filename Call SaveUploadFile(ctx.Request.RawBodyBin, savePath) ' 返回可访问的 URL Dim result As New Dictionary result("url") = "/upload/" & filename ctx.Response.Json result End Sub ``` ## 缓存控制 ### 内置懒缓存 + ETag + 304 HttpServer 内置了三层缓存机制，自动感知文件更新，无需手动干预： ``` 请求 /css/style.css │ ▼ 1. 计算 ETag（文件修改时间 + 大小，仅FSO元数据，不读内容） │ ├─> 浏览器发送 If-None-Match 且匹配 → 304 Not Modified ✅ │ （零传输，浏览器使用本地缓存） │ ├─> 缓存命中且 ETag 未变 → 内存输出（跳过磁盘 I/O） ✅ │ ├─> 缓存命中但 ETag 变化 → 重新读取 + 更新缓存 🔄 │ └─> 无缓存 → 磁盘读取 + 懒缓存（大小≤上限才加入） 📥 ``` **懒缓存规则**： * 默认不缓存任何文件 * 首次访问时，如果文件大小 ≤ `MaxCacheFileSize`，自动加入内存缓存 * 超出大小上限的文件（如视频、大图片）始终从磁盘读取，但仍享受 ETag/304 协商缓存 * 文件在磁盘上更新后，ETag 自动变化，旧缓存自动失效并重新读取 ### 缓存配置 ```vb Private Sub Form_Load() Set Server = New cHttpServer ' 缓存配置（可在 Start 前或运行中随时修改） Server.MaxCacheFileSize = 1048576 ' 单文件缓存上限：1MB（默认） Server.CacheTTLSeconds = 300 ' 缓存TTL：5分钟（默认） ' 设置为0可禁用内容缓存（仅保留ETag/304协商缓存） Server.MaxCacheFileSize = 0 Server.WebRoot("C:\WebRoot").Start 8080 End Sub ``` | 配置项 | 默认值 | 说明 | | ------------------ | ------------- | ----------------------------------------------------- | | `MaxCacheFileSize` | 1048576 (1MB) | 单文件缓存上限字节，0=禁用内容缓存 | | `CacheTTLSeconds` | 300 (5分钟) | 缓存TTL秒数，过期后检查ETag再决定是否刷新，0=永不过期 | ### 手动刷新缓存 部署新文件后，可手动刷新目录结构缓存和内容缓存： ```vb ' 刷新目录结构缓存（新增/删除文件后调用） ' 不影响内容缓存，内容缓存通过ETag自动感知文件更新 Server.RefreshCache ' 清空所有文件内容缓存（强制重新从磁盘读取） Server.ClearFileCache ``` > **最佳实践**：大多数场景只需 `RefreshCache`，内容缓存会通过 ETag 自动感知文件更新。只有当需要强制释放内存时才用 `ClearFileCache`。 ### 自定义中间件缓存头 ```vb ' cCacheMiddleware.cls Public Sub Entry(ctx As cHttpServerContext) ' 静态文件添加浏览器缓存头 If IsStaticFile(ctx.Request.PathInfo) Then ' 缓存 1 小时 ctx.Response.Header("Cache-Control") = "public, max-age=3600" End If End Sub Private Function IsStaticFile(path As String) As Boolean Dim ext As String ext = LCase(Mid(path, InStrRev(path, "."))) IsStaticFile = (ext = ".css" Or ext = ".js" Or ext = ".png" Or _ ext = ".jpg" Or ext = ".gif" Or ext = ".ico") End Function ``` *** **最后更新**: 2026-06-22 --- --- url: /zh/donate.md --- # 捐赠支持 感谢所有支持本项目的朋友们！您的捐赠将帮助我们持续改进和维护 VB6.Pro 作品。 ## 如何捐赠 如果您觉得 VB6.Pro 对您有帮助，欢迎通过以下方式支持我们的开发工作： ## 捐赠者名单（Aspman专项） 以下是支持本项目（AspMan）的捐赠者名单（按时间先后排序）： | 日期 Date | 捐赠者 Donor | 金额 Amount | 留言 Message | | ---------- | ------------------- | ----------- | ------------ | | 2024-xx-xx | PopAsp 作者（风歌） | ￥100 | 支持 | | 2024-xx-xx | PopAsp 群友（功陈） | ￥100 | 支持 | | 日期 Date | 捐赠者 Donor | 金额 Amount | 留言 Message | | ---------- | ------------------- | ------------- | ---------------------- | | 2025-08-09 | 天天Asp站长（大仙） | ￥100\[`已退`] | 造福大家 | | 2025-08-10 | A00陈陈（微信群友） | ￥200\[`已退`] | 不管能不能用我都支持你 | ## 捐赠者名单（站内合并） 以下是支持本站的捐赠者名单（按时间先后排序）： | 日期 Date | 捐赠者 Donor | 金额 Amount | 留言 Message | | ---------- | ---------------------------- | ----------- | -------------------------------------------------------------------------------------------------- | | 2024-06-20 | VbsGirl（土妹） | ￥ 200 | vbsgirl 娟 200 元 | | 2024-06-21 | 匿名 VB 群友 | ￥ 10 | 暂无 | | 2024-06-27 | 赞助商 码农库 | ￥ 200 | 码农库 MaNongKu.com 捐 200 元 | | 2024-06-28 | VbsGirl（土妹） | ￥ 100 | 过 500 了，怀念 VB 的人务必支持一下，人生有情，情怀无价！ | | 2024-08-06 | twinbasic 群友：TONMIN | ￥ 100 | 支持一下 | | 2024-09-26 | ASP 群友：天子 | ￥ 10 | (马鞍山市的徐磊)支持一下 | | 2024-09-29 | 好友：郑春来 | ￥ 200 | 捐助￥ 200 开发 VBMAN 服务器 demo | | 2024-09-29 | VB 群友：Kimi | ￥ 500 | 捐助开发 JSON 服务器 demo | | 2024-10-11 | VB 群友：流云 | ￥ 100 | 你们这种精神需要鼓励。 | | 2024-10-16 | VB 群友: Edward | ￥ 10 | 暂无 | | 2024-10-19 | VB 群友: 静咫流云 | ￥ 200 | 我看好 VBMAN, 加油干 | | 2024-09-29 | 好友：郑春来 | ￥ 200 | 捐助￥ 200 开发 VBMAN 客户端 HTTP 分块上传文件的 demo | | 2024-12-12 | QQ 群友: 守望者 | ￥ 6.66 | 捐赠 6.66 | | 2024-12-12 | QQ 群友: 码农库 MaNongKu.com | ￥ 1.66 | 捐赠 1.66 | | 2024-12-18 | QQ 群友: mature | ￥ 50.00 | 期待后续的开发，特别是对网页的视频的控制，如播放，暂停，快进，拖放等，看视频中途有题出现时的处理。 | | 2024-12-20 | QQ 群友: 郑春来 | ￥ 88.00 | 捐赠 vbman2。 | | 2024-12-28 | QQ 群友: moonboy | ￥ 66.00 | 小小支持一下，祝越做越好。 | | 2025-03-07 | 微信：\*翼 | ￥ 10.00 | 太棒了，期待更强。 | | 2025-01-11 | QQ 群友：绵阳汪汪 | ￥ 66.66 | 暂无。 | | 2025-01-07 | 微信：\*尔 | ￥ 10.80 | 暂无。 | | 2025-01-07 | 微信：\*尔（支付 2 次） | ￥ 10.80 | 暂无。 | | 2025-06-14 | 微信：贺文龙 | ￥ 500.00 | 把 vb 瘸了的那条腿给接上了。 | | 2025-06-16 | QQ 群友：cuieaor | ￥ 18.00 | 请大神喝杯奶茶。 | | 2025-06-18 | QQ 群友：上海二毛 | ￥ 188.00 | 守住国内 VB6 最后的领地。 | | 2025-12-15 | QQ 群友：蓝海岸 | ￥ 10.00 | 暂无。 | | 2025-12-22 | QQ 群友：Man.兔子 ღ o О | ￥ 50.00 | 暂无。 | | 2026-01-12 | QQ 群友：你到底说不说 | ￥ 50.00 | 再接再厉，继续加油! | | 2026-01-16 | QQ 群友: 码农库 MaNongKu.com | ￥ 20.00 | for vbman | | 2026-01-17 | QQ 群友: 往事随风 | ￥ 100.00 | VBMAN 加油 | | 2026-01-30 | QQ 群友: 小鱼 | ￥ 100.00 | 以图鼓励 嘎嘎 | | 2026-01-30 | QQ 群友: xxdoc | ￥ 20.00 | vbmen牛 | | 2026-02-08 | QQ 群友: 老白 | ￥ 200.00 | 过年了赞助你点 | | 2026-02-09 | QQ 群友: 南赡部洲 | ￥ 100.00 | 大佬，赞助了100 | | 2026-02-16 | QQ 群友: 松林 | ￥ 100.00 | 捐献给本网站 | | 2026-02-18 | QQ 群友: 游戏玩家 | ￥ 6.66 | vbman2，一点点感谢 | | 2026-03-02 | 微信: y\*w | ￥ 20.00 | （无留言） | | 2026-03-02 | QQ 群友: ck^er | ￥ 6.66 | 有空把winsock例程分开吧^O^ | | 2026-03-19 | 微信: 德\*d | ￥ 30.00 | （无留言） | | 2026-03-26 | QQ 群友: norman | ￥ 50.00 | 希望给vb6多续两年命 | | 2026-05-08 | QQ 群友: 小熊软糖 | ￥ 500.00 | 小小心意 | | 2026-05-21 | QQ 群友: 小熊软糖 | ￥ 300.00 | 咖啡费已捐赠 | | 2026-06-01 | QQ 群友: 橙子 | ￥ 100.00 | (无留言) | | 2026-06-25 | QQ 群友: 自学成柴 | ￥ 10.00 | 喝杯红牛 | | 2026-07-19 | QQ 匿名网友（1） | ￥ 200.00 | 辛苦 | | 2026-07-23 | 好友：郑春来 | ￥ 200.00 | VBMAN | | 2026-08-16 | QQ 群友：后悔（2） | ￥ 50.00 | 支持大佬，请大佬喝咖 | ## 资金使用说明 所有捐赠资金将用于： * 项目的持续开发和维护 * 服务器和域名费用支出 * 文档的完善和翻译工作 * 社区建设和技术支持 ## 捐赠者名单（C3专项） 以下是支持 C3 项目的捐赠者名单（按时间先后排序）： | 日期 Date | 捐赠者 Donor | 金额 Amount | 留言 Message | | ---------- | ------------ | ----------- | ---------------------------- | | 2026-07-07 | QQ群友：落叶 | ￥16 | 请大佬喝杯咖啡，提提速！！！ | | 2026-07-20 | QQ群友：★UF● | ￥20 | 虽然现在VB不怎么用了，先支持下！ | ## 特别说明 * 捐赠纯属自愿，金额不限 * 捐赠者名单将定期更新 * 如果您希望匿名捐赠，请在留言中注明 再次感谢每一位支持者！ --- --- url: /zh/emoji/0C80-0CFF.md --- # 卡纳达文 (Kannada) 本页面展示了Unicode字符集中，位于U+0C80到U+0CFF范围的卡纳达文字符。卡纳达文是印度卡纳塔克邦的官方文字，用于书写卡纳达语。 | 字符 | Unicode | VB函数值 | 名称 | |:---:|:---:|:---:|:---| | ಁ | U+0C81 | ChrW(\&H0C81) | 卡纳达文标记CANDRABINDU | | ಂ | U+0C82 | ChrW(\&H0C82) | 卡纳达文标记ANUSVARA | | ಃ | U+0C83 | ChrW(\&H0C83) | 卡纳达文标记VISARGA | | ಅ | U+0C85 | ChrW(\&H0C85) | 卡纳达文字母A | | ಆ | U+0C86 | ChrW(\&H0C86) | 卡纳达文字母AA | | ಇ | U+0C87 | ChrW(\&H0C87) | 卡纳达文字母I | | ಈ | U+0C88 | ChrW(\&H0C88) | 卡纳达文字母II | | ಉ | U+0C89 | ChrW(\&H0C89) | 卡纳达文字母U | | ಊ | U+0C8A | ChrW(\&H0C8A) | 卡纳达文字母UU | | ಋ | U+0C8B | ChrW(\&H0C8B) | 卡纳达文字母VOCALIC R | --- --- url: /zh/vbman/start/devlog.md --- # 开发日志 ::: danger 使用须知 **仅限合法用途，非法使用绝对禁止。** 下载=同意：一切法律责任由使用者自负，与本站无关。 本站将依法配合国家审查。 ::: ## 2026-03-18 v1.0.335 [下载](https://wwaue.lanzouv.com/i9ZW43kylxkh) * **新增 cToast 消息提示组件** * 支持9种显示位置（居中、四角、四中） * 支持4种状态主题（信息、成功、警告、危险） * 支持2种颜色主题（浅色、深色） * 智能堆叠功能，自动顺序或倒序堆叠 * 鼠标悬停暂停倒计时 * 全局单例对象，可在任何地方免New调用 * 完整的事件机制和API文档 ## 2026-01-27 v1.0.302 [下载](https://wwaue.lanzouv.com/iScuR3h317da) * **新增 cRedis 类对象** * 新增 cWInsock 的 同步操作套件 * 新增 全局对象 Tools 相关日常工具 * 更多等你发现 ## 2026-01-10 v1.0.265 [下载](https://wwaue.lanzouv.com/igLdr3fz5ula) * **体积首次超过`1MB`** 本次发布正式版，首次超过 1MB 体积，经历的版本编译刚好`100`次。期间增加了不少功能对象。 具体就先看看 F2 对象浏览器的库成员吧。或者直接下载上面的链接文件，压缩包里面有很多 demo 示例了。 * **新增模块预览** 1. 完善 cCsv 完善。 2. 增加 cWinsock 类对象 3. 增加 cWebsocket 类对象 * ...更多请看 F2 对象浏览器 ## 2020-05-05 v1.0.165 [下载](https://wwaue.lanzouv.com/i6u1t3e63u3a) * **修正 cJson.Encode 错误** 群友 如风 发现`cJson`类在`Encode`方法中，超过 100 行的 JSON 字符串存就会溢出，已修正。 * **增加了天气预报查询实例** 实现了一个带视频播放的天气预报查询实例，通过调用天气预报查询接口，获取天气预报信息，并播放央视解说视频。 --- --- url: /zh/biz/cs-auther/client.md --- # 客户端模块详解 ## 工程概览 * **工程文件**: `src-client/Client.vbp` * **启动对象**: `fLogin` * **输出文件**: `dist/客户端/Client.exe` * **配置文件**: `config.ini` *** ## 全局模块 ### Insts.bas 定义客户端全局共享的实例： ```vb Public TcpClient As cWinsock ' TCP 连接对象 Public CurrentUser As New cJson ' 当前登录用户信息缓存 ``` **ConnectToServer** — 根据 `config.ini` 中的配置连接服务端： ```vb Public Sub ConnectToServer() With VBMAN.Ini.Section("Server") TcpClient.Connect .Item("IP"), .Item("Port") End With End Sub ``` *** ## 窗体模块 ### fLogin.frm — 登录窗体 **界面元素**: * `Text1` — 用户名输入框 * `Text2` — 密码输入框（显示为 `*`） * `Command1` — 登录按钮 * `Command2` — 设置按钮（打开 `fSetting`） * `Picture2/Label4` — 状态栏（显示连接状态） * `Timer1` — 重连定时器（3秒间隔） **核心逻辑**: 1. **Form\_Load**: * 加载 `config.ini`，若服务器配置缺失则强制弹出 `fSetting` * 注册路由：`User`, `Message`, `Notify` * 初始化 `TcpClient`，尝试连接服务器 * IDE 调试模式下自动填充测试账号 `wangli` / `123456` 2. **Command1\_Click (登录)**: ```vb With New cJson .Item("username") = Text1.Text .Item("password") = Common.Password(Text2.Text) Common.SendTo Insts.TcpClient, "user/login", .Root End With ``` 密码通过 `Common.Password` 使用 VBMAN 的哈希算法加密后发送。 3. **Tcp 事件**: * `Connect` — 状态栏变绿，启用登录按钮 * `CloseEvent` — 状态栏变红，禁用登录按钮，启动重连定时器 * `DataArrival` — 调用 `Common.HandleReciver` 处理数据 *** ### Form1.frm — 客户端主窗体 **界面布局**: * `List1` — 左侧功能列表（由 `bCalc` 初始化填充参数键名） * `Text1` — 右侧编辑区（显示/编辑参数值或 JSON） * `Text2` — 底部公告栏（浅蓝色背景，只读） * `Label1` — 右上角状态标签 **菜单**: * `文件 → 设置` — 打开 `fSetting`，重新连接服务器 * `文件 → 开机启动` — 切换 Windows 开机启动状态 * `文件 → 修改密码` — 打开 `fChangePwd`，修改当前用户密码 * `发送参数到服务器` — 将当前编辑的 50 个参数发送到服务端 **核心逻辑**: 1. **Form\_Load**: * 检查是否已登录（`CurrentUser` 是否为空），未登录则返回 `fLogin` * 接管 `TcpClient` 实例 * 注册 `Calc` 路由 * 请求最新公告 `Notify/CheckNew` * 初始化 `bCalc` 并绑定 `List1` 和 `Text1` 2. **bCalc 集成**: * `List1` 显示 50 个参数名 * 点击参数名 → `Text1` 显示对应值，可直接编辑 * 菜单发送 → 将完整 JSON 发送到服务端 `Calc/Submit` *** ### fChangePwd.frm — 修改密码窗体 **界面元素**: * `txtOldPwd` — 旧密码输入框（密码显示） * `txtNewPwd` — 新密码输入框（密码显示） * `txtNewPwd2` — 确认新密码输入框（密码显示） * `cmdOK` — 确定按钮 * `cmdCancel` — 取消按钮 * `lblUser` — 显示当前用户信息 **核心逻辑**: 1. **Form\_Load**: * 显示当前登录用户的昵称和账号 2. **cmdOK\_Click (修改密码)**: * 本地验证：旧密码、新密码、确认密码非空 * 验证两次输入的新密码是否一致 * 验证新密码长度不少于 6 位 * 发送请求到服务端 `User/ChangePassword`: ```vb With New cJson .Item("oldPassword") = Common.Password(OldPwd) .Item("newPassword") = Common.Password(NewPwd) Common.SendTo Insts.TcpClient, "User/ChangePassword", .Root End With ``` 3. **cmdCancel\_Click**: * 关闭窗口 *** ### fSetting.frm — 服务器配置窗体 **界面元素**: * `Text1` — 服务器 IP 输入框 * `Text2` — 端口输入框 * `Command1` — 保存按钮 * `Command2` — 退出程序按钮 * `Command3` — 关闭窗口按钮 **核心逻辑**: 1. **Form\_Load**: * 从 `config.ini` 读取现有配置并填充 2. **Command1\_Click (保存)**: ```vb With VBMAN.Ini.Section("Server") .Item("IP") = Text1.Text .Item("Port") = Text2.Text End With VBMAN.Ini.SaveTo ``` 保存后关闭窗口，调用方（`fLogin`）会继续尝试连接。 *** ## 业务类 ### bUser.cls — 用户业务 | 方法 | 说明 | |------|------| | `Info(Inst, Data)` | 接收服务端返回的用户信息，解析保存到 `CurrentUser`，延时 2 秒后显示 `Form1` | | `ShowMainForm()` | 被 `Delay.Callback` 异步调用，避免在 TCP 事件内直接切换窗体引发重入问题 | | `ChangePassword(Inst, Data)` | 接收服务端返回的密码修改结果，关闭修改密码窗口 | **异步显示主窗体的原因**: > 因为 `bUser.Info` 在 TCP 接收处理器内部执行，而 `fLogin` 也监听了 TCP 事件。如果直接在 `Info` 中 `Unload fLogin`，会引发事件重入冲突。因此使用 `VBMAN.Delay.Callback(Me, "ShowMainForm").CountDown 2000` 延迟 2 秒后异步执行。 *** ### bNotify.cls — 公告业务 | 方法 | 说明 | |------|------| | `Show(Inst, Data)` | 接收服务端推送的公告内容，显示在 `Form1.Text2` 中，同时弹出 Toast 通知 | **公告显示格式**: ``` 【公告】标题（发布时间） 公告正文内容... ``` *** ### bCalc.cls — 参数计算演示 这是一个完整的客户端-服务端数据交互演示类，包含 **50 个多类型参数**。 **数据类型覆盖**: | 类型 | 字段示例 | VB 类型 | |------|----------|---------| | 长整型 | `id`, `timeout` | `Long` | | 整型 | `age`, `screenW` | `Integer` | | 字节型 | `grade`, `retryCount` | `Byte` | | 货币型 | `salary`, `revenue` | `Currency` | | 单精度浮点 | `height`, `velocity` | `Single` | | 双精度浮点 | `pressure`, `lat` | `Double` | | 布尔型 | `isActive`, `isVip` | `Boolean` | | 日期型 | `birthDate`, `joinAt` | `Date` | | 字符串型 | `name`, `email`, `address` | `String` | **交互流程**: 1. `CreateJsonData` — 初始化 50 个参数到 `JsonData` 对象 2. `List1_Click` — 选择参数，在 `Text1` 中显示值 3. `Inputor_Change` — 编辑参数值，实时更新 `JsonData` 4. `SendJsonDataToServer` — 发送完整 JSON 到服务端 `Calc/Submit` 5. `Show(Inst, Data)` — 接收服务端修改后的数据，回显格式化 JSON 到 `Text1` *** ## 配置文件 (config.ini) ```ini [Server] IP=127.0.0.1 Port=800 ``` * 首次启动时若配置缺失，会强制弹出 `fSetting` 要求填写 * 配置保存在客户端同目录下 --- --- url: /zh/emoji/02B0-02FF.md --- # 空白修饰字母 本文档包含了Unicode基本多文种平面中的空白修饰字母字符，范围为U+02B0至U+02FF。这些字符主要用于音标标注中的上标和下标字母。 | 字符 | Unicode | VB函数值 | 名称 | |:---:|:---:|:---:|:---| | ʰ | U+02B0 | ChrW(\&H02B0) | 修饰字母小写h | | ʱ | U+02B1 | ChrW(\&H02B1) | 修饰字母小写h带钩 | | ʲ | U+02B2 | ChrW(\&H02B2) | 修饰字母小写j | | ʳ | U+02B3 | ChrW(\&H02B3) | 修饰字母小写r | | ʴ | U+02B4 | ChrW(\&H02B4) | 修饰字母小写转向r | | ʵ | U+02B5 | ChrW(\&H02B5) | 修饰字母小写转向r带钩 | | ʶ | U+02B6 | ChrW(\&H02B6) | 修饰字母小写倒置r | | ʷ | U+02B7 | ChrW(\&H02B7) | 修饰字母小写w | | ʸ | U+02B8 | ChrW(\&H02B8) | 修饰字母小写y | | ʹ | U+02B9 | ChrW(\&H02B9) | 修饰字母头 | | ʺ | U+02BA | ChrW(\&H02BA) | 修饰字母双头 | | ʻ | U+02BB | ChrW(\&H02BB) | 修饰字母转向逗号 | | ʼ | U+02BC | ChrW(\&H02BC) | 修饰字母撇号 | | ʽ | U+02BD | ChrW(\&H02BD) | 修饰字母反向逗号 | | ʾ | U+02BE | ChrW(\&H02BE) | 修饰字母右半环 | | ʿ | U+02BF | ChrW(\&H02BF) | 修饰字母左半环 | | ˀ | U+02C0 | ChrW(\&H02C0) | 修饰字母声门塞音 | | ˁ | U+02C1 | ChrW(\&H02C1) | 修饰字母声门摩擦音 | | ˂ | U+02C2 | ChrW(\&H02C2) | 修饰字母左箭头 | | ˃ | U+02C3 | ChrW(\&H02C3) | 修饰字母右箭头 | | ˄ | U+02C4 | ChrW(\&H02C4) | 修饰字母上箭头 | | ˅ | U+02C5 | ChrW(\&H02C5) | 修饰字母下箭头 | | ˆ | U+02C6 | ChrW(\&H02C6) | 修饰字母环境符号 | | ˇ | U+02C7 | ChrW(\&H02C7) | 抑音符 | | ˈ | U+02C8 | ChrW(\&H02C8) | 修饰字母纵线 | | ˉ | U+02C9 | ChrW(\&H02C9) | 修饰字母横线 | | ˊ | U+02CA | ChrW(\&H02CA) | 修饰字母锐音符 | | ˋ | U+02CB | ChrW(\&H02CB) | 修饰字母重音符 | | ˌ | U+02CC | ChrW(\&H02CC) | 修饰字母低纵线 | | ˍ | U+02CD | ChrW(\&H02CD) | 修饰字母低横线 | | ˎ | U+02CE | ChrW(\&H02CE) | 修饰字母低重音符 | | ˏ | U+02CF | ChrW(\&H02CF) | 修饰字母低锐音符 | | ː | U+02D0 | ChrW(\&H02D0) | 修饰字母三角号 | | ˑ | U+02D1 | ChrW(\&H02D1) | 修饰字母半长符号 | | ˒ | U+02D2 | ChrW(\&H02D2) | 修饰字母居中三角号 | | ˓ | U+02D3 | ChrW(\&H02D3) | 修饰字母居中抑音符 | | ˔ | U+02D4 | ChrW(\&H02D4) | 修饰字母上升箭头 | | ˕ | U+02D5 | ChrW(\&H02D5) | 修饰字母下降箭头 | | ˖ | U+02D6 | ChrW(\&H02D6) | 修饰字母加号 | | ˗ | U+02D7 | ChrW(\&H02D7) | 修饰字母减号 | | ˘ | U+02D8 | ChrW(\&H02D8) | 短音符号 | | ˙ | U+02D9 | ChrW(\&H02D9) | 点上符号 | | ˚ | U+02DA | ChrW(\&H02DA) | 圆圈上符号 | | ˛ | U+02DB | ChrW(\&H02DB) | 下加符号 | | ˜ | U+02DC | ChrW(\&H02DC) | 小波浪符号 | | ˝ | U+02DD | ChrW(\&H02DD) | 双锐音符 | | ˞ | U+02DE | ChrW(\&H02DE) | 修饰字母卷舌符号 | | ˟ | U+02DF | ChrW(\&H02DF) | 修饰字母叉号 | | ˠ | U+02E0 | ChrW(\&H02E0) | 修饰字母小型大写G | | ˡ | U+02E1 | ChrW(\&H02E1) | 修饰字母小写l | | ˢ | U+02E2 | ChrW(\&H02E2) | 修饰字母小写s | | ˣ | U+02E3 | ChrW(\&H02E3) | 修饰字母小写x | | ˤ | U+02E4 | ChrW(\&H02E4) | 修饰字母小型大写H | | ˥ | U+02E5 | ChrW(\&H02E5) | 修饰字母超高音调 | | ˦ | U+02E6 | ChrW(\&H02E6) | 修饰字母高音调 | | ˧ | U+02E7 | ChrW(\&H02E7) | 修饰字母中音调 | | ˨ | U+02E8 | ChrW(\&H02E8) | 修饰字母低音调 | | ˩ | U+02E9 | ChrW(\&H02E9) | 修饰字母超低音调 | | ˪ | U+02EA | ChrW(\&H02EA) | 修饰字母阴平 | | ˫ | U+02EB | ChrW(\&H02EB) | 修饰字母阳平 | | ˬ | U+02EC | ChrW(\&H02EC) | 修饰字母声调记号 | | ˭ | U+02ED | ChrW(\&H02ED) | 修饰字母平调 | | ˮ | U+02EE | ChrW(\&H02EE) | 修饰字母双撇号 | | ˯ | U+02EF | ChrW(\&H02EF) | 修饰字母低向下箭头 | | ˰ | U+02F0 | ChrW(\&H02F0) | 修饰字母低向上箭头 | | ˱ | U+02F1 | ChrW(\&H02F1) | 修饰字母低左箭头 | | ˲ | U+02F2 | ChrW(\&H02F2) | 修饰字母低右箭头 | | ˳ | U+02F3 | ChrW(\&H02F3) | 修饰字母低环 | | ˴ | U+02F4 | ChrW(\&H02F4) | 修饰字母中高点 | | ˵ | U+02F5 | ChrW(\&H02F5) | 修饰字母双重重音符 | | ˶ | U+02F6 | ChrW(\&H02F6) | 修饰字母双重锐音符 | | ˷ | U+02F7 | ChrW(\&H02F7) | 修饰字母低波浪符 | | ˸ | U+02F8 | ChrW(\&H02F8) | 修饰字母高点 | | ˹ | U+02F9 | ChrW(\&H02F9) | 修饰字母起始高音调 | | ˺ | U+02FA | ChrW(\&H02FA) | 修饰字母结束高音调 | | ˻ | U+02FB | ChrW(\&H02FB) | 修饰字母起始低音调 | | ˼ | U+02FC | ChrW(\&H02FC) | 修饰字母结束低音调 | | ˽ | U+02FD | ChrW(\&H02FD) | 修饰字母起始中音调 | | ˾ | U+02FE | ChrW(\&H02FE) | 修饰字母结束中音调 | | ˿ | U+02FF | ChrW(\&H02FF) | 修饰字母低向上钩 | --- --- url: /zh/emoji/2400-243F.md --- # 控制图片 (U+2400 - U+243F) 本节包含了控制字符的图形表示，主要用于显示不可见的控制字符。 | 字符 | Unicode | VB函数值 | 名称 | |:---:|:---:|:---:|:---| | ␀ | U+2400 | ChrW(\&H2400) | 符号为空 | | ␁ | U+2401 | ChrW(\&H2401) | 标题开始符号 | | ␂ | U+2402 | ChrW(\&H2402) | 正文开始符号 | | ␃ | U+2403 | ChrW(\&H2403) | 正文结束符号 | | ␄ | U+2404 | ChrW(\&H2404) | 传输结束符号 | | ␅ | U+2405 | ChrW(\&H2405) | 询问符号 | | ␆ | U+2406 | ChrW(\&H2406) | 认可符号 | | ␇ | U+2407 | ChrW(\&H2407) | 响铃符号 | | ␈ | U+2408 | ChrW(\&H2408) | 退格符号 | | ␉ | U+2409 | ChrW(\&H2409) | 水平制表符号 | | ␊ | U+240A | ChrW(\&H240A) | 换行符号 | | ␋ | U+240B | ChrW(\&H240B) | 垂直制表符号 | | ␌ | U+240C | ChrW(\&H240C) | 换页符号 | | ␍ | U+240D | ChrW(\&H240D) | 回车符号 | | ␎ | U+240E | ChrW(\&H240E) | 移出符号 | | ␏ | U+240F | ChrW(\&H240F) | 移入符号 | | ␐ | U+2410 | ChrW(\&H2410) | 数据链接转义符号 | | ␑ | U+2411 | ChrW(\&H2411) | 设备控制1符号 | | ␒ | U+2412 | ChrW(\&H2412) | 设备控制2符号 | | ␓ | U+2413 | ChrW(\&H2413) | 设备控制3符号 | | ␔ | U+2414 | ChrW(\&H2414) | 设备控制4符号 | | ␕ | U+2415 | ChrW(\&H2415) | 否定应答符号 | | ␖ | U+2416 | ChrW(\&H2416) | 同步空闲符号 | | ␗ | U+2417 | ChrW(\&H2417) | 传输块结束符号 | | ␘ | U+2418 | ChrW(\&H2418) | 取消符号 | | ␙ | U+2419 | ChrW(\&H2419) | 介质结束符号 | | ␚ | U+241A | ChrW(\&H241A) | 替换符号 | | ␛ | U+241B | ChrW(\&H241B) | 转义符号 | | ␜ | U+241C | ChrW(\&H241C) | 文件分隔符号 | | ␝ | U+241D | ChrW(\&H241D) | 组分隔符号 | | ␞ | U+241E | ChrW(\&H241E) | 记录分隔符号 | | ␟ | U+241F | ChrW(\&H241F) | 单元分隔符号 | --- --- url: /zh/biz/cs-auther/quickstart.md --- # 快速开始 ## 环境准备 ### 必要条件 | 项目 | 要求 | |------|------| | 操作系统 | Windows 7/10/11 (32位/64位) | | 开发环境 | Visual Basic 6.0 (SP6) | | 依赖库 | `VBMAN.dll`（需注册到系统或放在程序目录） | | 数据库引擎 | Microsoft Access Database Engine（用于 `.mdb`） | ### VBMAN 依赖 本项目基于 **VBMAN 框架** 构建，需要确保 `VBMAN.dll` 可用： 1. 将 `VBMAN.dll` 放置到工程引用路径，或注册到系统： ```cmd regsvr32 VBMAN.dll ``` 2. 在 VB6 IDE 中确认引用 `VBMANLIB` 已勾选（工程 → 引用） *** ## 项目编译 ### 编译服务端 1. 打开 `src-server/Server.vbp` 2. 确认引用路径指向正确的 `VBMAN.dll` 3. 菜单选择 **文件 → 生成 Server.exe** 4. 输出到 `dist/服务端/Server.exe` 5. 确保同目录下包含 `data.mdb` ### 编译客户端 1. 打开 `src-client/Client.vbp` 2. 确认引用路径指向正确的 `VBMAN.dll` 3. 菜单选择 **文件 → 生成 Client.exe** 4. 输出到 `dist/客户端/Client.exe` 5. 确保同目录下包含 `config.ini` *** ## 运行步骤 ### 1. 启动服务端 双击运行 `dist/服务端/Server.exe` * 服务端自动监听 **TCP 800 端口** * 连接同目录下的 `data.mdb` 数据库 * 窗体左侧显示用户列表，右侧显示操作日志 * 右上角显示当前在线客户端数量 ### 2. 配置客户端 首次运行客户端时，需要配置服务器地址： 1. 双击运行 `dist/客户端/Client.exe` 2. 弹出 **参数配置** 窗口 3. 填写服务器 IP（本机测试填 `127.0.0.1`） 4. 填写端口（默认 `800`） 5. 点击 **保存** 或手动创建 `config.ini`： ```ini [Server] IP=127.0.0.1 Port=800 ``` ### 3. 登录测试 1. 客户端自动连接服务端，状态栏显示"服务器已联机，请登录" 2. 在 IDE 调试模式下，账号密码已自动填充为： * 用户名: `wangli` * 密码: `123456` 3. 点击 **登录** 4. 登录成功后，显示主窗体 `Form1` > 若数据库中无此用户，可使用 Access 打开 `data.mdb` 的 `users` 表手动添加记录。 *** ## 功能体验 ### 用户登录与在线状态 * 服务端 `List1` 中在线用户会显示 `[ 在线 ]` 前缀并置顶 * 同一账号在另一客户端登录时，旧客户端会收到"账号在另外一个地方登录"提示并被踢下线 ### 公告推送 1. 在服务端点击菜单 **推送公告** 2. 填写标题和内容，点击 **立即推送** 3. 所有在线客户端会立即收到公告并显示在底部文本框 4. 离线客户端重新登录后会自动请求最新公告 ### 参数传输演示 1. 客户端主窗体左侧显示 50 个参数名 2. 点击任意参数，右侧显示当前值 3. 修改值后，点击菜单 **发送参数到服务器** 4. 服务端修改部分字段后回传，右侧显示服务端返回的完整 JSON *** ## 常见问题 ### 连接失败 * 检查服务端是否已启动并监听 800 端口 * 检查客户端 `config.ini` 中的 IP 和端口是否正确 * 检查 Windows 防火墙是否阻止了程序网络访问 ### 数据库连接失败 * 确保 `data.mdb` 与服务端 EXE 在同一目录 * 安装 Microsoft Access Database Engine 或确保系统已安装 Office/Access ### VBMAN 引用丢失 * 在 VB6 IDE 中打开工程，检查 **工程 → 引用** 中 `VBMANLIB` 是否标记为"丢失" * 重新浏览并选择正确的 `VBMAN.dll` 路径 *** ## 二次开发建议 ### 新增业务接口 以新增 `Order/Create` 接口为例： 1. **创建业务类**: 在客户端和服务端分别新建 `bOrder.cls` 2. **实现方法**: ```vb ' 服务端 Public Sub Create(Inst As cWinsock, Data As cJson) ' 处理创建订单逻辑 Common.SendTo Inst, "Order/Created", result End Sub ' 客户端 Public Sub Created(Inst As cWinsock, Data As cJson) ' 处理订单创建成功回调 End Sub ``` 3. **注册路由**: 在 `fLogin.Form_Load`（客户端）和 `Form1.RegRouter`（服务端）中添加： ```vb Common.Router.Add New bOrder, "Order" ``` 4. **客户端调用**: ```vb Common.SendTo Insts.TcpClient, "Order/Create", orderData ``` ### 新增中间件 1. 新建 `mLog.cls`（参考 `mAuth.cls`） 2. 实现 `Entry` 函数，记录日志或进行其他前置处理 3. 在服务端 `RegRouter` 中添加到 `MiddleWares` 集合 --- --- url: /zh/vbman/modbus/quickstart.md --- # 快速开始 本指南将帮助您快速上手 Modbus 类库，创建基本的主站和从站应用。 *** ## ? 前置准备 ### 必需文件 确保以下文件已添加到项目中： | 文件 | 位置 | 说明 | | ------------------- | ------------- | ---------------- | | `cWinsock.cls` | `add/` | 底层 Socket 封装 | | `cByteBuffer.cls` | `src/` | 字节缓冲区类 | | `cModbusMaster.cls` | `src/Modbus/` | 主站类 | | `cModbusSlave.cls` | `src/Modbus/` | 从站类 | ### 添加到项目 1. 打开 VB6 项目 2. 菜单：项目 → 添加类模块 3. 浏览到相应文件并添加 *** ## ? 主站快速入门（TCP 模式） ### 步骤 1：创建窗体 创建一个新窗体，添加以下控件： * 1 个 TextBox (`txtHost`) - 服务器地址 * 1 个 TextBox (`txtPort`) - 端口号 * 1 个 TextBox (`txtSlaveID`) - 从站 ID * 2 个 CommandButton (`cmdConnect`, `cmdDisconnect`) - 连接/断开 * 1 个 TextBox (`txtAddress`) - 寄存器地址 * 1 个 TextBox (`txtCount`) - 读取数量 * 1 个 CommandButton (`cmdRead`) - 读取数据 * 1 个 TextBox (`txtLog`) - 显示日志（MultiLine = True） ### 步骤 2：编写代码 ```vb Option Explicit Private WithEvents mbMaster As cModbusMaster Private Sub Form_Load() Set mbMaster = New cModbusMaster txtHost.Text = "127.0.0.1" txtPort.Text = "502" txtSlaveID.Text = "1" txtAddress.Text = "0" txtCount.Text = "10" UpdateUI False End Sub Private Sub cmdConnect_Click() On Error GoTo EH mbMaster.ProtocolType = MB_MASTER_PROTOCOL_TCP mbMaster.TCPHost = txtHost.Text mbMaster.TCPPort = CLng(txtPort.Text) mbMaster.SlaveID = CByte(txtSlaveID.Text) mbMaster.Connect LogMessage "正在连接到: " & txtHost.Text & ":" & txtPort.Text Exit Sub EH: LogMessage "连接失败: " & Err.Description End Sub Private Sub cmdDisconnect_Click() On Error Resume Next mbMaster.Disconnect LogMessage "已断开连接" UpdateUI False End Sub Private Sub cmdRead_Click() On Error GoTo EH If mbMaster.State <> MB_MASTER_STATE_CONNECTED Then LogMessage "未连接" Exit Sub End If Dim lAddr As Long Dim lCount As Long Dim iRegs() As Integer Dim i As Long lAddr = CLng(txtAddress.Text) lCount = CLng(txtCount.Text) LogMessage "读取寄存器: 地址=" & lAddr & ", 数量=" & lCount iRegs = mbMaster.ReadHoldingRegisters(lAddr, lCount) Dim sResult As String For i = 0 To UBound(iRegs) sResult = sResult & "Reg[" & (lAddr + i) & "]=" & iRegs(i) & " " Next i LogMessage sResult Exit Sub EH: LogMessage "读取失败: " & Err.Description End Sub ' ====== Modbus Master 事件处理 ====== Private Sub mbMaster_OnConnect() LogMessage "*** 连接成功! ***" UpdateUI True End Sub Private Sub mbMaster_OnDisconnect() LogMessage "*** 连接断开 ***" UpdateUI False End Sub Private Sub mbMaster_OnError(ByVal Description As String) LogMessage "*** 错误: " & Description & " ***" End Sub ' ====== 辅助函数 ====== Private Sub LogMessage(sMessage As String) txtLog.Text = txtLog.Text & Format$(Now, "hh:mm:ss") & " - " & sMessage & vbCrLf txtLog.SelStart = Len(txtLog.Text) End Sub Private Sub UpdateUI(bConnected As Boolean) txtHost.Enabled = Not bConnected txtPort.Enabled = Not bConnected txtSlaveID.Enabled = Not bConnected cmdConnect.Enabled = Not bConnected cmdDisconnect.Enabled = bConnected cmdRead.Enabled = bConnected End Sub Private Sub Form_Unload(Cancel As Integer) On Error Resume Next mbMaster.Disconnect End Sub ``` ### 步骤 3：运行测试 1. 按 F5 运行程序 2. 输入服务器地址（如 `127.0.0.1`） 3. 点击"连接" 4. 连接成功后，输入地址和数量 5. 点击"读取数据" *** ## ? 从站快速入门（TCP 模式） ### 步骤 1：创建窗体 创建一个新窗体，添加以下控件： * 1 个 TextBox (`txtPort`) - 监听端口 * 1 个 TextBox (`txtSlaveID`) - 从站 ID * 2 个 CommandButton (`cmdStart`, `cmdStop`) - 启动/停止 * 1 个 ListBox (`lstRegisters`) - 寄存器列表 * 1 个 TextBox (`txtRegAddr`) - 寄存器地址 * 1 个 TextBox (`txtRegValue`) - 寄存器值 * 1 个 CommandButton (`cmdSetReg`) - 设置寄存器 * 1 个 TextBox (`txtLog`) - 显示日志（MultiLine = True） ### 步骤 2：编写代码 ```vb Option Explicit Private WithEvents mbSlave As cModbusSlave Private Sub Form_Load() Set mbSlave = New cModbusSlave txtPort.Text = "502" txtSlaveID.Text = "1" txtRegAddr.Text = "0" txtRegValue.Text = "0" UpdateServerUI False End Sub Private Sub cmdStart_Click() On Error GoTo EH mbSlave.ProtocolType = MB_SLAVE_PROTOCOL_TCP mbSlave.SlaveID = CByte(txtSlaveID.Text) mbSlave.Start CLng(txtPort.Text) LogMessage "正在启动服务器, 端口: " & txtPort.Text Exit Sub EH: LogMessage "启动失败: " & Err.Description End Sub Private Sub cmdStop_Click() On Error Resume Next mbSlave.StopMe LogMessage "服务器已停止" UpdateServerUI False End Sub Private Sub cmdSetReg_Click() On Error GoTo EH If mbSlave.State <> MB_SLAVE_STATE_RUNNING Then LogMessage "服务器未运行" Exit Sub End If Dim lAddr As Long Dim iValue As Integer lAddr = CLng(txtRegAddr.Text) iValue = CInt(txtRegValue.Text) mbSlave.SetHoldingRegister lAddr, iValue LogMessage "设置寄存器: 地址=" & lAddr & ", 值=" & iValue RefreshRegisterList Exit Sub EH: LogMessage "设置失败: " & Err.Description End Sub Private Sub RefreshRegisterList() Dim i As Long lstRegisters.Clear For i = 0 To 10 Dim iValue As Integer iValue = mbSlave.GetHoldingRegister(i) lstRegisters.AddItem "Reg[" & i & "] = " & iValue Next i End Sub ' ====== Modbus Slave 事件处理 ====== Private Sub mbSlave_OnStarted() LogMessage "*** 服务器已启动! ***" UpdateServerUI True End Sub Private Sub mbSlave_OnStopped() LogMessage "*** 服务器已停止 ***" UpdateServerUI False End Sub Private Sub mbSlave_OnClientConnect(ByVal ClientID As String, ByVal RemoteAddress As String) LogMessage "客户端连接: " & ClientID & " (" & RemoteAddress & ")" End Sub Private Sub mbSlave_OnClientDisconnect(ByVal ClientID As String, ByVal Reason As String) LogMessage "客户端断开: " & ClientID & " - " & Reason End Sub Private Sub mbSlave_OnError(ByVal Description As String) LogMessage "*** 错误: " & Description & " ***" End Sub ' ====== 辅助函数 ====== Private Sub LogMessage(sMessage As String) txtLog.Text = txtLog.Text & Format$(Now, "hh:mm:ss") & " - " & sMessage & vbCrLf txtLog.SelStart = Len(txtLog.Text) End Sub Private Sub UpdateServerUI(bRunning As Boolean) txtPort.Enabled = Not bRunning txtSlaveID.Enabled = Not bRunning cmdStart.Enabled = Not bRunning cmdStop.Enabled = bRunning cmdSetReg.Enabled = bRunning End Sub Private Sub Form_Unload(Cancel As Integer) On Error Resume Next mbSlave.StopMe End Sub ``` ### 步骤 3：运行测试 1. 按 F5 运行从站程序 2. 点击"启动服务" 3. 运行上面创建的主站程序 4. 点击"连接" 5. 发送读取请求测试 *** ## ? 主从通信示例 ### 测试场景：主站读取从站寄存器 #### 从站代码（提供数据） ```vb Private Sub Form_Load() Set mbSlave = New cModbusSlave ' 设置一些初始数据 mbSlave.SetHoldingRegister 0, 100 mbSlave.SetHoldingRegister 1, 200 mbSlave.SetHoldingRegister 2, 300 mbSlave.SetHoldingRegister 3, 400 mbSlave.SetHoldingRegister 4, 500 ' 启动服务器 mbSlave.ProtocolType = MB_SLAVE_PROTOCOL_TCP mbSlave.SlaveID = 1 mbSlave.Start 502 End Sub ``` #### 主站代码（读取数据） ```vb Private Sub cmdRead_Click() ' 连接从站 mbMaster.ProtocolType = MB_MASTER_PROTOCOL_TCP mbMaster.TCPHost = "127.0.0.1" mbMaster.TCPPort = 502 mbMaster.SlaveID = 1 mbMaster.Connect ' 读取5个寄存器 Dim iRegs() As Integer iRegs = mbMaster.ReadHoldingRegisters(0, 5) ' 显示结果 Dim i As Long For i = 0 To UBound(iRegs) Debug.Print "Reg[" & i & "] = " & iRegs(i) Next i ' 输出: ' Reg[0] = 100 ' Reg[1] = 200 ' Reg[2] = 300 ' Reg[3] = 400 ' Reg[4] = 500 End Sub ``` *** ## ? RTU 模式快速开始 ### 主站 RTU 模式 ```vb ' 配置 RTU 模式 mbMaster.ProtocolType = MB_MASTER_PROTOCOL_RTU mbMaster.SerialPort = "COM1" mbMaster.BaudRate = 9600 mbMaster.DataBits = 8 mbMaster.Parity = "N" mbMaster.StopBits = 1 mbMaster.SlaveID = 1 ' 连接 mbMaster.Connect "COM1" ' 读取寄存器 Dim iRegs() As Integer iRegs = mbMaster.ReadHoldingRegisters(0, 10) ``` ### 从站 RTU 模式 ```vb ' 配置 RTU 模式 mbSlave.ProtocolType = MB_SLAVE_PROTOCOL_RTU mbSlave.SerialPort = "COM1" mbSlave.BaudRate = 9600 mbSlave.DataBits = 8 mbSlave.Parity = "N" mbSlave.StopBits = 1 mbSlave.SlaveID = 1 ' 启动服务器 mbSlave.Start "COM1" ' 设置数据供主站读取 mbSlave.SetHoldingRegister 0, 1234 mbSlave.SetHoldingRegister 1, 5678 ``` *** ## ? 完整的功能示例 ### 主站 - 读取所有类型的数据 ```vb Private Sub ReadAllTypes() ' 读取线圈 Dim baCoils() As Boolean baCoils = mbMaster.ReadCoils(0, 10) ' 读取离散输入 Dim baInputs() As Boolean baInputs = mbMaster.ReadDiscreteInputs(0, 10) ' 读取保持寄存器 Dim iHoldingRegs() As Integer iHoldingRegs = mbMaster.ReadHoldingRegisters(0, 10) ' 读取输入寄存器 Dim iInputRegs() As Integer iInputRegs = mbMaster.ReadInputRegisters(0, 10) End Sub ``` ### 主站 - 写入所有类型的数据 ```vb Private Sub WriteAllTypes() ' 写入单个线圈 mbMaster.WriteSingleCoil 0, True ' 写入多个线圈 Dim baCoils(4) As Boolean baCoils(0) = True baCoils(1) = False baCoils(2) = True baCoils(3) = False baCoils(4) = True mbMaster.WriteMultipleCoils 0, baCoils ' 写入单个寄存器 mbMaster.WriteSingleRegister 0, 1234 ' 写入多个寄存器 Dim iRegs(4) As Integer iRegs(0) = 100 iRegs(1) = 200 iRegs(2) = 300 iRegs(3) = 400 iRegs(4) = 500 mbMaster.WriteMultipleRegisters 0, iRegs End Sub ``` ### 从站 - 动态更新数据 ```vb Private Sub UpdateDataRealtime() Dim i As Long Dim iValue As Integer ' 持续更新寄存器 Do While mbSlave.State = MB_SLAVE_STATE_RUNNING For i = 0 To 10 iValue = GetSensorValue(i) ' 从传感器获取值 mbSlave.SetHoldingRegister i, iValue Next i DoEvents ' 让出 CPU 时间 Sleep 1000 ' 等待1秒 Loop End Sub Private Function GetSensorValue(iSensorID As Long) As Integer ' 模拟传感器数据 GetSensorValue = Rnd * 10000 End Function ``` *** ## ? 常见问题 ### Q1: 编译错误"用户定义类型未定义" **原因**: 未添加 `cByteBuffer.cls` 类。 **解决**: 1. 菜单：项目 → 添加类模块 2. 浏览到 `src/cByteBuffer.cls` 3. 添加到项目 *** ### Q2: 连接失败"无法解析主机名" **原因**: * TCP 模式：URL 格式错误或网络问题 * RTU 模式：串口不存在或被占用 **解决**: * TCP: 检查主机地址和端口，确保从站已启动 * RTU: 检查串口名称（COM1, COM2 等），确保串口未被占用 *** ### Q3: 读取超时 **原因**: * 从站未启动 * 网络连接问题 * 从站 ID 不匹配 * 超时时间设置过短 **解决**: * 确保从站已启动 * 检查 Slave ID 是否匹配 * 增加 ResponseTimeout 值（默认 1000ms） ```vb mbMaster.ResponseTimeout = 3000 ' 3秒超时 ``` *** ### Q4: 收到异常响应 **原因**: * 功能码不支持 * 地址超出范围 * 数据值非法 **解决**: * 检查从站支持的功能码 * 确保地址在有效范围内 * 检查数据值是否合法 ```vb Private Sub mbMaster_OnError(ByVal Description As String) If InStr(Description, "Modbus Exception") > 0 Then MsgBox "Modbus 异常: " & Description End If End Sub ``` *** ### Q5: RTU 模式 CRC 校验失败 **原因**: * 串口配置不正确（波特率、数据位、校验位、停止位） * 通信线路干扰 **解决**: * 确保主从站串口配置完全一致 * 检查波特率、数据位、校验位、停止位 * 检查通信线路质量 *** ### Q6: 如何处理多个从站 ```vb ' 连接多个从站 mbMaster.SlaveID = 1 mbMaster.Connect Dim iRegs1() As Integer iRegs1 = mbMaster.ReadHoldingRegisters(0, 10) mbMaster.Disconnect mbMaster.SlaveID = 2 mbMaster.Connect Dim iRegs2() As Integer iRegs2 = mbMaster.ReadHoldingRegisters(0, 10) mbMaster.Disconnect ``` *** ### Q7: 如何实现数据缓存 ```vb ' 主站 - 数据缓存 Private m_iRegisterCache(99) As Integer Private Sub ReadWithCache(lAddr As Long, lCount As Long) As Integer() Dim iRegs() As Integer ' 先从缓存读取 If lAddr + lCount <= UBound(m_iRegisterCache) + 1 Then ReDim iRegs(lCount - 1) As Integer Dim i As Long For i = 0 To lCount - 1 iRegs(i) = m_iRegisterCache(lAddr + i) Next i Else ' 缓存未命中，从从站读取 iRegs = mbMaster.ReadHoldingRegisters(lAddr, lCount) ' 更新缓存 If lAddr + lCount <= UBound(m_iRegisterCache) + 1 Then For i = 0 To lCount - 1 m_iRegisterCache(lAddr + i) = iRegs(i) Next i End If End If ReadWithCache = iRegs End Sub ``` *** ## ? 下一步 * 查看 [master.md](./master.md) 了解主站详细 API * 查看 [slave.md](./slave.md) 了解从站详细 API * 查看 [advanced.md](./advanced.md) 了解高级功能 *** **最后更新**: 2026-01-16 ### 更新日志 #### 2026-01-16 (v1.1.0) * 更新从站示例代码，使用 `StopMe()` 替代 `Stop()` * 添加 `BindAddress` 使用示例（从站） * 更新枚举引用（适配 v1.1.0 命名规范） --- --- url: /zh/vbman/websocket/quickstart.md --- # 快速开始 本指南将帮助您快速上手 WebSocket 类库，创建基本的服务端和客户端应用。 *** ## 📦 前置准备 ### 必需文件 确保以下文件已添加到项目中： | 文件 | 位置 | 说明 | |------|------|------| | `cWinsock.cls` | `add/` | 底层 Socket 封装 | | `cWebSocketClient.cls` | `newWebsocket/` | 客户端类 | | `cWebSocketServer.cls` | `newWebsocket/` | 服务端类 | | `cWebSocketFrame.cls` | `newWebsocket/` | 帧解析类 | | `cByteBuffer.cls` | `newWebsocket/` | 缓冲区类 | | `cWebSocketServerClient.cls` | `newWebsocket/` | 服务端客户端类 | | `mWebSocketUtils.bas` | `newWebsocket/` | 工具模块 | ### 添加到项目 1. 打开 VB6 项目 2. 菜单：项目 → 添加类模块 / 添加模块 3. 浏览到相应文件并添加 *** ## 🚀 客户端快速入门 ### 步骤 1：创建窗体 创建一个新窗体，添加以下控件： * 1 个 TextBox (`txtURL`) - 用于输入服务器地址 * 2 个 CommandButton (`cmdConnect`, `cmdDisconnect`) - 连接/断开 * 1 个 TextBox (`txtMessage`) - 输入消息 * 1 个 CommandButton (`cmdSend`) - 发送消息 * 1 个 TextBox (`txtLog`) - 显示日志（MultiLine = True） ### 步骤 2：编写代码 ```vb Option Explicit Private WithEvents m_Client As cWebSocketClient Private Sub Form_Load() Set m_Client = New cWebSocketClient txtURL.Text = "ws://127.0.0.1:8080" txtMessage.Text = "Hello WebSocket!" UpdateUI False End Sub Private Sub cmdConnect_Click() On Error GoTo EH m_Client.Connect txtURL.Text LogMessage "正在连接到: " & txtURL.Text Exit Sub EH: LogMessage "连接失败: " & Err.Description End Sub Private Sub cmdDisconnect_Click() If Not m_Client Is Nothing Then m_Client.CloseConnection LogMessage "已断开连接" End If UpdateUI False End Sub Private Sub cmdSend_Click() On Error GoTo EH If m_Client.State = WS_STATE_OPEN Then m_Client.SendText txtMessage.Text LogMessage "已发送: " & txtMessage.Text End If Exit Sub EH: LogMessage "发送失败: " & Err.Description End Sub ' ====== WebSocket 事件处理 ====== Private Sub m_Client_OnOpen() LogMessage "已成功连接到 WebSocket 服务器" UpdateUI True End Sub Private Sub m_Client_OnClose(ByVal Code As WsCloseCode, ByVal Reason As String) LogMessage "连接已关闭: " & Reason & " (状态码: " & Code & ")" UpdateUI False End Sub Private Sub m_Client_OnTextMessage(ByVal Message As String) LogMessage "收到消息: " & Message End Sub Private Sub m_Client_OnError(ByVal Description As String) LogMessage "错误: " & Description End Sub ' ====== 辅助函数 ====== Private Sub LogMessage(sMessage As String) txtLog.Text = txtLog.Text & Format$(Now, "hh:mm:ss") & " - " & sMessage & vbCrLf txtLog.SelStart = Len(txtLog.Text) End Sub Private Sub UpdateUI(bConnected As Boolean) cmdConnect.Enabled = Not bConnected cmdDisconnect.Enabled = bConnected cmdSend.Enabled = bConnected End Sub Private Sub Form_Unload(Cancel As Integer) If Not m_Client Is Nothing Then m_Client.CloseConnection End If End Sub ``` ### 步骤 3：运行测试 1. 按 F5 运行程序 2. 输入服务器地址（如 `ws://127.0.0.1:8080`） 3. 点击"连接" 4. 连接成功后，输入消息并点击"发送" *** ## 🌐 服务端快速入门 ### 步骤 1：创建窗体 创建一个新窗体，添加以下控件： * 1 个 TextBox (`txtPort`) - 端口号 * 2 个 CommandButton (`cmdStart`, `cmdStop`) - 启动/停止 * 1 ListBox (`lstClients`) - 客户端列表 * 1 个 TextBox (`txtLog`) - 显示日志（MultiLine = True） ### 步骤 2：编写代码 ```vb Option Explicit Private WithEvents m_Server As cWebSocketServer Private Sub Form_Load() Set m_Server = New cWebSocketServer txtPort.Text = "8080" End Sub Private Sub cmdStart_Click() On Error GoTo EH m_Server.Listen CLng(txtPort.Text) LogMessage "服务器已启动，监听端口: " & txtPort.Text Exit Sub EH: LogMessage "启动失败: " & Err.Description End Sub Private Sub cmdStop_Click() If Not m_Server Is Nothing Then m_Server.StopServer LogMessage "服务器已停止" End If lstClients.Clear End Sub ' ====== WebSocket 服务端事件处理 ====== Private Sub m_Server_OnStart(ByVal Port As Long) LogMessage "服务已启动，监听端口: " & Port End Sub Private Sub m_Server_OnStop() LogMessage "服务已停止" End Sub Private Sub m_Server_OnClientConnect(ByVal ClientID As String, ByVal RemoteAddress As String, ByVal RemotePort As Long) LogMessage "客户端连接: " & ClientID & " (" & RemoteAddress & ":" & RemotePort & ")" lstClients.AddItem ClientID & " - " & RemoteAddress ' 发送欢迎消息 m_Server.SendText ClientID, "欢迎连接到 WebSocket 服务器！" End Sub Private Sub m_Server_OnClientDisconnect(ByVal ClientID As String, ByVal Reason As String) LogMessage "客户端断开: " & ClientID & " - " & Reason ' 从列表中移除 Dim i As Long For i = 0 To lstClients.ListCount - 1 If InStr(lstClients.List(i), ClientID) > 0 Then lstClients.RemoveItem i Exit For End If Next End Sub Private Sub m_Server_OnClientTextMessage(ByVal ClientID As String, ByVal Message As String) LogMessage "收到来自 " & ClientID & " 的消息: " & Message ' 回显消息 m_Server.SendText ClientID, "服务器收到: " & Message ' 广播给所有其他客户端（聊天模式） m_Server.BroadcastText ClientID & ": " & Message, ClientID End Sub Private Sub m_Server_OnClientBinaryMessage(ByVal ClientID As String, Data() As Byte) LogMessage "收到来自 " & ClientID & " 的二进制消息: " & (UBound(Data) + 1) & " 字节" End Sub Private Sub m_Server_OnError(ByVal Description As String) LogMessage "错误: " & Description End Sub ' ====== 辅助函数 ====== Private Sub LogMessage(sMessage As String) txtLog.Text = txtLog.Text & Format$(Now, "hh:mm:ss") & " - " & sMessage & vbCrLf txtLog.SelStart = Len(txtLog.Text) End Sub Private Sub Form_Unload(Cancel As Integer) If Not m_Server Is Nothing Then m_Server.StopServer End If End Sub ``` ### 步骤 3：运行测试 1. 按 F5 运行服务端程序 2. 点击"启动服务" 3. 运行上面创建的客户端程序 4. 点击"连接" 5. 发送消息测试 *** ## 💬 聊天室示例 ### 服务端代码 ```vb Option Explicit Private WithEvents m_Server As cWebSocketServer Private Sub Form_Load() Set m_Server = New cWebSocketServer m_Server.Listen 8080 End Sub Private Sub m_Server_OnClientConnect(ByVal ClientID As String, ByVal RemoteAddress As String, ByVal RemotePort As Long) Debug.Print ClientID & " 加入了聊天室" ' 通知其他用户 m_Server.BroadcastText "[系统] " & ClientID & " 加入了聊天室", ClientID ' 发送欢迎消息 m_Server.SendText ClientID, "欢迎来到聊天室！当前在线: " & m_Server.ClientCount & " 人" End Sub Private Sub m_Server_OnClientDisconnect(ByVal ClientID As String, ByVal Reason As String) Debug.Print ClientID & " 离开了聊天室" m_Server.BroadcastText "[系统] " & ClientID & " 离开了聊天室" End Sub Private Sub m_Server_OnClientTextMessage(ByVal ClientID As String, ByVal Message As String) ' 广播给所有用户 m_Server.BroadcastText ClientID & ": " & Message, ClientID Debug.Print ClientID & ": " & Message End Sub Private Sub Form_Unload(Cancel As Integer) m_Server.StopServer End Sub ``` ### 客户端代码 ```vb Option Explicit Private WithEvents m_Client As cWebSocketClient Private m_sUsername As String Private Sub Form_Load() Set m_Client = New cWebSocketClient m_sUsername = "用户" & CStr(Int(Rnd * 1000)) txtURL.Text = "ws://127.0.0.1:8080" End Sub Private Sub cmdConnect_Click() m_Client.Connect txtURL.Text End Sub Private Sub cmdSend_Click() If m_Client.State = WS_STATE_OPEN Then m_Client.SendText txtMessage.Text txtMessage.Text = "" End If End Sub Private Sub m_Client_OnOpen() Debug.Print "已连接到聊天室" UpdateUI True End Sub Private Sub m_Client_OnTextMessage(ByVal Message As String) txtChat.Text = txtChat.Text & Message & vbCrLf txtChat.SelStart = Len(txtChat.Text) End Sub Private Sub UpdateUI(bConnected As Boolean) cmdConnect.Enabled = Not bConnected cmdSend.Enabled = bConnected End Sub Private Sub Form_Unload(Cancel As Integer) m_Client.CloseConnection End Sub ``` *** ## 🔍 常见问题 ### Q1: 编译错误"用户定义类型未定义" **原因**: 未添加 `mWebSocketUtils.bas` 模块。 **解决**: 1. 菜单：项目 → 添加模块 2. 浏览到 `newWebsocket/mWebSocketUtils.bas` 3. 添加到项目 *** ### Q2: 连接失败"无法解析主机名" **原因**: URL 格式错误或网络问题。 **解决**: * 检查 URL 格式：`ws://host:port` * 确保服务端已启动 * 使用 `127.0.0.1` 而非 `localhost` *** ### Q3: 握手失败"Handshake failed" **原因**: * 服务端未实现 WebSocket 握手 * 端口被其他程序占用 * 防火墙阻止 **解决**: * 确保使用 WebSocket 类库的服务端 * 更换端口 * 检查防火墙设置 *** ### Q4: 收到乱码 **原因**: 编码问题。 **解决**: WebSocket 类库自动处理 UTF-8 编码，不需要手动转换。 *** ### Q5: 如何发送二进制数据 ```vb ' 发送二进制数据 Dim baData() As Byte baData = LoadFile("image.png") m_Client.SendBinary baData ' 接收二进制数据 Private Sub m_Client_OnBinaryMessage(Data() As Byte) Debug.Print "收到 " & (UBound(Data) + 1) & " 字节" SaveFile Data, "received.png" End Sub ``` *** ### Q6: 如何实现自动重连 ```vb Private WithEvents m_Client As cWebSocketClient Private WithEvents tmrReconnect As Timer Private m_bAutoReconnect As Boolean Private m_sServerURL As String Private Sub Form_Load() Set m_Client = New cWebSocketClient Set tmrReconnect = New Timer tmrReconnect.Interval = 5000 ' 5 秒后重连 m_bAutoReconnect = True m_sServerURL = "ws://127.0.0.1:8080" ConnectToServer End Sub Private Sub ConnectToServer() If m_Client.State = WS_STATE_CLOSED Then m_Client.Connect m_sServerURL End If End Sub Private Sub m_Client_OnClose(ByVal Code As WsCloseCode, ByVal Reason As String) Debug.Print "连接关闭: " & Reason If m_bAutoReconnect Then Debug.Print "5 秒后重连..." tmrReconnect.Enabled = True End If End Sub Private Sub tmrReconnect_Timer() tmrReconnect.Enabled = False ConnectToServer End Sub ``` *** ## 📚 下一步 * 查看 [client.md](./client.md) 了解客户端详细 API * 查看 [server.md](./server.md) 了解服务端详细 API * 查看 [advanced.md](./advanced.md) 了解高级功能 *** **最后更新**: 2026-01-10 --- --- url: /zh/vbman/database/quickstart.md --- # 快速入门 本指南将帮助您快速上手 cDataBase 类库，创建基本的数据库应用程序。 *** ## ? 前置准备 ### 必需文件 确保以下文件已添加到项目中： | 文件 | 位置 | 说明 | | -------------------------------------------- | -------- | ----------------- | | `VBMAN.dll` | 项目引用 | 编译后的 COM 组件 | | `Microsoft ActiveX Data Objects 2.8 Library` | 项目引用 | ADO 核心库 | ### 添加到项目 1. 打开 VB6 项目 2. 菜单：**项目** → **引用** 3. 勾选以下引用： * ? **VBMAN** (VBMAN.dll) * ? **Microsoft ActiveX Data Objects 2.8 Library** *** ## ? 客户端快速入门 ### 步骤 1：创建窗体 创建一个新窗体，添加以下控件： * 1 个 TextBox (`txtLog`) - 显示日志（MultiLine = True） * 1 个 CommandButton (`cmdConnect`) - 连接数据库 * 1 个 CommandButton (`cmdQuery`) - 执行查询 ### 步骤 2：编写代码 ```vb Option Explicit ' 声明数据库对象（使用 VBMAN.dll 中的类） Private WithEvents m_DB As VBMAN.cDataBase Private Sub Form_Load() ' 创建数据库对象 Set m_DB = New VBMAN.cDataBase ' 连接 SQL Server 数据库 If m_DB.Connect(VBMAN.enumDbType_MsSql, _ "127.0.0.1,1433", _ "sa", _ "Sa123456", _ "master") Then LogMessage "数据库连接成功" Else LogMessage "数据库连接失败: " & m_DB.LastErr End If End Sub Private Sub cmdQuery_Click() On Error GoTo EH ' 执行查询 If m_DB.Sql("SELECT TOP 10 * FROM sys.tables").Query Then ' 获取结果集 Dim i As Long For i = 1 To m_DB.Rows.Count LogMessage "表名: " & m_DB.Rows(i)("name") Next Else LogMessage "查询失败: " & m_DB.LastErr End If Exit Sub EH: LogMessage "错误: " & Err.Description End Sub ' ====== 辅助函数 ====== Private Sub LogMessage(sMessage As String) txtLog.Text = txtLog.Text & Format$(Now, "hh:mm:ss") & " - " & sMessage & vbCrLf txtLog.SelStart = Len(txtLog.Text) End Sub Private Sub Form_Unload(Cancel As Integer) ' 断开连接 If Not m_DB Is Nothing Then m_DB.DisConnect End If End Sub ``` ### 步骤 3：运行测试 1. 按 F5 运行程序 2. 点击"连接数据库" 3. 点击"执行查询" 4. 查看日志输出 *** ## ? 服务端快速入门 ### 步骤 1：创建窗体 创建一个新窗体，添加以下控件： * 1 个 TextBox (`txtPort`) - 端口号 * 1 个 CommandButton (`cmdStart`) - 启动服务 * 1 个 ListBox (`lstResults`) - 显示结果 * 1 个 TextBox (`txtLog`) - 显示日志 ### 步骤 2：编写代码 ```vb Option Explicit Private WithEvents m_DB As VBMAN.cDataBase Private Sub Form_Load() Set m_DB = New VBMAN.cDataBase txtPort.Text = "1433" End Sub Private Sub cmdStart_Click() On Error GoTo EH ' 连接数据库 If m_DB.Connect(VBMAN.enumDbType_MsSql, _ "127.0.0.1," & txtPort.Text, _ "sa", _ "Sa123456", _ "master") Then LogMessage "数据库服务已启动" LoadData Else LogMessage "启动失败: " & m_DB.LastErr End If Exit Sub EH: LogMessage "错误: " & Err.Description End Sub Private Sub LoadData() ' 查询数据 If m_DB.Sql("SELECT name FROM sys.tables ORDER BY name").Fetch Then Dim i As Long lstResults.Clear For i = 1 To m_DB.Rows.Count lstResults.AddItem m_DB.Rows(i)("name") Next LogMessage "已加载 " & m_DB.Rows.Count & " 条记录" End If End Sub ' ====== 辅助函数 ====== Private Sub LogMessage(sMessage As String) txtLog.Text = txtLog.Text & Format$(Now, "hh:mm:ss") & " - " & sMessage & vbCrLf txtLog.SelStart = Len(txtLog.Text) End Sub Private Sub Form_Unload(Cancel As Integer) If Not m_DB Is Nothing Then m_DB.DisConnect End If End Sub ``` *** ## ? 完整示例：用户管理 ### 服务端代码 ```vb Option Explicit Private WithEvents m_DB As VBMAN.cDataBase Private Sub Form_Load() Set m_DB = New VBMAN.cDataBase ' 连接数据库 m_DB.Connect VBMAN.enumDbType_MsSql, "127.0.0.1,1433", "sa", "pwd", "mydb" ' 创建用户表（如果不存在） CreateUserTable ' 加载用户列表 LoadUsers End Sub ' 创建用户表 Private Sub CreateUserTable() Dim sSql As String sSql = "IF NOT EXISTS (SELECT * FROM sys.tables WHERE name = 'users') " & _ "CREATE TABLE users (id INT IDENTITY(1,1) PRIMARY KEY, " & _ "name NVARCHAR(50), age INT, email NVARCHAR(100))" m_DB.Sql(sSql).Exec End Sub ' 加载用户列表 Private Sub LoadUsers() If m_DB.Sql("SELECT * FROM users ORDER BY id").Fetch Then Dim i As Long lstUsers.Clear For i = 1 To m_DB.Rows.Count lstUsers.AddItem m_DB.Rows(i)("name") & " - " & m_DB.Rows(i)("age") Next End If End Sub ' 添加用户 Private Sub cmdAddUser_Click() ' 使用参数化查询防止 SQL 注入 If m_DB.Sql("INSERT INTO users (name, age, email) VALUES (?, ?, ?)") _ .Param("name", txtName.Text, adVarWChar) _ .Param("age", CLng(txtAge.Text), adInteger) _ .Param("email", txtEmail.Text, adVarWChar) _ .ExecParam Then LogMessage "用户添加成功，ID: " & m_DB.LastInsertId LoadUsers Else LogMessage "添加失败: " & m_DB.LastErr End If End Sub ' 删除用户 Private Sub cmdDeleteUser_Click() If m_DB.Sql("DELETE FROM users WHERE id = ?") _ .Param("id", CLng(txtId.Text), adInteger) _ .ExecParam Then LogMessage "用户删除成功" LoadUsers End If End Sub Private Sub LogMessage(sMessage As String) txtLog.Text = txtLog.Text & Format$(Now, "hh:mm:ss") & " - " & sMessage & vbCrLf txtLog.SelStart = Len(txtLog.Text) End Sub ``` ### 客户端代码 ```vb Option Explicit Private WithEvents m_DB As VBMAN.cDataBase Private Sub Form_Load() Set m_DB = New VBMAN.cDataBase m_DB.Connect VBMAN.enumDbType_MsSql, "127.0.0.1,1433", "sa", "pwd", "mydb" LoadUsers End Sub Private Sub LoadUsers() ' 使用分页查询 If m_DB.Sql("SELECT * FROM users").Page(1, 10).Fetch Then Dim i As Long lstUsers.Clear For i = 1 To m_DB.Rows.Count lstUsers.AddItem m_DB.Rows(i)("name") & " - " & m_DB.Rows(i)("age") Next End If End Sub Private Sub cmdSearch_Click() ' 使用参数化查询搜索 If m_DB.Sql("SELECT * FROM users WHERE name LIKE ?") _ .Param("name", "%" & txtSearch.Text & "%", adVarWChar) _ .QueryParam Then Dim i As Long lstResults.Clear For i = 1 To m_DB.Rows.Count lstResults.AddItem m_DB.Rows(i)("name") Next End If End Sub ``` *** ## ? 常见问题 ### Q1: 编译错误"用户定义类型未定义" **原因**: 未引用 `VBMAN.dll` 或 `Microsoft ActiveX Data Objects 2.8 Library` **解决**: 1. 菜单：**项目** → **引用** 2. 勾选 **VBMAN** 和 **Microsoft ActiveX Data Objects 2.8 Library** *** ### Q2: 连接失败"无法连接到数据库" **原因**: 连接字符串错误或数据库服务未启动 **解决**: * 检查数据库服务是否运行 * 验证连接参数（地址、端口、用户名、密码） * 检查防火墙设置 *** ### Q3: 查询返回空结果 **原因**: SQL 语句错误或表不存在 **解决**: * 使用 `m_DB.LastErr` 查看错误信息 * 检查 SQL 语句语法 * 验证表名和字段名 *** ### Q4: 如何执行事务操作 ```vb ' 开始事务 m_DB.TransBegin ' 执行多个操作 m_DB.Sql("INSERT INTO table1 ...").Exec m_DB.Sql("INSERT INTO table2 ...").Exec ' 提交事务（失败自动回滚） If m_DB.TransCommit Then Debug.Print "成功" Else Debug.Print "失败: " & m_DB.LastErr End If ``` *** ### Q5: 如何防止 SQL 注入 ```vb ' ? 错误：直接拼接 SQL（不安全） m_DB.Sql("SELECT * FROM users WHERE name = '" & txtName.Text & "'").Query ' ? 正确：使用参数化查询（安全） m_DB.Sql("SELECT * FROM users WHERE name = ?") _ .Param("name", txtName.Text, adVarWChar) _ .QueryParam ``` *** ### Q6: 如何获取最后插入的 ID ```vb ' 插入数据 m_DB.Sql("INSERT INTO users (name) VALUES (?)") _ .Param("name", "张三", adVarWChar) _ .ExecParam ' 获取最后插入的 ID Dim lId As Variant lId = m_DB.LastInsertId Debug.Print "新用户 ID: " & lId ``` *** ## ? 下一步 * 查看 [连接管理](./connection.md) 了解数据库连接 * 查看 [查询操作](./query.md) 了解查询功能 * 查看 [参数化查询](./parameterized.md) 了解安全查询 * 查看 [高级功能](./advanced.md) 了解最佳实践 *** **最后更新**: 2026-01-21 --- --- url: /zh/emoji/0100-017F.md --- # 拉丁文扩展-A 本文档包含了Unicode基本多文种平面中的拉丁文扩展-A字符，范围为U+0100至U+017F。这个范围包括了带有变音符号的拉丁字母，主要用于欧洲多种语言的书写。 | 字符 | Unicode | VB函数值 | 名称 | |:---:|:---:|:---:|:---| | Ā | U+0100 | ChrW(\&H0100) | 带长音符的大写字母A | | ā | U+0101 | ChrW(\&H0101) | 带长音符的小写字母a | | Ă | U+0102 | ChrW(\&H0102) | 带短音符的大写字母A | | ă | U+0103 | ChrW(\&H0103) | 带短音符的小写字母a | | Ą | U+0104 | ChrW(\&H0104) | 带下尾形的大写字母A | | ą | U+0105 | ChrW(\&H0105) | 带下尾形的小写字母a | | Ć | U+0106 | ChrW(\&H0106) | 带锐音符的大写字母C | | ć | U+0107 | ChrW(\&H0107) | 带锐音符的小写字母c | | Ĉ | U+0108 | ChrW(\&H0108) | 带扬抑符的大写字母C | | ĉ | U+0109 | ChrW(\&H0109) | 带扬抑符的小写字母c | | Ċ | U+010A | ChrW(\&H010A) | 带点的大写字母C | | ċ | U+010B | ChrW(\&H010B) | 带点的小写字母c | | Č | U+010C | ChrW(\&H010C) | 带抑音符的大写字母C | | č | U+010D | ChrW(\&H010D) | 带抑音符的小写字母c | | Ď | U+010E | ChrW(\&H010E) | 带抑音符的大写字母D | | ď | U+010F | ChrW(\&H010F) | 带抑音符的小写字母d | | Đ | U+0110 | ChrW(\&H0110) | 带划线的大写字母D | | đ | U+0111 | ChrW(\&H0111) | 带划线的小写字母d | | Ē | U+0112 | ChrW(\&H0112) | 带长音符的大写字母E | | ē | U+0113 | ChrW(\&H0113) | 带长音符的小写字母e | | Ĕ | U+0114 | ChrW(\&H0114) | 带短音符的大写字母E | | ĕ | U+0115 | ChrW(\&H0115) | 带短音符的小写字母e | | Ė | U+0116 | ChrW(\&H0116) | 带点的大写字母E | | ė | U+0117 | ChrW(\&H0117) | 带点的小写字母e | | Ę | U+0118 | ChrW(\&H0118) | 带下尾形的大写字母E | | ę | U+0119 | ChrW(\&H0119) | 带下尾形的小写字母e | | Ě | U+011A | ChrW(\&H011A) | 带抑音符的大写字母E | | ě | U+011B | ChrW(\&H011B) | 带抑音符的小写字母e | | Ĝ | U+011C | ChrW(\&H011C) | 带扬抑符的大写字母G | | ĝ | U+011D | ChrW(\&H011D) | 带扬抑符的小写字母g | | Ğ | U+011E | ChrW(\&H011E) | 带短音符的大写字母G | | ğ | U+011F | ChrW(\&H011F) | 带短音符的小写字母g | | Ġ | U+0120 | ChrW(\&H0120) | 带点的大写字母G | | ġ | U+0121 | ChrW(\&H0121) | 带点的小写字母g | | Ģ | U+0122 | ChrW(\&H0122) | 带下加符的大写字母G | | ģ | U+0123 | ChrW(\&H0123) | 带下加符的小写字母g | | Ĥ | U+0124 | ChrW(\&H0124) | 带扬抑符的大写字母H | | ĥ | U+0125 | ChrW(\&H0125) | 带扬抑符的小写字母h | | Ħ | U+0126 | ChrW(\&H0126) | 带划线的大写字母H | | ħ | U+0127 | ChrW(\&H0127) | 带划线的小写字母h | | Ĩ | U+0128 | ChrW(\&H0128) | 带波浪符的大写字母I | | ĩ | U+0129 | ChrW(\&H0129) | 带波浪符的小写字母i | | Ī | U+012A | ChrW(\&H012A) | 带长音符的大写字母I | | ī | U+012B | ChrW(\&H012B) | 带长音符的小写字母i | | Ĭ | U+012C | ChrW(\&H012C) | 带短音符的大写字母I | | ĭ | U+012D | ChrW(\&H012D) | 带短音符的小写字母i | | Į | U+012E | ChrW(\&H012E) | 带下尾形的大写字母I | | į | U+012F | ChrW(\&H012F) | 带下尾形的小写字母i | | İ | U+0130 | ChrW(\&H0130) | 带点的大写字母I | | ı | U+0131 | ChrW(\&H0131) | 无点的小写字母i | | IJ | U+0132 | ChrW(\&H0132) | 大写连字IJ | | ij | U+0133 | ChrW(\&H0133) | 小写连字ij | | Ĵ | U+0134 | ChrW(\&H0134) | 带扬抑符的大写字母J | | ĵ | U+0135 | ChrW(\&H0135) | 带扬抑符的小写字母j | | Ķ | U+0136 | ChrW(\&H0136) | 带下加符的大写字母K | | ķ | U+0137 | ChrW(\&H0137) | 带下加符的小写字母k | | ĸ | U+0138 | ChrW(\&H0138) | 小写字母kra | | Ĺ | U+0139 | ChrW(\&H0139) | 带锐音符的大写字母L | | ĺ | U+013A | ChrW(\&H013A) | 带锐音符的小写字母l | | Ļ | U+013B | ChrW(\&H013B) | 带下加符的大写字母L | | ļ | U+013C | ChrW(\&H013C) | 带下加符的小写字母l | | Ľ | U+013D | ChrW(\&H013D) | 带抑音符的大写字母L | | ľ | U+013E | ChrW(\&H013E) | 带抑音符的小写字母l | | Ŀ | U+013F | ChrW(\&H013F) | 带中点的大写字母L | | ŀ | U+0140 | ChrW(\&H0140) | 带中点的小写字母l | | Ł | U+0141 | ChrW(\&H0141) | 带划线的大写字母L | | ł | U+0142 | ChrW(\&H0142) | 带划线的小写字母l | | Ń | U+0143 | ChrW(\&H0143) | 带锐音符的大写字母N | | ń | U+0144 | ChrW(\&H0144) | 带锐音符的小写字母n | | Ņ | U+0145 | ChrW(\&H0145) | 带下加符的大写字母N | | ņ | U+0146 | ChrW(\&H0146) | 带下加符的小写字母n | | Ň | U+0147 | ChrW(\&H0147) | 带抑音符的大写字母N | | ň | U+0148 | ChrW(\&H0148) | 带抑音符的小写字母n | | ʼn | U+0149 | ChrW(\&H0149) | 带前撇号的小写字母n | | Ŋ | U+014A | ChrW(\&H014A) | 大写字母Eng | | ŋ | U+014B | ChrW(\&H014B) | 小写字母eng | | Ō | U+014C | ChrW(\&H014C) | 带长音符的大写字母O | | ō | U+014D | ChrW(\&H014D) | 带长音符的小写字母o | | Ŏ | U+014E | ChrW(\&H014E) | 带短音符的大写字母O | | ŏ | U+014F | ChrW(\&H014F) | 带短音符的小写字母o | | Ő | U+0150 | ChrW(\&H0150) | 带双锐音符的大写字母O | | ő | U+0151 | ChrW(\&H0151) | 带双锐音符的小写字母o | | Œ | U+0152 | ChrW(\&H0152) | 大写连字OE | | œ | U+0153 | ChrW(\&H0153) | 小写连字oe | | Ŕ | U+0154 | ChrW(\&H0154) | 带锐音符的大写字母R | | ŕ | U+0155 | ChrW(\&H0155) | 带锐音符的小写字母r | | Ŗ | U+0156 | ChrW(\&H0156) | 带下加符的大写字母R | | ŗ | U+0157 | ChrW(\&H0157) | 带下加符的小写字母r | | Ř | U+0158 | ChrW(\&H0158) | 带抑音符的大写字母R | | ř | U+0159 | ChrW(\&H0159) | 带抑音符的小写字母r | | Ś | U+015A | ChrW(\&H015A) | 带锐音符的大写字母S | | ś | U+015B | ChrW(\&H015B) | 带锐音符的小写字母s | | Ŝ | U+015C | ChrW(\&H015C) | 带扬抑符的大写字母S | | ŝ | U+015D | ChrW(\&H015D) | 带扬抑符的小写字母s | | Ş | U+015E | ChrW(\&H015E) | 带下加符的大写字母S | | ş | U+015F | ChrW(\&H015F) | 带下加符的小写字母s | | Š | U+0160 | ChrW(\&H0160) | 带抑音符的大写字母S | | š | U+0161 | ChrW(\&H0161) | 带抑音符的小写字母s | | Ţ | U+0162 | ChrW(\&H0162) | 带下加符的大写字母T | | ţ | U+0163 | ChrW(\&H0163) | 带下加符的小写字母t | | Ť | U+0164 | ChrW(\&H0164) | 带抑音符的大写字母T | | ť | U+0165 | ChrW(\&H0165) | 带抑音符的小写字母t | | Ŧ | U+0166 | ChrW(\&H0166) | 带划线的大写字母T | | ŧ | U+0167 | ChrW(\&H0167) | 带划线的小写字母t | | Ũ | U+0168 | ChrW(\&H0168) | 带波浪符的大写字母U | | ũ | U+0169 | ChrW(\&H0169) | 带波浪符的小写字母u | | Ū | U+016A | ChrW(\&H016A) | 带长音符的大写字母U | | ū | U+016B | ChrW(\&H016B) | 带长音符的小写字母u | | Ŭ | U+016C | ChrW(\&H016C) | 带短音符的大写字母U | | ŭ | U+016D | ChrW(\&H016D) | 带短音符的小写字母u | | Ů | U+016E | ChrW(\&H016E) | 带圆圈的大写字母U | | ů | U+016F | ChrW(\&H016F) | 带圆圈的小写字母u | | Ű | U+0170 | ChrW(\&H0170) | 带双锐音符的大写字母U | | ű | U+0171 | ChrW(\&H0171) | 带双锐音符的小写字母u | | Ų | U+0172 | ChrW(\&H0172) | 带下尾形的大写字母U | | ų | U+0173 | ChrW(\&H0173) | 带下尾形的小写字母u | | Ŵ | U+0174 | ChrW(\&H0174) | 带扬抑符的大写字母W | | ŵ | U+0175 | ChrW(\&H0175) | 带扬抑符的小写字母w | | Ŷ | U+0176 | ChrW(\&H0176) | 带扬抑符的大写字母Y | | ŷ | U+0177 | ChrW(\&H0177) | 带扬抑符的小写字母y | | Ÿ | U+0178 | ChrW(\&H0178) | 带分音符的大写字母Y | | Ź | U+0179 | ChrW(\&H0179) | 带锐音符的大写字母Z | | ź | U+017A | ChrW(\&H017A) | 带锐音符的小写字母z | | Ż | U+017B | ChrW(\&H017B) | 带点的大写字母Z | | ż | U+017C | ChrW(\&H017C) | 带点的小写字母z | | Ž | U+017D | ChrW(\&H017D) | 带抑音符的大写字母Z | | ž | U+017E | ChrW(\&H017E) | 带抑音符的小写字母z | | ſ | U+017F | ChrW(\&H017F) | 长小写字母s | --- --- url: /zh/emoji/0180-024F.md --- # 拉丁文扩展-B 本文档包含了Unicode基本多文种平面中的拉丁文扩展-B字符，范围为U+0180至U+024F。这个范围包括了用于非欧洲语言转写、方言书写和语音学标记的拉丁字母。 | 字符 | Unicode | VB函数值 | 名称 | |:---:|:---:|:---:|:---| | ƀ | U+0180 | ChrW(\&H0180) | 带横线的小写字母b | | Ɓ | U+0181 | ChrW(\&H0181) | 大写字母B带钩 | | Ƃ | U+0182 | ChrW(\&H0182) | 大写字母B带尾形 | | ƃ | U+0183 | ChrW(\&H0183) | 小写字母b带尾形 | | Ƅ | U+0184 | ChrW(\&H0184) | 大写字母音调六 | | ƅ | U+0185 | ChrW(\&H0185) | 小写字母音调六 | | Ɔ | U+0186 | ChrW(\&H0186) | 大写字母开放O | | Ƈ | U+0187 | ChrW(\&H0187) | 大写字母C带钩 | | ƈ | U+0188 | ChrW(\&H0188) | 小写字母c带钩 | | Ɖ | U+0189 | ChrW(\&H0189) | 大写字母非洲D | | Ɗ | U+018A | ChrW(\&H018A) | 大写字母D带钩 | | Ƌ | U+018B | ChrW(\&H018B) | 大写字母D带尾形 | | ƌ | U+018C | ChrW(\&H018C) | 小写字母d带尾形 | | ƍ | U+018D | ChrW(\&H018D) | 小写字母转向delta | | Ǝ | U+018E | ChrW(\&H018E) | 大写字母反向E | | Ə | U+018F | ChrW(\&H018F) | 大写字母Schwa | | Ɛ | U+0190 | ChrW(\&H0190) | 大写字母开放E | | Ƒ | U+0191 | ChrW(\&H0191) | 大写字母F带钩 | | ƒ | U+0192 | ChrW(\&H0192) | 小写字母f带钩 | | Ɠ | U+0193 | ChrW(\&H0193) | 大写字母G带钩 | | Ɣ | U+0194 | ChrW(\&H0194) | 大写字母伽马 | | ƕ | U+0195 | ChrW(\&H0195) | 小写字母hv | | Ɩ | U+0196 | ChrW(\&H0196) | 大写字母Iota | | Ɨ | U+0197 | ChrW(\&H0197) | 大写字母I带笔划 | | Ƙ | U+0198 | ChrW(\&H0198) | 大写字母K带钩 | | ƙ | U+0199 | ChrW(\&H0199) | 小写字母k带钩 | | ƚ | U+019A | ChrW(\&H019A) | 小写字母l带横线 | | ƛ | U+019B | ChrW(\&H019B) | 小写字母lambda带笔划 | | Ɯ | U+019C | ChrW(\&H019C) | 大写字母转向M | | Ɲ | U+019D | ChrW(\&H019D) | 大写字母N带左钩 | | ƞ | U+019E | ChrW(\&H019E) | 小写字母n带长右腿 | | Ɵ | U+019F | ChrW(\&H019F) | 大写字母O带中线 | | Ơ | U+01A0 | ChrW(\&H01A0) | 大写字母O带角 | | ơ | U+01A1 | ChrW(\&H01A1) | 小写字母o带角 | | Ƣ | U+01A2 | ChrW(\&H01A2) | 大写字母OI | | ƣ | U+01A3 | ChrW(\&H01A3) | 小写字母oi | | Ƥ | U+01A4 | ChrW(\&H01A4) | 大写字母P带钩 | | ƥ | U+01A5 | ChrW(\&H01A5) | 小写字母p带钩 | | Ʀ | U+01A6 | ChrW(\&H01A6) | 大写字母YR | | Ƨ | U+01A7 | ChrW(\&H01A7) | 大写字母音调2 | | ƨ | U+01A8 | ChrW(\&H01A8) | 小写字母音调2 | | Ʃ | U+01A9 | ChrW(\&H01A9) | 大写字母Esh | | ƪ | U+01AA | ChrW(\&H01AA) | 小写字母反向Esh带环 | | ƫ | U+01AB | ChrW(\&H01AB) | 小写字母t带上勾 | | Ƭ | U+01AC | ChrW(\&H01AC) | 大写字母T带钩 | | ƭ | U+01AD | ChrW(\&H01AD) | 小写字母t带钩 | | Ʈ | U+01AE | ChrW(\&H01AE) | 大写字母T带翻转 | | Ư | U+01AF | ChrW(\&H01AF) | 大写字母U带角 | | ư | U+01B0 | ChrW(\&H01B0) | 小写字母u带角 | | Ʊ | U+01B1 | ChrW(\&H01B1) | 大写字母倒置V | | Ʋ | U+01B2 | ChrW(\&H01B2) | 大写字母V带钩 | | Ƴ | U+01B3 | ChrW(\&H01B3) | 大写字母Y带钩 | | ƴ | U+01B4 | ChrW(\&H01B4) | 小写字母y带钩 | | Ƶ | U+01B5 | ChrW(\&H01B5) | 大写字母Z带笔划 | | ƶ | U+01B6 | ChrW(\&H01B6) | 小写字母z带笔划 | | Ʒ | U+01B7 | ChrW(\&H01B7) | 大写字母Ezh | | Ƹ | U+01B8 | ChrW(\&H01B8) | 大写字母Ezh反向 | | ƹ | U+01B9 | ChrW(\&H01B9) | 小写字母ezh反向 | | ƺ | U+01BA | ChrW(\&H01BA) | 小写字母ezh带尾 | | ƻ | U+01BB | ChrW(\&H01BB) | 带点的字母音调2 | | Ƽ | U+01BC | ChrW(\&H01BC) | 大写字母音调5 | | ƽ | U+01BD | ChrW(\&H01BD) | 小写字母音调5 | | ƾ | U+01BE | ChrW(\&H01BE) | 小写字母倒置音标Glottal Stop | | ƿ | U+01BF | ChrW(\&H01BF) | 小写字母Wynn | | ǀ | U+01C0 | ChrW(\&H01C0) | 拉丁字母牙齿咬合音 | | ǁ | U+01C1 | ChrW(\&H01C1) | 拉丁字母侧向咔嗒音 | | ǂ | U+01C2 | ChrW(\&H01C2) | 拉丁字母齿龈咔嗒音 | | ǃ | U+01C3 | ChrW(\&H01C3) | 拉丁字母逆牙咔嗒音 | | DŽ | U+01C4 | ChrW(\&H01C4) | 大写连字DZ带抑音符 | | Dž | U+01C5 | ChrW(\&H01C5) | 大小写连字Dz带抑音符 | | dž | U+01C6 | ChrW(\&H01C6) | 小写连字dz带抑音符 | | LJ | U+01C7 | ChrW(\&H01C7) | 大写连字LJ | | Lj | U+01C8 | ChrW(\&H01C8) | 大小写连字Lj | | lj | U+01C9 | ChrW(\&H01C9) | 小写连字lj | | NJ | U+01CA | ChrW(\&H01CA) | 大写连字NJ | | Nj | U+01CB | ChrW(\&H01CB) | 大小写连字Nj | | nj | U+01CC | ChrW(\&H01CC) | 小写连字nj | | Ǎ | U+01CD | ChrW(\&H01CD) | 带抑音符的大写字母A | | ǎ | U+01CE | ChrW(\&H01CE) | 带抑音符的小写字母a | | Ǐ | U+01CF | ChrW(\&H01CF) | 带抑音符的大写字母I | | ǐ | U+01D0 | ChrW(\&H01D0) | 带抑音符的小写字母i | | Ǒ | U+01D1 | ChrW(\&H01D1) | 带抑音符的大写字母O | | ǒ | U+01D2 | ChrW(\&H01D2) | 带抑音符的小写字母o | | Ǔ | U+01D3 | ChrW(\&H01D3) | 带抑音符的大写字母U | | ǔ | U+01D4 | ChrW(\&H01D4) | 带抑音符的小写字母u | | Ǖ | U+01D5 | ChrW(\&H01D5) | 带长音符和分音符的大写字母U | | ǖ | U+01D6 | ChrW(\&H01D6) | 带长音符和分音符的小写字母u | | Ǘ | U+01D7 | ChrW(\&H01D7) | 带锐音符和分音符的大写字母U | | ǘ | U+01D8 | ChrW(\&H01D8) | 带锐音符和分音符的小写字母u | | Ǚ | U+01D9 | ChrW(\&H01D9) | 带抑音符和分音符的大写字母U | | ǚ | U+01DA | ChrW(\&H01DA) | 带抑音符和分音符的小写字母u | | Ǜ | U+01DB | ChrW(\&H01DB) | 带重音符和分音符的大写字母U | | ǜ | U+01DC | ChrW(\&H01DC) | 带重音符和分音符的小写字母u | | ǝ | U+01DD | ChrW(\&H01DD) | 小写字母转向e | | Ǟ | U+01DE | ChrW(\&H01DE) | 带长音符和分音符的大写字母A | | ǟ | U+01DF | ChrW(\&H01DF) | 带长音符和分音符的小写字母a | | Ǡ | U+01E0 | ChrW(\&H01E0) | 带点和长音符的大写字母A | | ǡ | U+01E1 | ChrW(\&H01E1) | 带点和长音符的小写字母a | | Ǣ | U+01E2 | ChrW(\&H01E2) | 带长音符的大写连字AE | | ǣ | U+01E3 | ChrW(\&H01E3) | 带长音符的小写连字ae | | Ǥ | U+01E4 | ChrW(\&H01E4) | 带横线的大写字母G | | ǥ | U+01E5 | ChrW(\&H01E5) | 带横线的小写字母g | | Ǧ | U+01E6 | ChrW(\&H01E6) | 带抑音符的大写字母G | | ǧ | U+01E7 | ChrW(\&H01E7) | 带抑音符的小写字母g | | Ǩ | U+01E8 | ChrW(\&H01E8) | 带抑音符的大写字母K | | ǩ | U+01E9 | ChrW(\&H01E9) | 带抑音符的小写字母k | | Ǫ | U+01EA | ChrW(\&H01EA) | 带下尾形的大写字母O | | ǫ | U+01EB | ChrW(\&H01EB) | 带下尾形的小写字母o | | Ǭ | U+01EC | ChrW(\&H01EC) | 带下尾形和长音符的大写字母O | | ǭ | U+01ED | ChrW(\&H01ED) | 带下尾形和长音符的小写字母o | | Ǯ | U+01EE | ChrW(\&H01EE) | 带抑音符的大写字母Ezh | | ǯ | U+01EF | ChrW(\&H01EF) | 带抑音符的小写字母ezh | | ǰ | U+01F0 | ChrW(\&H01F0) | 带抑音符的小写字母j | | DZ | U+01F1 | ChrW(\&H01F1) | 大写连字DZ | | Dz | U+01F2 | ChrW(\&H01F2) | 大小写连字Dz | | dz | U+01F3 | ChrW(\&H01F3) | 小写连字dz | | Ǵ | U+01F4 | ChrW(\&H01F4) | 带锐音符的大写字母G | | ǵ | U+01F5 | ChrW(\&H01F5) | 带锐音符的小写字母g | | Ƕ | U+01F6 | ChrW(\&H01F6) | 大写字母Hwair | | Ƿ | U+01F7 | ChrW(\&H01F7) | 大写字母Wynn | | Ǹ | U+01F8 | ChrW(\&H01F8) | 带重音符的大写字母N | | ǹ | U+01F9 | ChrW(\&H01F9) | 带重音符的小写字母n | | Ǻ | U+01FA | ChrW(\&H01FA) | 带圆圈和锐音符的大写字母A | | ǻ | U+01FB | ChrW(\&H01FB) | 带圆圈和锐音符的小写字母a | | Ǽ | U+01FC | ChrW(\&H01FC) | 带锐音符的大写连字AE | | ǽ | U+01FD | ChrW(\&H01FD) | 带锐音符的小写连字ae | | Ǿ | U+01FE | ChrW(\&H01FE) | 带锐音符和斜线的大写字母O | | ǿ | U+01FF | ChrW(\&H01FF) | 带锐音符和斜线的小写字母o | --- --- url: /zh/emoji/0E80-0EFF.md --- # 老挝文 (Lao) 本页面展示了Unicode字符集中，位于U+0E80到U+0EFF范围的老挝文字符。老挝文是老挝的官方文字，用于书写老挝语。 | 字符 | Unicode | VB函数值 | 名称 | |:---:|:---:|:---:|:---| | ກ | U+0E81 | ChrW(\&H0E81) | 老挝文字母KO | | ຂ | U+0E82 | ChrW(\&H0E82) | 老挝文字母KHO SUNG | | ຄ | U+0E84 | ChrW(\&H0E84) | 老挝文字母KHO TAM | | ງ | U+0E87 | ChrW(\&H0E87) | 老挝文字母NGO | | ຈ | U+0E88 | ChrW(\&H0E88) | 老挝文字母CO | | ຉ | U+0E89 | ChrW(\&H0E89) | 老挝文字母SO TAM | | ຊ | U+0E8A | ChrW(\&H0E8A) | 老挝文字母SO SUNG | | ຍ | U+0E8D | ChrW(\&H0E8D) | 老挝文字母NYO | | ດ | U+0E94 | ChrW(\&H0E94) | 老挝文字母DO | | ຕ | U+0E95 | ChrW(\&H0E95) | 老挝文字母TO | --- --- url: /zh/packages/vbccr/bars/coolbar.md description: 冷却栏控件（CoolBar） - VBCCR 开发手册，基于源码的完整 API 参考 --- # 冷却栏控件（CoolBar） 封装 ReBar 系统控件，实现可拖拽、可调整大小的带状容器栏。 ## 枚举 ### CbrOrientationConstants | 常量 | 值 | 说明 | |------|-----|------| | CbrOrientationHorizontal | 0 | 水平方向 | | CbrOrientationVertical | 1 | 垂直方向 | ### CbrBandStyleConstants | 常量 | 值 | 说明 | |------|-----|------| | CbrBandStyleNormal | 0 | 正常样式，可调整大小 | | CbrBandStyleFixedSize | 1 | 固定大小 | ### CbrBandGripperConstants | 常量 | 值 | 说明 | |------|-----|------| | CbrBandGripperNormal | 0 | 默认抓握条 | | CbrBandGripperAlways | 1 | 始终显示抓握条 | | CbrBandGripperNever | 2 | 不显示抓握条 | ### CbrHitResultConstants | 常量 | 值 | 说明 | |------|-----|------| | CbrHitResultNoWhere | 0 | 空白区域 | | CbrHitResultCaption | 1 | 标题区域 | | CbrHitResultClient | 2 | 客户区 | | CbrHitResultGrabber | 3 | 抓握条 | | CbrHitResultChevron | 4 | 折叠箭头 | | CbrHitResultSplitter | 5 | 分隔条 | ## 属性 ### VisualStyles ```vb Property Get VisualStyles() As Boolean Property Let VisualStyles(ByVal Value As Boolean) ``` 是否启用视觉样式。 ### Enabled ```vb Property Get Enabled() As Boolean Property Let Enabled(ByVal Value As Boolean) ``` 是否可用。 ### OLEDropMode ```vb Property Get OLEDropMode() As OLEDropModeConstants Property Let OLEDropMode(ByVal Value As OLEDropModeConstants) ``` OLE 拖放模式。参见通用枚举。 ### MousePointer ```vb Property Get MousePointer() As CCMousePointerConstants Property Let MousePointer(ByVal Value As CCMousePointerConstants) ``` 鼠标指针。参见通用枚举。 ### MouseIcon ```vb Property Get MouseIcon() As IPictureDisp Property Let MouseIcon(ByVal Value As IPictureDisp) Property Set MouseIcon(ByVal Value As IPictureDisp) ``` 自定义鼠标图标。 ### MouseTrack ```vb Property Get MouseTrack() As Boolean Property Let MouseTrack(ByVal Value As Boolean) ``` 鼠标进入/离开跟踪。 ### RightToLeft ```vb Property Get RightToLeft() As Boolean Property Let RightToLeft(ByVal Value As Boolean) ``` 从右到左显示。 ### RightToLeftLayout ```vb Property Get RightToLeftLayout() As Boolean Property Let RightToLeftLayout(ByVal Value As Boolean) ``` 从右到左镜像布局。 ### RightToLeftMode ```vb Property Get RightToLeftMode() As CCRightToLeftModeConstants Property Let RightToLeftMode(ByVal Value As CCRightToLeftModeConstants) ``` 从右到左模式。参见通用枚举。 ### ImageList ```vb Property Get ImageList() As Variant Property Let ImageList(ByVal Value As Variant) Property Set ImageList(ByVal Value As Variant) ``` 关联的 ImageList 控件。 ### BackColor ```vb Property Get BackColor() As OLE_COLOR Property Let BackColor(ByVal Value As OLE_COLOR) ``` 背景色。 ### ForeColor ```vb Property Get ForeColor() As OLE_COLOR Property Let ForeColor(ByVal Value As OLE_COLOR) ``` 前景色。 ### BorderStyle ```vb Property Get BorderStyle() As Integer Property Let BorderStyle(ByVal Value As Integer) ``` 边框样式（0-无边框，1-固定单线）。 ### Orientation ```vb Property Get Orientation() As CbrOrientationConstants Property Let Orientation(ByVal Value As CbrOrientationConstants) ``` 方向。 ### BandBorders ```vb Property Get BandBorders() As Boolean Property Let BandBorders(ByVal Value As Boolean) ``` 是否在带之间显示分隔线。 ### FixedOrder ```vb Property Get FixedOrder() As Boolean Property Let FixedOrder(ByVal Value As Boolean) ``` 是否禁止用户重新排列带。 ### VariantHeight ```vb Property Get VariantHeight() As Boolean Property Let VariantHeight(ByVal Value As Boolean) ``` 是否允许带具有不同高度。 ### Picture ```vb Property Get Picture() As IPictureDisp Property Let Picture(ByVal Value As IPictureDisp) Property Set Picture(ByVal Value As IPictureDisp) ``` 背景图片。 ### DblClickToggle ```vb Property Get DblClickToggle() As Boolean Property Let DblClickToggle(ByVal Value As Boolean) ``` 双击是否切换最大化/最小化。 ### VerticalGripper ```vb Property Get VerticalGripper() As Boolean Property Let VerticalGripper(ByVal Value As Boolean) ``` 垂直方向时是否使用垂直抓握条。 ### ShowTips ```vb Property Get ShowTips() As Boolean Property Let ShowTips(ByVal Value As Boolean) ``` 是否显示工具提示。 ### DoubleBuffer ```vb Property Get DoubleBuffer() As Boolean Property Let DoubleBuffer(ByVal Value As Boolean) ``` 是否启用双缓冲减少闪烁。 ### Bands ```vb Property Get Bands() As CbrBands ``` 带的集合。 ### ContainedControls ```vb Property Get ContainedControls() As VBRUN.ContainedControls ``` 包含的控件集合。只读。 ### RowCount ```vb Property Get RowCount() As Long ``` 行数。只读。 ### hWnd / hWndUserControl / Font 参见公共属性。 ### Name / Tag / Parent / Container / Left / Top / Width / Height / Visible / ToolTipText / WhatsThisHelpID / Align / DragIcon / DragMode 参见标准扩展器属性。 ## 方法 ### Refresh ```vb Public Sub Refresh() ``` 强制重绘。 ### HitTest ```vb Public Function HitTest(ByVal X As Single, ByVal Y As Single, Optional ByRef HitResult As CbrHitResultConstants) As CbrBand ``` 命中测试，返回指定坐标处的带对象。 ### OLEDrag ```vb Public Sub OLEDrag() ``` ### Drag / ZOrder 参见标准方法。 ## 事件 ### Click ```vb Public Event Click() ``` 单击。 ### DblClick ```vb Public Event DblClick() ``` 双击。 ### Resize ```vb Public Event Resize() ``` 大小改变。 ### HeightChanged ```vb Public Event HeightChanged(ByVal NewHeight As Single) ``` 高度改变。 ### LayoutChanged ```vb Public Event LayoutChanged() ``` 布局改变。 ### MinMax ```vb Public Event MinMax(ByRef Cancel As Boolean) ``` 带即将最大化或最小化，可取消。 ### BandBeforeDrag ```vb Public Event BandBeforeDrag(ByVal Band As CbrBand, ByRef Cancel As Boolean) ``` 带即将被拖动，可取消。 ### BandAfterDrag ```vb Public Event BandAfterDrag(ByVal Band As CbrBand, ByVal NewPosition As Long) ``` 带拖动完成。 ### BandChevronPushed ```vb Public Event BandChevronPushed(ByVal Band As CbrBand, ByVal Left As Single, ByVal Top As Single, ByVal Width As Single, ByVal Height As Single) ``` 折叠箭头被点击。 ### BandMouseEnter ```vb Public Event BandMouseEnter(ByVal Band As CbrBand) ``` 鼠标进入带。 ### BandMouseLeave ```vb Public Event BandMouseLeave(ByVal Band As CbrBand) ``` 鼠标离开带。 ### MouseDown / MouseMove / MouseUp / MouseEnter / MouseLeave ### OLECompleteDrag / OLEDragDrop / OLEDragOver / OLEGiveFeedback / OLESetData / OLEStartDrag ## CbrBand 对象 带的属性和方法。 ### 属性 #### Index ```vb Property Get Index() As Long ``` 带在集合中的索引。只读。 #### Key ```vb Property Get Key() As String Property Let Key(ByVal Value As String) ``` 带的关键字。 #### Tag ```vb Property Get Tag() As Variant Property Let Tag(ByVal Value As Variant) Property Set Tag(ByVal Value As Variant) ``` 自定义数据。 #### ID ```vb Property Get ID() As Long ``` 内部标识。只读。 #### Caption ```vb Property Get Caption() As String Property Let Caption(ByVal Value As String) ``` 带标题。 #### Child ```vb Property Get Child() As Object Property Let Child(ByVal Value As Object) Property Set Child(ByVal Value As Object) ``` 带中包含的子控件。 #### Style ```vb Property Get Style() As CbrBandStyleConstants Property Let Style(ByVal Value As CbrBandStyleConstants) ``` 带样式。 #### Image ```vb Property Get Image() As Variant Property Let Image(ByVal Value As Variant) ``` ImageList 中图像的索引或关键字。 #### ImageIndex ```vb Property Get ImageIndex() As Long ``` 图像索引。只读。 #### Width ```vb Property Get Width() As Single Property Let Width(ByVal Value As Single) ``` 带宽度。Style 为 FixedSize 时只读。 #### Height ```vb Property Get Height() As Single ``` 带高度。只读。 #### MinWidth ```vb Property Get MinWidth() As Single Property Let MinWidth(ByVal Value As Single) ``` 最小宽度。 #### MinHeight ```vb Property Get MinHeight() As Single Property Let MinHeight(ByVal Value As Single) ``` 最小高度。 #### IdealWidth ```vb Property Get IdealWidth() As Single Property Let IdealWidth(ByVal Value As Single) ``` 理想宽度。 #### Gripper ```vb Property Get Gripper() As CbrBandGripperConstants Property Let Gripper(ByVal Value As CbrBandGripperConstants) ``` 抓握条样式。 #### ToolTipText ```vb Property Get ToolTipText() As String Property Let ToolTipText(ByVal Value As String) ``` 工具提示文本。需要 ShowTips 为 True。 #### UseCoolBarPicture ```vb Property Get UseCoolBarPicture() As Boolean Property Let UseCoolBarPicture(ByVal Value As Boolean) ``` 是否使用 CoolBar 的背景图片。 #### Picture ```vb Property Get Picture() As IPictureDisp Property Let Picture(ByVal Value As IPictureDisp) Property Set Picture(ByVal Value As IPictureDisp) ``` 带的背景图片。 #### UseCoolBarColors ```vb Property Get UseCoolBarColors() As Boolean Property Let UseCoolBarColors(ByVal Value As Boolean) ``` 是否使用 CoolBar 的前景/背景色。 #### BackColor ```vb Property Get BackColor() As OLE_COLOR Property Let BackColor(ByVal Value As OLE_COLOR) ``` 带背景色。 #### ForeColor ```vb Property Get ForeColor() As OLE_COLOR Property Let ForeColor(ByVal Value As OLE_COLOR) ``` 带前景色。 #### NewRow ```vb Property Get NewRow() As Boolean Property Let NewRow(ByVal Value As Boolean) ``` 是否在新行开始。 #### Visible ```vb Property Get Visible() As Boolean Property Let Visible(ByVal Value As Boolean) ``` 是否可见。 #### ChildEdge ```vb Property Get ChildEdge() As Boolean Property Let ChildEdge(ByVal Value As Boolean) ``` 是否在子控件上下显示边缘。 #### UseChevron ```vb Property Get UseChevron() As Boolean Property Let UseChevron(ByVal Value As Boolean) ``` 带宽小于理想宽度时是否显示折叠箭头。 #### HideCaption ```vb Property Get HideCaption() As Boolean Property Let HideCaption(ByVal Value As Boolean) ``` 是否隐藏标题。 #### FixedBackground ```vb Property Get FixedBackground() As Boolean Property Let FixedBackground(ByVal Value As Boolean) ``` 背景图片是否固定不动。 #### Position ```vb Property Get Position() As Long Property Let Position(ByVal Value As Long) ``` 带的位置。 ### 方法 #### Maximize ```vb Public Sub Maximize() ``` 最大化带。 #### Minimize ```vb Public Sub Minimize() ``` 最小化带。 #### PushChevron ```vb Public Sub PushChevron() ``` 程序化点击折叠箭头。 ## CbrBands 集合 带的集合对象。 ### 属性 #### Item ```vb Property Get Item(ByVal Index As Variant) As CbrBand ``` 按索引或关键字获取带。 #### ItemFromPosition ```vb Property Get ItemFromPosition(ByVal Position As Long) As CbrBand ``` 按位置获取带。 #### Count ```vb Property Get Count() As Long ``` 带数量。 ### 方法 #### Add ```vb Public Function Add(Optional ByVal Index As Long, Optional ByVal Key As String, Optional ByVal Caption As String, Optional ByVal Image As Variant, Optional ByVal NewRow As Boolean, Optional ByVal Child As Variant, Optional ByVal Visible As Boolean = True) As CbrBand ``` 添加新带。 #### Remove ```vb Public Sub Remove(ByVal Index As Variant) ``` 移除带。 #### Clear ```vb Public Sub Clear() ``` 清空所有带。 #### Exists ```vb Public Function Exists(ByVal Index As Variant) As Boolean ``` 检查带是否存在。 ## CbrBandProperties 对象 带颜色属性的辅助对象。 ### 属性 #### BackColor ```vb Property Get BackColor() As OLE_COLOR Property Let BackColor(ByVal Value As OLE_COLOR) ``` 背景色。 #### ForeColor ```vb Property Get ForeColor() As OLE_COLOR Property Let ForeColor(ByVal Value As OLE_COLOR) ``` 前景色。 ## 代码示例 ### 基本用法 ```vb ' 添加带 With CoolBar1.Bands .Add Key:="Band1", Caption:="工具栏", NewRow:=True .Add Key:="Band2", Caption:="格式栏" End With ' 设置子控件 Set CoolBar1.Bands("Band1").Child = Toolbar1 ' 设置带属性 CoolBar1.Bands(1).UseChevron = True CoolBar1.Bands(1).IdealWidth = 500 ``` ### 命中测试 ```vb Private Sub CoolBar1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) Dim HitResult As CbrHitResultConstants Dim Band As CbrBand Set Band = CoolBar1.HitTest(X, Y, HitResult) If Not Band Is Nothing Then Debug.Print "点击了: " & Band.Caption End If End Sub ``` ### 折叠箭头事件 ```vb Private Sub CoolBar1_BandChevronPushed(ByVal Band As CbrBand, _ ByVal Left As Single, ByVal Top As Single, _ ByVal Width As Single, ByVal Height As Single) ' 在折叠箭头位置显示菜单 PopupMenu mnuToolbar, , Left, Top + Height End Sub ``` --- --- url: /zh/vbman/database/connection.md --- # 连接管理 本文档详细介绍 cDataBase 类的数据库连接管理功能，包括连接、断开、连接池等。 *** ## ? 目录 * [数据库连接](#数据库连接) * [支持的数据库类型](#支持的数据库类型) * [连接字符串配置](#连接字符串配置) * [连接状态管理](#连接状态管理) * [连接池管理](#连接池管理) * [错误处理](#错误处理) *** ## 数据库连接 ### Connect 方法 `Connect` 方法用于建立数据库连接。 #### 语法 ```vb Function Connect( _ ByVal DbType As enumDbType, _ Optional ByVal DbAddress As String = "127.0.0.1,1433", _ Optional ByVal username As String = "sa", _ Optional ByVal password As String = "Sa123456", _ Optional ByVal DefaultDataBase As String = "master") As Boolean ``` #### 参数说明 | 参数 | 类型 | 说明 | | ----------------- | ------------ | ----------------------------------------- | | `DbType` | `enumDbType` | 数据库类型（必需） | | `DbAddress` | `String` | 数据库地址（可选，默认 "127.0.0.1,1433"） | | `username` | `String` | 用户名（可选，默认 "sa"） | | `password` | `String` | 密码（可选，默认 "Sa123456"） | | `DefaultDataBase` | `String` | 默认数据库（可选，默认 "master"） | #### 返回值 * `True` - 连接成功（或**已经连接**，不会重复连接） * `False` - 连接失败（可通过 `LastErr` 查看错误信息） #### 重要行为 1. **已连接时直接返回 True**：如果 `IsConnect = True`，Connect 不会重复连接，直接返回 True 2. **失败时抛出异常**：连接失败会通过 `ERR.Raise` 抛出 VB 错误，建议使用 `On Error` 处理 3. **Custom 类型**：`DbAddress` 参数直接作为完整连接字符串，后续参数被忽略 #### 示例 ```vb Dim db As New VBMAN.cDataBase ' SQL Server 连接 On Error GoTo ErrHandler If db.Connect(VBMAN.enumDbType_MsSql, "127.0.0.1,1433", "sa", "password", "mydb") Then Debug.Print "连接成功" Else Debug.Print "连接失败: " & db.LastErr End If ' Custom 类型连接（传入完整 DSN） If db.Connect(VBMAN.enumDbType_Custom, _ "DRIVER={MySQL ODBC 8.0 ANSI Driver};SERVER=localhost;DATABASE=testdb;UID=root;PWD=root") Then Debug.Print "自定义连接成功" End If Exit Sub ErrHandler: Debug.Print "连接异常: " & Err.Description ``` *** ## 支持的数据库类型 ### enumDbType 枚举 ```vb Public Enum enumDbType Access = 1 ' Microsoft Access Mysql = 2 ' MySQL MsSql = 3 ' Microsoft SQL Server Csv = 4 ' CSV 文件 Custom = 5 ' 自定义连接字符串（DbAddress 参数直接传入完整 DSN） End Enum ``` ### SQL Server 连接 ```vb ' 基本连接 db.Connect VBMAN.enumDbType_MsSql, "127.0.0.1,1433", "sa", "password", "master" ' 使用命名实例 db.Connect VBMAN.enumDbType_MsSql, "SERVER\INSTANCE,1433", "sa", "password", "mydb" ' 使用 Windows 身份验证（需要修改连接字符串） ' 注意：需要在类内部修改连接字符串以支持 Windows 身份验证 ``` ### MySQL 连接 ```vb ' 基本连接（默认端口 3306） db.Connect VBMAN.enumDbType_Mysql, "localhost:3306", "root", "password", "testdb" ' 指定端口 db.Connect VBMAN.enumDbType_Mysql, "192.168.1.100:3306", "user", "pwd", "mydb" ' 使用中文逗号（自动转换） db.Connect VBMAN.enumDbType_Mysql, "localhost，3306", "root", "pwd", "testdb" ``` ### Access 连接 ```vb ' 连接 Access 数据库文件 db.Connect VBMAN.enumDbType_Access, "C:\data\mydb.mdb" ' 使用相对路径（自动转换为绝对路径） db.Connect VBMAN.enumDbType_Access, "data\mydb.mdb" ``` ### CSV 连接 ```vb ' 连接 CSV 文件目录 db.Connect VBMAN.enumDbType_Csv, "C:\data\csvfiles" ' CSV 文件会被当作表来查询 db.Sql("SELECT * FROM data.csv").Query ``` ### Custom 连接（自定义连接字符串） ```vb ' 使用自定义 DSN/连接字符串 ' DbAddress 参数直接传入完整的连接字符串，username/password/DefaultDataBase 参数不需要 db.Connect VBMAN.enumDbType_Custom, _ "DRIVER={MySQL ODBC 8.0 ANSI Driver};SERVER=10.0.0.252;DATABASE=mysql;UID=root;PWD=root" ' 使用 OLEDB 连接字符串 db.Connect VBMAN.enumDbType_Custom, _ "Provider=SQLOLEDB;Data Source=127.0.0.1;Initial Catalog=mydb;User ID=sa;Password=pwd" ' 注意：Custom 类型时，DbAddress 参数即为完整的连接字符串 ' 后面的 username、password、DefaultDataBase 参数会被忽略 ``` *** ## 连接字符串配置 ### 自动生成的连接字符串 类库会根据数据库类型自动生成连接字符串： #### SQL Server ``` Driver={SQL Server};Server=127.0.0.1,1433;Uid=sa;pwd=password;Database=mydb; ``` #### MySQL ``` Driver={MySQL ODBC 5.1 Driver};Server=localhost:3306;Uid=root;pwd=password;Database=testdb; ``` #### Access ``` Driver={Microsoft Access Driver (*.mdb)};Dbq=C:\data\mydb.mdb; ``` #### CSV ``` Driver={Microsoft Text Driver (*.txt; *.csv)};DefaultDir=C:\data\csvfiles ``` #### Custom Custom 类型直接使用 `DbAddress` 参数作为完整的连接字符串，不再自动拼接。 ### 自定义连接字符串 推荐使用 `enumDbType_Custom` 类型传入自定义连接字符串： ```vb ' 方式 1：使用 Custom 类型（推荐） db.Connect VBMAN.enumDbType_Custom, "Provider=SQLOLEDB;Data Source=...;..." ' 方式 2：直接设置 ADO Connection 对象 Set db.Conn = New ADODB.Connection db.Conn.ConnectionString = "Provider=SQLOLEDB;Data Source=...;..." db.Conn.Open db.IsConnect = True db.DatabaseType = VBMAN.enumDbType_MsSql ' 需要手动设置，影响 LastInsertId 等方法 ``` *** ## 连接状态管理 ### IsConnect 属性 `IsConnect` 属性表示当前连接状态（**公共属性，可直接读写**）。 ```vb ' 检查连接状态 If db.IsConnect Then Debug.Print "已连接" Else Debug.Print "未连接" End If ``` ### DatabaseType 属性 `DatabaseType` 属性存储当前数据库类型（**公共属性**），连接后自动设置。 ```vb ' 查看当前数据库类型 Debug.Print "当前类型: " & db.DatabaseType ' 输出如 3 (MsSql) ' 用于判断数据库类型以编写兼容代码 If db.DatabaseType = VBMAN.enumDbType_MsSql Then ' SQL Server 特定操作 End If ``` ### IsCloneInstance 属性 `IsCloneInstance` 属性标记是否为连接池克隆实例（**公共属性**）。克隆实例断开连接时不会关闭共享的 Connection 对象。 ```vb ' 检查是否为克隆实例 If db.IsCloneInstance Then Debug.Print "这是连接池克隆实例，断开时不会关闭共享连接" End If ``` ### CheckConnection 方法 `CheckConnection` 方法检查连接状态并尝试重连。 ```vb ' 检查并重连 If Not db.CheckConnection Then Debug.Print "连接已断开，尝试重连..." db.Connect VBMAN.enumDbType_MsSql, "127.0.0.1,1433", "sa", "pwd", "mydb" End If ``` ### 连接状态检查 在执行操作前检查连接状态： ```vb If Not db.IsConnect Then Debug.Print "数据库未连接" Exit Sub End If ' 执行查询 db.Sql("SELECT * FROM users").Query ``` *** ## 连接池管理 ### ConnInst 方法 `ConnInst` 方法创建或获取连接池中的数据库实例。 #### 语法 ```vb Function ConnInst(ByVal InstName As String, Optional ByVal IsCloneMasterConnection As Boolean = True) As cDataBase ``` #### 参数说明 | 参数 | 类型 | 说明 | | ------------------------- | --------- | --------------------------------- | | `InstName` | `String` | 实例名称（必需） | | `IsCloneMasterConnection` | `Boolean` | 是否克隆主连接（可选，默认 True） | #### 示例 ```vb Dim db As New VBMAN.cDataBase ' 主连接 db.Connect VBMAN.enumDbType_MsSql, "127.0.0.1,1433", "sa", "pwd", "mydb" ' 创建连接实例 1（克隆主连接） Dim db1 As VBMAN.cDataBase Set db1 = db.ConnInst("db1", True) db1.Sql("SELECT * FROM table1").Query ' 创建连接实例 2（独立连接） Dim db2 As VBMAN.cDataBase Set db2 = db.ConnInst("db2", False) db2.Connect VBMAN.enumDbType_Mysql, "localhost:3306", "root", "pwd", "testdb" db2.Sql("SELECT * FROM table2").Query ' 获取已存在的实例 Set db1 = db.ConnInst("db1") ``` ### ConnInstRemove 方法 `ConnInstRemove` 方法移除连接池中的实例。 #### 语法 ```vb Sub ConnInstRemove(Optional ByVal InstName As String) ``` #### 示例 ```vb ' 移除指定实例 db.ConnInstRemove "db1" ' 移除所有实例 db.ConnInstRemove "" ``` ### 连接池使用场景 #### 场景 1：多数据库操作 ```vb Dim db As New VBMAN.cDataBase ' 主数据库 db.Connect VBMAN.enumDbType_MsSql, "127.0.0.1,1433", "sa", "pwd", "mydb" ' 日志数据库 Dim dbLog As VBMAN.cDataBase Set dbLog = db.ConnInst("log", False) dbLog.Connect VBMAN.enumDbType_Mysql, "192.168.1.100:3306", "loguser", "pwd", "logdb" ' 使用不同的数据库 db.Sql("SELECT * FROM users").Query dbLog.Sql("INSERT INTO logs (msg) VALUES ('test')").Exec ``` #### 场景 2：动态数据库切换 ```vb Dim db As New VBMAN.cDataBase ' 根据配置动态创建连接 Function GetDatabase(sConfigName As String) As VBMAN.cDataBase Dim dbInst As VBMAN.cDataBase Set dbInst = db.ConnInst(sConfigName, False) ' 根据配置连接不同的数据库 Select Case sConfigName Case "main" dbInst.Connect VBMAN.enumDbType_MsSql, "127.0.0.1,1433", "sa", "pwd", "maindb" Case "backup" dbInst.Connect VBMAN.enumDbType_Mysql, "192.168.1.100:3306", "user", "pwd", "backupdb" End Select Set GetDatabase = dbInst End Function ' 使用 Dim dbMain As VBMAN.cDataBase Set dbMain = GetDatabase("main") dbMain.Sql("SELECT * FROM users").Query ``` *** ## 断开连接 ### DisConnect 方法 `DisConnect` 方法断开数据库连接。 #### 语法 ```vb Function DisConnect() As Boolean ``` #### 功能 * 关闭数据库连接 * 关闭记录集 * 释放资源 * 自动回滚未完成的事务 * **克隆实例**只清空本地引用，不关闭共享连接 #### 示例 ```vb ' 断开连接 If db.DisConnect Then Debug.Print "已断开连接" End If ``` ### 自动断开 类在销毁时会自动断开连接： ```vb Private Sub Form_Unload(Cancel As Integer) ' 不需要手动调用 DisConnect，类会自动处理 Set db = Nothing End Sub ``` *** ## 错误处理 ### 错误属性 | 属性 | 类型 | 说明 | | -------------------- | -------- | ------------------------ | | `LastErr` | `String` | 最后错误信息（完整描述） | | `LastErrNumber` | `Long` | 最后错误代码 | | `LastErrDescription` | `String` | 最后错误描述 | ### 错误处理示例 ```vb ' 连接错误处理 If Not db.Connect(VBMAN.enumDbType_MsSql, "127.0.0.1,1433", "sa", "pwd", "mydb") Then Debug.Print "连接失败" Debug.Print "错误代码: " & db.LastErrNumber Debug.Print "错误描述: " & db.LastErrDescription Debug.Print "完整信息: " & db.LastErr Exit Sub End If ' 查询错误处理 If Not db.Sql("SELECT * FROM users").Query Then Debug.Print "查询失败: " & db.LastErr Exit Sub End If ``` ### 常见连接错误 #### 错误 1：无法连接到服务器 ``` 错误代码: -2147467259 错误描述: [Microsoft][ODBC SQL Server Driver][DBNETLIB]SQL Server 不存在或访问被拒绝 ``` **解决方案**： * 检查数据库服务是否启动 * 验证服务器地址和端口 * 检查防火墙设置 #### 错误 2：登录失败 ``` 错误代码: -2147467259 错误描述: [Microsoft][ODBC SQL Server Driver][SQL Server]用户 'sa' 登录失败 ``` **解决方案**： * 验证用户名和密码 * 检查 SQL Server 身份验证模式 * 确认用户权限 #### 错误 3：数据库不存在 ``` 错误代码: -2147467259 错误描述: [Microsoft][ODBC SQL Server Driver][SQL Server]无法打开登录所请求的数据库 ``` **解决方案**： * 验证数据库名称 * 检查数据库是否存在 * 确认用户有访问权限 *** ## 最佳实践 ### 1. 连接管理 ```vb ' ? 推荐：在需要时连接，使用完毕后断开 Private Sub ProcessData() Dim db As New VBMAN.cDataBase If db.Connect(VBMAN.enumDbType_MsSql, "127.0.0.1,1433", "sa", "pwd", "mydb") Then ' 执行操作 db.Sql("SELECT * FROM users").Query End If db.DisConnect Set db = Nothing End Sub ``` ### 2. 连接复用 ```vb ' ? 推荐：对于频繁操作，保持连接 Private m_DB As VBMAN.cDataBase Private Sub Form_Load() Set m_DB = New VBMAN.cDataBase m_DB.Connect VBMAN.enumDbType_MsSql, "127.0.0.1,1433", "sa", "pwd", "mydb" End Sub Private Sub Form_Unload(Cancel As Integer) If Not m_DB Is Nothing Then m_DB.DisConnect Set m_DB = Nothing End If End Sub ``` ### 3. 错误处理 ```vb ' ? 推荐：始终检查返回值并处理错误 If Not db.Connect(...) Then MsgBox "连接失败: " & db.LastErr, vbCritical Exit Sub End If ``` *** **最后更新**: 2026-01-21 --- --- url: /zh/vbman/redis/connection.md --- # 连接管理 ## 基本连接 ### 连接到本地 Redis 服务器 ```vb Dim oRedis As New cRedisClient ' 连接到本地 Redis 服务器 If oRedis.Connect() Then Debug.Print "连接成功!" Else Debug.Print "连接失败: " & oRedis.LastError End If ``` ### 连接到指定服务器 ```vb Dim oRedis As New cRedisClient ' 连接到指定地址和端口 If oRedis.Connect("192.168.1.100", 6379) Then Debug.Print "连接成功!" End If ``` ### 带密码认证的连接 ```vb Dim oRedis As New cRedisClient ' 连接并使用密码认证 If oRedis.Connect("127.0.0.1", 6379, "mypassword") Then Debug.Print "连接成功!" End If ``` ### 带 ACL 用户名和密码的连接 (Redis 6.0+) ```vb Dim oRedis As New cRedisClient ' 使用 ACL 认证（需要 Redis 6.0+ 并配置了 ACL 用户） If oRedis.Connect("127.0.0.1", 6379, "mypassword", "myusername") Then Debug.Print "ACL 认证连接成功!" End If ``` ### 设置超时时间 ```vb Dim oRedis As New cRedisClient ' 设置超时时间为 10 秒 oRedis.Timeout = 10 If oRedis.Connect() Then Debug.Print "连接成功!" End If ``` ### 断开连接 ```vb oRedis.DisConnect ``` ## 连接状态检查 在执行操作前检查连接状态： ```vb ' 检查内部连接标志 If Not oRedis.Connected Then Debug.Print "未连接到 Redis 服务器" End If ' 检查 Socket 实际连接状态（更准确，会同步内部标志） If Not oRedis.IsConnected Then Debug.Print "Socket 已断开，尝试重连..." If Not oRedis.Connect() Then Debug.Print "重连失败: " & oRedis.LastError Exit Sub End If End If ``` ## 事件处理 ### OnDisconnected - 连接断开事件 ```vb ' 在类模块中声明 WithEvents 变量 Private WithEvents m_oRedis As cRedisClient Private Sub m_oRedis_OnDisconnected() Debug.Print "Redis 连接已断开" ' 可以在这里实现重连逻辑 End Sub ``` ### OnError - 错误事件 ```vb Private Sub m_oRedis_OnError(ByVal ErrorMsg As String) Debug.Print "Redis 错误: " & ErrorMsg ' 可以在这里实现错误处理逻辑 End Sub ``` ## 连接最佳实践 ### 1. 使用 Using 模式 ```vb Sub DoRedisWork() Dim oRedis As New cRedisClient If Not oRedis.Connect() Then Debug.Print "连接失败" Exit Sub End If ' 执行操作 oRedis.Set_ "key", "value" ' 确保断开连接 oRedis.DisConnect Set oRedis = Nothing End Sub ``` ### 2. 错误处理 ```vb Sub SafeRedisOperation() Dim oRedis As New cRedisClient On Error GoTo ErrorHandler If Not oRedis.Connect() Then Debug.Print "连接失败: " & oRedis.LastError Exit Sub End If ' 执行操作（命令失败会自动重连重试一次） oRedis.Set_ "key", "value" ' 检查错误 If oRedis.LastError <> "" Then Debug.Print "操作出错: " & oRedis.LastError End If Exit Sub ErrorHandler: Debug.Print "发生错误: " & Err.Description If oRedis.Connected Then oRedis.DisConnect End If End Sub ``` ### 3. 心跳保持连接 ```vb Dim oRedis As New cRedisClient ' 连接到 Redis If oRedis.Connect("127.0.0.1", 6379, "mypassword") Then ' 设置心跳间隔（秒），默认 30 秒 oRedis.HeartbeatInterval = 30 ' 启动心跳（定时发送 PING 保持连接活跃） oRedis.StartHeartbeat ' 执行业务操作... oRedis.Set_ "key", "value" ' 停止心跳并断开 oRedis.StopHeartbeat oRedis.DisConnect End If ``` ### 4. 连接池示例 ```vb ' 简单的连接管理器示例 Private m_oRedis As cRedisClient Function GetRedisConnection() As cRedisClient If m_oRedis Is Nothing Then Set m_oRedis = New cRedisClient If Not m_oRedis.Connect() Then Debug.Print "创建连接失败: " & m_oRedis.LastError Set GetRedisConnection = Nothing Exit Function End If End If ' 检查连接是否仍然有效 If Not m_oRedis.Connected Then If Not m_oRedis.Connect() Then Debug.Print "重连失败: " & m_oRedis.LastError Set GetRedisConnection = Nothing Exit Function End If End If Set GetRedisConnection = m_oRedis End Function Sub CloseRedisConnection() If Not m_oRedis Is Nothing Then m_oRedis.StopHeartbeat ' 先停止心跳 m_oRedis.DisConnect Set m_oRedis = Nothing End If End Sub ``` ## 自动重连机制 从 v1.x 起，自动重连默认开启。当连接意外断开时： * `Connected` / `IsConnected` 会返回 `False` * 发送命令时会自动尝试重连一次 * 若重连成功，命令继续执行；失败则抛出错误 * 配合心跳机制可及时检测死连接 ```vb ' 关闭自动重连（不推荐） oRedis.AutoReconnect = False ' 启用自动重连（默认） oRedis.AutoReconnect = True ``` --- --- url: /zh/CONTACT.md --- # 联系我们 欢迎通过以下方式与我们取得联系： ## 作者信息 | 项目 | 信息 | | -------- | ------------------------------------- | | 作者姓名 | 邓伟 | | 网站博客 | [https://vb6.pro](https://vb6.pro/) | | 个人站点 | [https://a-vi.com](https://a-vi.com/) | ## 联系方式 | 类型 | 内容 | | ----- | --------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------- | | 邮箱 | 215879458@qq.com | | QQ 群 | [点击加入群聊](http://qm.qq.com/cgi-bin/qm/qr?_wv=1027\&k=maQtC3a5Zxb3gMLvwpj6oE5fwmZGCOlY\&authKey=8%2FhBgSMLqADLatzXghFXO5BIBa%2BxSoHO%2FHFvtbZQk2kURUx%2FegxZukzAvhSPX6WJ\&noverify=0\&group_code=915520648) 群号：915520648 | ## 社区交流 加入我们的 QQ 群，与其他 VB6 开发者交流经验、分享技术! ::: tip 温馨提示 群内有活跃的 VB6 开发者，欢迎提问和分享您的使用心得。 ::: ## 反馈与建议 如果您在使用过程中遇到问题或有任何建议，欢迎： 1. 加入 QQ 群直接反馈 2. 发送邮件 3. 在文档站点的相关问题页提出 感谢您的关注和支持！ --- --- url: /zh/packages/vbccr/text/linklabel.md description: 链接标签控件（LinkLabel） - VBCCR 开发手册，基于源码的完整 API 参考 --- # 链接标签控件（LinkLabel） 增强型链接标签控件，支持超链接显示和自定义链接集合。 ## 枚举 ### LlbLinkBehaviorConstants | 常量 | 值 | 说明 | |------|-----|------| | LlbLinkBehaviorSystemDefault | 0 | 系统默认 | | LlbLinkBehaviorAlwaysUnderline | 1 | 始终下划线 | | LlbLinkBehaviorHoverUnderline | 2 | 悬停下划线 | | LlbLinkBehaviorNeverUnderline | 3 | 从不下划线 | ### CCAppearanceConstants 参见通用枚举。 ### CCBorderStyleConstants 参见通用枚举。 ### CCBackStyleConstants 参见通用枚举。 ### CCMousePointerConstants 参见通用枚举。 ### CCVerticalAlignmentConstants 参见通用枚举。 ### CCRightToLeftModeConstants 参见通用枚举。 ## 属性 ### Caption ```vb Property Get Caption() As String Property Let Caption(ByVal Value As String) ``` 显示文本。 ### ActiveLinkColor ```vb Property Get ActiveLinkColor() As OLE_COLOR Property Let ActiveLinkColor(ByVal Value As OLE_COLOR) ``` 活动链接颜色。 ### LinkColor ```vb Property Get LinkColor() As OLE_COLOR Property Let LinkColor(ByVal Value As OLE_COLOR) ``` 链接颜色。 ### VisitedLinkColor ```vb Property Get VisitedLinkColor() As OLE_COLOR Property Let VisitedLinkColor(ByVal Value As OLE_COLOR) ``` 已访问链接颜色。 ### DisabledLinkColor ```vb Property Get DisabledLinkColor() As OLE_COLOR Property Let DisabledLinkColor(ByVal Value As OLE_COLOR) ``` 禁用链接颜色。 ### LinkBehavior ```vb Property Get LinkBehavior() As LlbLinkBehaviorConstants Property Let LinkBehavior(ByVal Value As LlbLinkBehaviorConstants) ``` 链接行为样式。 ### Text ```vb Property Get Text() As String Property Let Text(ByVal Value As String) ``` 控件的完整文本内容，包含链接标记。 ### Links ```vb Property Get Links() As LlbLinks ``` 链接集合。 ### AutoSize ```vb Property Get AutoSize() As Boolean Property Let AutoSize(ByVal Value As Boolean) ``` 是否自动调整大小以适应内容。 ### BorderStyle ```vb Property Get BorderStyle() As CCBorderStyleConstants Property Let BorderStyle(ByVal Value As CCBorderStyleConstants) ``` 边框样式。参见通用枚举。 ### BackColor ```vb Property Get BackColor() As OLE_COLOR Property Let BackColor(ByVal Value As OLE_COLOR) ``` 背景颜色。 ### BackStyle ```vb Property Get BackStyle() As CCBackStyleConstants Property Let BackStyle(ByVal Value As CCBackStyleConstants) ``` 背景样式。参见通用枚举。 ### ForeColor ```vb Property Get ForeColor() As OLE_COLOR Property Let ForeColor(ByVal Value As OLE_COLOR) ``` 前景颜色。 ### Font ```vb Property Get Font() As StdFont Property Let Font(ByVal NewFont As StdFont) Property Set Font(ByVal NewFont As StdFont) ``` 字体。 ### Enabled ```vb Property Get Enabled() As Boolean Property Let Enabled(ByVal Value As Boolean) ``` 是否可用。 ### MousePointer ```vb Property Get MousePointer() As CCMousePointerConstants Property Let MousePointer(ByVal Value As CCMousePointerConstants) ``` 鼠标指针样式。参见通用枚举。 ### MouseIcon ```vb Property Get MouseIcon() As IPictureDisp Property Let MouseIcon(ByVal Value As IPictureDisp) Property Set MouseIcon(ByVal Value As IPictureDisp) ``` 自定义鼠标图标。 ### MouseTrack ```vb Property Get MouseTrack() As Boolean Property Let MouseTrack(ByVal Value As Boolean) ``` 是否启用鼠标进入/离开跟踪。 ### WordWrap ```vb Property Get WordWrap() As Boolean Property Let WordWrap(ByVal Value As Boolean) ``` 是否自动换行。 ### UseMnemonic ```vb Property Get UseMnemonic() As Boolean Property Let UseMnemonic(ByVal Value As Boolean) ``` 是否将 & 字符解释为快捷键前缀。 ### RightToLeft ```vb Property Get RightToLeft() As Boolean Property Let RightToLeft(ByVal Value As Boolean) ``` 从右到左显示方向。 ### RightToLeftLayout ```vb Property Get RightToLeftLayout() As Boolean Property Let RightToLeftLayout(ByVal Value As Boolean) ``` 从右到左镜像布局。 ### RightToLeftMode ```vb Property Get RightToLeftMode() As CCRightToLeftModeConstants Property Let RightToLeftMode(ByVal Value As CCRightToLeftModeConstants) ``` 从右到左模式。参见通用枚举。 ### Appearance ```vb Property Get Appearance() As CCAppearanceConstants Property Let Appearance(ByVal Value As CCAppearanceConstants) ``` 外观样式。参见通用枚举。 ### VerticalAlignment ```vb Property Get VerticalAlignment() As CCVerticalAlignmentConstants Property Let VerticalAlignment(ByVal Value As CCVerticalAlignmentConstants) ``` 垂直对齐方式。参见通用枚举。 ### hWnd ```vb Property Get hWnd() As LongPtr ``` 窗口句柄。只读。 ### ToolTipText ```vb Property Get ToolTipText() As String Property Let ToolTipText(ByVal Value As String) ``` 工具提示文本。 ### Name ```vb Property Get Name() As String ``` 控件名称。只读。 ### Tag ```vb Property Get Tag() As Variant Property Let Tag(ByVal Value As Variant) Property Set Tag(ByVal Value As Variant) ``` 自定义数据。 ### Parent ```vb Property Get Parent() As Object ``` 父对象。只读。 ### Container ```vb Property Get Container() As Object Property Set Container(ByVal Value As Object) ``` 容器对象。 ### Left ```vb Property Get Left() As Single Property Let Left(ByVal Value As Single) ``` 左边距。 ### Top ```vb Property Get Top() As Single Property Let Top(ByVal Value As Single) ``` 顶边距。 ### Width ```vb Property Get Width() As Single Property Let Width(ByVal Value As Single) ``` 宽度。 ### Height ```vb Property Get Height() As Single Property Let Height(ByVal Value As Single) ``` 高度。 ### Visible ```vb Property Get Visible() As Boolean Property Let Visible(ByVal Value As Boolean) ``` 可见性。 ## 方法 ### Refresh ```vb Sub Refresh() ``` 强制重绘。 ### AboutBox ```vb Sub AboutBox() ``` 显示关于对话框。 ## 事件 ### LinkClick ```vb Event LinkClick(ByVal Link As LlbLink) ``` 链接被点击时触发。 ### Click ```vb Event Click() ``` 单击时触发。 ### DblClick ```vb Event DblClick() ``` 双击时触发。 ### MouseDown ```vb Event MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) ``` 鼠标按下时触发。 ### MouseUp ```vb Event MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) ``` 鼠标释放时触发。 ### MouseMove ```vb Event MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) ``` 鼠标移动时触发。 ### MouseEnter ```vb Event MouseEnter() ``` 鼠标进入控件时触发。 ### MouseLeave ```vb Event MouseLeave() ``` 鼠标离开控件时触发。 ## 子对象 ### Link（LlbLink） 表示链接标签中的单个链接。 #### 属性 | 属性 | 类型 | 读写 | 说明 | |------|------|------|------| | Start As Long | Long | 读写 | 链接文本起始位置（从 0 开始） | | Length As Long | Long | 读写 | 链接文本长度 | | Visited As Boolean | Boolean | 读写 | 是否已访问 | | Key As String | String | 读写 | 链接关键字 | | Tag As Variant | Variant | 读写 | 自定义数据 | ### Links（LlbLinks） 链接集合对象。 #### 属性 | 属性 | 类型 | 读写 | 说明 | |------|------|------|------| | Item(ByVal Index As Variant) As LlbLink | LlbLink | 只读 | 按索引获取链接 | | Count As Long | Long | 只读 | 链接数量 | #### 方法 | 方法 | 说明 | |------|------| | Add(ByVal Start As Long, ByVal Length As Long, Optional ByVal Key As String) As LlbLink | 添加链接 | | Clear() | 清除所有链接 | | Remove(ByVal Index As Variant) | 移除指定链接 | ## 代码示例 ```vb ' 设置带链接的文本 With LinkLabel1 .Caption = "访问 VBCCR 项目主页获取更多信息" .LinkColor = vbBlue .VisitedLinkColor = vbPurple .LinkBehavior = LlbLinkBehaviorHoverUnderline ' 添加链接 .Links.Add 2, 7, "url_main" .Links.Add 15, 4, "url_more" End With ' 处理链接点击 Private Sub LinkLabel1_LinkClick(ByVal Link As LlbLink) Select Case Link.Key Case "url_main" ShellExecute 0, "open", "https://github.com/Kr00l/VBCCR", vbNullString, vbNullString, 1 Case "url_more" MsgBox "更多信息..." End Select Link.Visited = True End Sub ' 创建多链接文本 With LinkLabel2 .Caption = "请阅读 许可协议 和 隐私政策" .Links.Clear .Links.Add 3, 4, "license" .Links.Add 10, 4, "privacy" End With ``` --- --- url: /zh/vbman/database/chain-curd-aggregate.md --- # 链式 CURD - 聚合终结方法 聚合方法直接返回计算结果，无需手动构建 `SELECT COUNT(*) FROM ...`。详细架构参见 [链式 CURD 概述](./chain-curd)。 *** ## RowCount - 统计行数 ### 语法 ```vb Function RowCount() As Long ``` ### 示例 ```vb ' 统计总行数 Dim total As Long total = db.Table("users").RowCount ' 条件统计 Dim activeCount As Long activeCount = db.Table("users").Where("status=?", "active").RowCount ' 范围统计 Dim youngCount As Long youngCount = db.Table("users").WhereBetween("age", 18, 30).RowCount ``` *** ## RowExists - 判断是否存在 ### 语法 ```vb Function RowExists() As Boolean ``` ### 示例 ```vb ' 判断用户是否存在 If db.Table("users").Where("serial_no=?", sn).RowExists Then MsgBox "设备已存在" Else MsgBox "设备不存在" End If ' 判断邮箱是否已注册 If db.Table("users").Where("email=?", email).RowExists Then MsgBox "邮箱已注册" End If ``` *** ## RowPluck - 提取单列值列表 返回 Collection，包含指定字段的所有值。 ### 语法 ```vb Function RowPluck(ByVal FieldName As String) As Collection ``` ### 示例 ```vb ' 提取所有用户名 Dim names As Collection Set names = db.Table("users").RowPluck("name") ' 提取满足条件的ID列表 Dim ids As Collection Set ids = db.Table("users").Where("role=?", "admin").RowPluck("id") ' 遍历提取结果 Dim v As Variant For Each v In ids Debug.Print "管理员ID: " & v Next ``` *** ## RowMax - 最大值 ### 语法 ```vb Function RowMax(ByVal FieldName As String) As Variant ``` ### 示例 ```vb Dim maxAge As Variant maxAge = db.Table("users").RowMax("age") Debug.Print "最大年龄: " & maxAge ' 条件最大值 Dim maxSalary As Variant maxSalary = db.Table("users").Where("dept=?", "IT").RowMax("salary") ``` *** ## RowMin - 最小值 ```vb Dim minAge As Variant minAge = db.Table("users").RowMin("age") ``` *** ## RowSum - 求和 ```vb Dim totalAmount As Variant totalAmount = db.Table("orders").Where("year=?", 2026).RowSum("amount") Debug.Print "2026年总金额: " & totalAmount ``` *** ## RowAvg - 平均值 ```vb Dim avgSalary As Variant avgSalary = db.Table("users").Where("dept=?", "IT").RowAvg("salary") Debug.Print "IT部门平均薪资: " & avgSalary ``` *** **最后更新**: 2026-06-26 --- --- url: /zh/vbman/database/chain-curd-modifiers.md --- # 链式 CURD - 排序、分组、连接与选择 排序、分组、连接、选择方法均返回 `cDataBase` 对象，可自由叠加组合。详细架构参见 [链式 CURD 概述](./chain-curd)。 *** ## 排序方法 ### OrderBy - ASC 排序 可多次调用叠加多个排序字段。 #### 语法 ```vb Function OrderBy(ByVal FieldName As String) As cDataBase ``` #### 示例 ```vb ' 单字段排序 db.Table("users").OrderBy("age").RowRead ' 多字段排序（先按年龄，再按姓名） db.Table("users").OrderBy("age").OrderBy("name").RowRead ``` ### OrderByDesc - DESC 排序 #### 语法 ```vb Function OrderByDesc(ByVal FieldName As String) As cDataBase ``` #### 示例 ```vb ' 按ID降序 db.Table("users").OrderByDesc("id").RowRead ' 混合排序（年龄降序，姓名升序） db.Table("users").OrderByDesc("age").OrderBy("name").RowRead ``` ### OrderByRaw - 自定义排序子句 #### 语法 ```vb Function OrderByRaw(ByVal RawClause As String) As cDataBase ``` #### 示例 ```vb ' 复合排序 db.Table("users").OrderByRaw("age DESC, name ASC").RowRead ' 函数排序 db.Table("users").OrderByRaw("RAND()").RowRead ``` *** ## 分组方法 ### GroupBy - 分组查询 可多次调用叠加多个分组字段。 #### 语法 ```vb Function GroupBy(ByVal FieldName As String) As cDataBase ``` #### 示例 ```vb ' 按部门分组 db.Table("users").Columns("dept,COUNT(*) AS cnt").GroupBy("dept").RowRead ' 多字段分组 db.Table("orders").Columns("year,month,SUM(amount) AS total").GroupBy("year").GroupBy("month").RowRead ``` ### Having - 分组过滤 配合 GroupBy 使用，过滤分组后的结果。 #### 语法 ```vb Function Having(ByVal Condition As String) As cDataBase ``` #### 示例 ```vb ' 统计人数大于5的部门 db.Table("users").Columns("dept,COUNT(*) AS cnt").GroupBy("dept").Having("cnt>5").RowRead ' 统计平均薪资大于8000的部门 db.Table("users").Columns("dept,AVG(salary) AS avg_sal").GroupBy("dept").Having("avg_sal>8000").RowRead ``` *** ## 连接方法 ### Join - INNER JOIN #### 语法 ```vb Function Join(ByVal TableName As String, ByVal OnCondition As String) As cDataBase ``` #### 示例 ```vb ' 内连接 db.Table("orders") _ .Columns("orders.id,users.name,orders.amount") _ .Join("users", "orders.user_id=users.id") _ .RowRead ``` ### LeftJoin - LEFT JOIN #### 语法 ```vb Function LeftJoin(ByVal TableName As String, ByVal OnCondition As String) As cDataBase ``` #### 示例 ```vb ' 左连接（保留所有订单，即使没有匹配的用户） db.Table("orders") _ .Columns("orders.id,users.name") _ .LeftJoin("users", "orders.user_id=users.id") _ .OrderByDesc("orders.id") _ .RowRead ``` ### RightJoin - RIGHT JOIN #### 语法 ```vb Function RightJoin(ByVal TableName As String, ByVal OnCondition As String) As cDataBase ``` #### 示例 ```vb ' 右连接 db.Table("orders") _ .RightJoin("users", "orders.user_id=users.id") _ .RowRead ``` ### 多表连接叠加 ```vb ' 三表连接 db.Table("orders") _ .Columns("orders.id,users.name,products.title") _ .Join("users", "orders.user_id=users.id") _ .Join("products", "orders.product_id=products.id") _ .Where("orders.amount>?", 100) _ .OrderByDesc("orders.id") _ .RowRead ``` *** ## 查询列选择方法 ### Columns - 指定查询列 默认 `SELECT *`，调用后改为指定列。支持逗号分隔字符串或多参数形式。 > **注意**：方法名使用 `Columns` 而非 `Select`，避免与 VB6 保留字 `Select Case` 冲突。 #### 语法 ```vb Function Columns(ParamArray Cols() As Variant) As cDataBase ``` #### 示例 ```vb ' 字符串形式 db.Table("users").Columns("id,name,age").RowRead ' 多参数形式 db.Table("users").Columns("id", "name", "age").RowRead ' 配合聚合函数 db.Table("users").Columns("dept,COUNT(*) AS cnt").GroupBy("dept").RowRead ' 配合 JOIN db.Table("orders").Columns("orders.id,users.name").Join("users", "orders.uid=users.id").RowRead ``` ### Distinct - 去重查询 #### 语法 ```vb Function Distinct() As cDataBase ``` #### 示例 ```vb ' 查询不重复的部门 db.Table("users").Distinct.Columns("dept").RowRead ' 查询不重复的城市 db.Table("users").Distinct.Columns("city").Where("age>?", 18).RowRead ``` *** **最后更新**: 2026-06-26 --- --- url: /zh/vbman/database/chain-curd-where.md --- # 链式 CURD - 条件方法 所有条件方法返回 `cDataBase` 对象，可自由叠加组合。详细架构参见 [链式 CURD 概述](./chain-curd)。 *** ## Where - WHERE 条件 设置 WHERE AND 条件，支持 `?` 占位符 + 参数自动转义。 ### 语法 ```vb Function Where(ByVal Condition As String, ParamArray Params() As Variant) As cDataBase ``` ### 示例 ```vb ' 简单条件 db.Table("users").Where("age > 18").RowRead ' 占位符参数（自动转义单引号） db.Table("users").Where("name=?", "张三").RowRead ' 多参数 db.Table("users").Where("name=? AND age>?", "张三", 18).RowRead ``` *** ## OrWhere - OR 条件 添加 OR 条件，与 Where 的 AND 条件用 OR 连接。 ### 语法 ```vb Function OrWhere(ByVal Condition As String, ParamArray Params() As Variant) As cDataBase ``` ### 示例 ```vb ' AND + OR 组合 ' 生成 SQL: WHERE age > 18 OR (status = 'VIP') db.Table("users").Where("age>?", 18).OrWhere("status=?", "VIP").RowRead ' 多个 OrWhere ' 生成 SQL: WHERE age > 18 OR (role='admin' OR role='super') db.Table("users").Where("age>?", 18).OrWhere("role='admin'").OrWhere("role='super'").RowRead ``` *** ## WhereIn - IN 条件 字段值在指定列表中。支持逗号分隔字符串或多参数形式。 ### 语法 ```vb Function WhereIn(ByVal FieldName As String, ParamArray Values() As Variant) As cDataBase ``` ### 示例 ```vb ' 逗号分隔字符串形式 db.Table("users").WhereIn("status", "active,pending,closed").RowRead ' 多参数形式 db.Table("users").WhereIn("id", 1, 2, 3, 5, 8).RowRead ' 组合其他条件 db.Table("users").Where("age>?", 18).WhereIn("dept", "IT,HR").RowRead ``` *** ## WhereNotIn - NOT IN 条件 字段值不在指定列表中。 ### 语法 ```vb Function WhereNotIn(ByVal FieldName As String, ParamArray Values() As Variant) As cDataBase ``` ### 示例 ```vb ' 排除指定角色 db.Table("users").WhereNotIn("role", "admin,root,superadmin").RowRead ``` *** ## WhereBetween - BETWEEN 条件 字段值在两个值之间。 ### 语法 ```vb Function WhereBetween(ByVal FieldName As String, ByVal Value1 As Variant, ByVal Value2 As Variant) As cDataBase ``` ### 示例 ```vb ' 年龄范围查询 db.Table("users").WhereBetween("age", 18, 30).RowRead ' 日期范围查询 db.Table("orders").WhereBetween("created_at", "2025-01-01", "2025-12-31").RowRead ' 组合条件 db.Table("users").Where("dept=?", "IT").WhereBetween("salary", 5000, 15000).RowRead ``` *** ## WhereNotBetween - NOT BETWEEN 条件 ```vb db.Table("users").WhereNotBetween("age", 18, 30).RowRead ``` *** ## WhereLike - LIKE 模糊匹配 ### 语法 ```vb Function WhereLike(ByVal FieldName As String, ByVal Pattern As String) As cDataBase ``` ### 示例 ```vb ' 包含匹配 db.Table("users").WhereLike("name", "%张%").RowRead ' 前缀匹配 db.Table("users").WhereLike("email", "admin%").RowRead ' 组合其他条件 db.Table("users").Where("dept=?", "IT").WhereLike("name", "%张%").RowRead ``` *** ## WhereNotLike - NOT LIKE ```vb db.Table("users").WhereNotLike("name", "%test%").RowRead ``` *** ## WhereNull - IS NULL 条件 ### 语法 ```vb Function WhereNull(ByVal FieldName As String) As cDataBase ``` ### 示例 ```vb ' 查询未删除的记录 db.Table("users").WhereNull("deleted_at").RowRead ' 查询未设置邮箱的用户 db.Table("users").WhereNull("email").RowRead ``` *** ## WhereNotNull - IS NOT NULL 条件 ```vb ' 查询已验证邮箱的用户 db.Table("users").WhereNotNull("email_verified_at").RowRead ``` *** **最后更新**: 2026-06-26 --- --- url: /zh/vbman/database/chain-curd-limit-page.md --- # 链式 CURD - 限制与分页 限制与分页方法控制查询结果的数量和偏移。详细架构参见 [链式 CURD 概述](./chain-curd)。 *** ## Limit - 限制返回条数 非分页场景的简单截断，适用于"取最新N条"等场景。 ### 语法 ```vb Function Limit(ByVal N As Long) As cDataBase ``` ### 数据库适配 | 数据库 | 生成的 SQL | | ------------ | --------------------------------------------- | | MySQL | `LIMIT N` | | SQL Server | `OFFSET 0 ROWS FETCH NEXT N ROWS ONLY` | | Access | 自动转为 ADO 分页机制 | ### 示例 ```vb ' 取最新10条记录 db.Table("logs").OrderByDesc("id").Limit(10).RowRead ' 取前5条活跃用户 db.Table("users").Where("status=?", "active").OrderBy("name").Limit(5).RowRead ``` *** ## Offset - 偏移量 配合 Limit 使用，跳过前 N 条记录。 ### 语法 ```vb Function Offset(ByVal N As Long) As cDataBase ``` ### 数据库适配 | 数据库 | 生成的 SQL | | ------------ | --------------------------------------------- | | MySQL | `LIMIT Offset, Limit` | | SQL Server | `OFFSET N ROWS FETCH NEXT M ROWS ONLY` | ### 示例 ```vb ' 跳过前20条，取10条（第3页，每页10条） db.Table("users").OrderBy("id").Limit(10).Offset(20).RowRead ' 排行榜：跳过前100名，取50名 db.Table("scores").OrderByDesc("score").Limit(50).Offset(100).RowRead ``` *** ## Page - ADO 分页 基于 ADO 原生分页属性（`PageSize` + `AbsolutePage`），所有数据库类型通用。 ### 语法 ```vb Function Page(Optional Num As Long = 1, Optional Limit As Long = 10) As cDataBase ``` ### 参数说明 | 参数 | 类型 | 说明 | | -------- | ------ | --------------------------- | | `Num` | `Long` | 页码（可选，默认 1） | | `Limit` | `Long` | 每页记录数（可选，默认 10） | ### 示例 ```vb ' 第2页，每页20条 db.Table("users").OrderBy("id").Page(2, 20).RowRead ' 链式分页查询 db.Table("users") _ .Where("status=?", "active") _ .OrderByDesc("created_at") _ .Page(1, 10) _ .RowRead ' 与传统 Sql 方式的对比 ' 传统: db.Sql("SELECT * FROM users").Page(1, 10).Fetch ' 链式: db.Table("users").Page(1, 10).RowRead (更简洁) ``` > **注意**: `Page` 和 `Limit/Offset` 不要同时使用，二者功能重叠。`Page` 适合标准分页场景，`Limit/Offset` 适合灵活截断场景。 *** **最后更新**: 2026-06-26 --- --- url: /zh/vbman/database/chain-curd-terminal.md --- # 链式 CURD - 终结方法 终结方法执行实际数据库操作，执行后自动重置构建器状态（`ResetBuilder`）。详细架构参见 [链式 CURD 概述](./chain-curd)。 *** ## Field - 设置字段值 配合 `RowCreate` 和 `RowUpdate` 使用，设置插入/更新的字段值。 ### 语法 ```vb Function Field(ByVal FieldName As String, ByVal Value As Variant) As cDataBase ``` ### 示例 ```vb ' 插入时设置字段值 db.Table("users").Field("name", "张三").Field("age", 25).RowCreate ' 更新时设置字段值 db.Table("users").Where("id=?", 1).Field("name", "张三更新").Field("age", 26).RowUpdate ``` *** ## RowCreate - 创建行 ### 语法 ```vb Function RowCreate() As cDataBase ``` ### 用法模式 ```vb ' 模式1：链式 Field（推荐，一行完成插入） With db.Table("users") .Field "name", "张三" .Field "age", 25 .Field "email", "zhang@example.com" .RowCreate End With ' 模式2：传统 Rs 编辑（适合需要逐字段判断的场景） With db.Table("users").RowCreate .Rs!name = "张三" .Rs!age = 25 .Rs.Update End With ' 获取插入后的自增ID With db.Table("users") .Field "name", "李四" .RowCreate Debug.Print "新ID: " & db.LastInsertId End With ``` *** ## RowRead - 查询行 ### 语法 ```vb Function RowRead() As cDataBase ``` 查询结果存储在 `db.Rs` (Recordset) 中，可通过 `db.Rs!字段名` 访问。 ### 示例 ```vb ' 简单查询 If db.Table("users").Where("id=?", 1).RowRead Then Debug.Print db.Rs!name End If ' 链式复杂查询 db.Table("users") _ .Columns("id,name,age") _ .Where("age>?", 18) _ .WhereIn("dept", "IT,HR") _ .OrderByDesc("age") _ .Limit(10) _ .RowRead ' 遍历结果 If db.Table("users").Where("status=?", "active").RowRead Then Do Until db.Rs.EOF Debug.Print db.Rs!name & " - " & db.Rs!age db.Rs.MoveNext Loop End If ``` *** ## RowUpdate - 更新行 ### 语法 ```vb Function RowUpdate() As cDataBase ``` ### 用法模式 ```vb ' 模式1：链式 Field（推荐，一行完成更新） With db.Table("users").Where("id=?", 1) .Field "name", "张三更新" .Field "age", 26 .RowUpdate End With ' 模式2：传统 Rs 编辑 With db.Table("users").Where("id=?", 1).RowUpdate .Rs!name = "张三更新" .Rs.Update End With ' 批量更新（配合 WhereIn） With db.Table("users").WhereIn("id", 1, 2, 3) .Field "status", "archived" .RowUpdate End With ``` > **注意**: RowUpdate 要求必须设置 Where 条件，防止误更新全表。 *** ## RowDelete - 删除行 ### 语法 ```vb Function RowDelete() As cDataBase ``` ### 示例 ```vb ' 按ID删除 db.Table("users").Where("id=?", 1).RowDelete ' 批量删除 db.Table("users").WhereIn("id", 5, 8, 13).RowDelete ' 条件删除 db.Table("logs").Where("created_at<'2025-01-01'").RowDelete ' 组合条件删除 db.Table("users") _ .Where("status=?", "expired") _ .WhereNull("email") _ .RowDelete ``` > **注意**: RowDelete 要求必须设置 Where 条件，防止误删全表。 *** **最后更新**: 2026-06-26 --- --- url: /zh/vbman/database/chain-curd-examples.md --- # 链式 CURD - 综合示例与最佳实践 本文包含实战示例、与传统 SQL 对比、常见问题和最佳实践。方法详细说明参见各子页面： * [条件方法](./chain-curd-where) * [排序/分组/连接/选择](./chain-curd-modifiers) * [限制与分页](./chain-curd-limit-page) * [终结方法](./chain-curd-terminal) * [聚合终结方法](./chain-curd-aggregate) *** ## 综合示例 ### 示例1：用户管理系统 ```vb ' 查询活跃用户列表（排序+分页） If db.Table("users") _ .Where("status=?", "active") _ .WhereNotNull("email") _ .OrderByDesc("last_login") _ .Page(1, 20) _ .RowRead Then Do Until db.Rs.EOF Debug.Print db.Rs!name & " | " & db.Rs!email db.Rs.MoveNext Loop End If ' 搜索用户（模糊匹配+OR条件） db.Table("users") _ .WhereLike("name", "%" & keyword & "%") _ .OrWhereLike("email", "%" & keyword & "%") _ .OrderBy("name") _ .RowRead ' 创建新用户 With db.Table("users") .Field "name", txtName.Text .Field "age", CLng(txtAge.Text) .Field "email", txtEmail.Text .Field "status", "active" .RowCreate newId = db.LastInsertId End With ' 更新用户信息 With db.Table("users").Where("id=?", userId) .Field "name", txtName.Text .Field "email", txtEmail.Text .RowUpdate End With ' 删除过期用户 db.Table("users").Where("status=?", "expired").WhereNull("email").RowDelete ``` ### 示例2：报表统计 ```vb ' 部门人数统计 db.Table("users") _ .Columns("dept,COUNT(*) AS cnt") _ .GroupBy("dept") _ .Having("cnt>5") _ .OrderByDesc("cnt") _ .RowRead ' 月度销售汇总 db.Table("orders") _ .Columns("YEAR(created_at) AS y,MONTH(created_at) AS m,SUM(amount) AS total") _ .GroupBy("YEAR(created_at)") _ .GroupBy("MONTH(created_at)") _ .WhereBetween("created_at", "2026-01-01", "2026-12-31") _ .OrderBy("y") _ .OrderBy("m") _ .RowRead ' 快速统计 Dim totalUsers As Long totalUsers = db.Table("users").RowCount Dim avgSalary As Variant avgSalary = db.Table("users").Where("dept=?", "IT").RowAvg("salary") Dim maxOrder As Variant maxOrder = db.Table("orders").RowMax("amount") ' 获取所有部门名称列表 Dim depts As Collection Set depts = db.Table("users").Distinct.Columns("dept").RowPluck("dept") ``` ### 示例3：多表关联查询 ```vb ' 订单详情（订单+用户+产品） db.Table("orders") _ .Columns("orders.id,users.name AS user_name,products.title AS product,orders.amount") _ .Join("users", "orders.user_id=users.id") _ .LeftJoin("products", "orders.product_id=products.id") _ .Where("orders.amount>?", 100) _ .WhereBetween("orders.created_at", "2026-01-01", "2026-06-30") _ .OrderByDesc("orders.amount") _ .Limit(50) _ .RowRead ``` ### 示例4：判断存在与提取列表 ```vb ' 注册前检查邮箱是否已存在 If db.Table("users").Where("email=?", newEmail).RowExists Then MsgBox "该邮箱已注册" Exit Sub End If ' 获取管理员ID列表 Dim adminIds As Collection Set adminIds = db.Table("users").WhereIn("role", "admin,superadmin").RowPluck("id") ' 批量操作：将所有管理员标记为在线 With db.Table("users").WhereIn("id", "1,2,3,5") .Field "online_status", True .RowUpdate End With ``` *** ## 与传统 SQL 方式对比 ### 查询对比 ```vb ' ── 传统 SQL 方式 ── db.Sql("SELECT id,name FROM users WHERE age > 18 AND dept IN ('IT','HR') ORDER BY age DESC LIMIT 10").Fetch ' ── 链式构建器方式 ── db.Table("users") _ .Columns("id,name") _ .Where("age>?", 18) _ .WhereIn("dept", "IT,HR") _ .OrderByDesc("age") _ .Limit(10) _ .RowRead ``` ### 插入对比 ```vb ' ── 传统 SQL 方式 ── db.Sql("INSERT INTO users (name,age) VALUES ('张三',25)").Exec ' ── 链式构建器方式 ── db.Table("users").Field("name", "张三").Field("age", 25).RowCreate ``` ### 更新对比 ```vb ' ── 传统 SQL 方式 ── db.Sql("UPDATE users SET name='李四' WHERE id=1").Exec ' ── 链式构建器方式 ── db.Table("users").Where("id=?", 1).Field("name", "李四").RowUpdate ``` ### 删除对比 ```vb ' ── 传统 SQL 方式 ── db.Sql("DELETE FROM users WHERE status='expired'").Exec ' ── 链式构建器方式 ── db.Table("users").Where("status=?", "expired").RowDelete ``` ### 链式优势 | 维度 | 传统 SQL | 链式构建器 | | ------------ | --------------------------------- | ------------------------------- | | 可读性 | 长字符串拼接，难以阅读 | 方法链语义清晰 | | SQL 注入风险 | 手动拼接值，容易遗漏转义 | 参数自动转义 | | 跨数据库 | 需手写不同数据库的分页/限制语法 | 自动适配 MySQL/MSSQL/Access | | 维护性 | 改条件需重写整个 SQL | 增删链式方法即可 | | 调试 | 需打印完整 SQL | 每步对应一个 SQL 子句 | *** ## 常见问题 ### Q1: 链式构建器与 Sql() 方法能混用吗？ **不建议混用**。链式构建器（`Table` + `Where` + ...）和传统方式（`Sql`）使用不同的内部状态。如果已调用 `Sql()`，链式条件不会生效；反之亦然。请选择一种方式： ```vb ' 方式1：链式构建器（推荐用于标准 CRUD） db.Table("users").Where("id=?", 1).RowRead ' 方式2：传统 SQL（适合复杂查询、子查询等） db.Sql("SELECT * FROM users WHERE id = 1").Fetch ``` ### Q2: 复杂查询不适合链式怎么办？ 对于子查询、UNION、窗口函数等高级 SQL，链式构建器无法覆盖，请使用传统 `Sql()` 方式： ```vb ' 子查询 - 使用 Sql() 方式 db.Sql("SELECT * FROM users WHERE id IN (SELECT user_id FROM orders WHERE amount > 1000)").Fetch ' UNION 查询 - 使用 Sql() 方式 db.Sql("SELECT name FROM users UNION SELECT name FROM admins").Fetch ``` ### Q3: Where 和 WhereLike 能同时使用吗？ 可以，它们都是 AND 条件，会自动合并： ```vb db.Table("users") _ .Where("dept=?", "IT") _ .WhereLike("name", "%张%") _ .RowRead ' 生成: WHERE dept='IT' AND name LIKE '%张%' ``` ### Q4: OrWhere 的优先级如何？ OrWhere 用括号包裹，确保与 AND 条件正确组合： ```vb db.Table("users").Where("age>?", 18).OrWhere("role='VIP'").RowRead ' 生成: WHERE age > 18 OR (role='VIP') ``` ### Q5: RowCreate 后能继续使用 Rs 编辑吗？ 可以。`RowCreate` 后不自动重置构建器，允许你继续操作 Rs： ```vb With db.Table("users").RowCreate .Rs!name = "张三" If someCondition Then .Rs!email = "zhang@test.com" End If .Rs.Update End With ``` ### Q6: Page 和 Limit/Offset 有什么区别？ | 方法 | 适用场景 | 实现方式 | | ------------- | -------------- | ------------------------ | | `Page(N,M)` | 标准分页 | ADO `PageSize/AbsolutePage`，所有数据库通用 | | `Limit(M)` | 简单截断 | SQL `LIMIT M`，MySQL/MSSQL 语法适配 | | `Offset(N)` | 配合 Limit偏移 | SQL `OFFSET N`，MySQL/MSSQL 语法适配 | **不要同时使用 Page 和 Limit/Offset**，选择其一即可。 ### Q7: 链式方法执行后状态会保留吗？ 不会。终结方法（`RowRead`, `RowCreate`, `RowUpdate`, `RowDelete`, `RowCount` 等）执行后会自动调用 `ResetBuilder` 清除所有内部状态。下次链式调用需要重新从 `Table()` 开始。 *** ## 最佳实践 ### 1. 使用 With 简化链式调用 ```vb ' 推荐：With 结构清晰 With db.Table("users").Where("id=?", userId) .Field "name", newName .Field "age", newAge .RowUpdate End With ' 不推荐：散开写 db.Table "users" db.Where "id=?", userId db.Field "name", newName db.Field "age", newAge db.RowUpdate ``` ### 2. 优先使用链式参数转义 ```vb ' 推荐：Where 占位符自动转义 db.Table("users").Where("name=?", userName).RowRead ' 不推荐：手动拼接值 db.Table("users").Where("name='" & userName & "'").RowRead ``` ### 3. 始终为更新/删除设置条件 ```vb ' 安全：必须有 Where 条件 db.Table("users").Where("id=?", 1).RowUpdate db.Table("users").Where("status=?", "expired").RowDelete ' 危险：没有条件会报错（构建器保护） db.Table("users").RowUpdate ' 报错: no condition set ``` ### 4. 复杂查询用 Sql() ```vb ' 链式适合：标准 CRUD、简单条件、排序、分页 db.Table("users").Where("age>?", 18).OrderByDesc("id").Page(1, 10).RowRead ' Sql() 适合：子查询、UNION、窗口函数、复杂表达式 db.Sql("SELECT * FROM (SELECT id,name FROM users UNION SELECT id,name FROM admins) t").Fetch ``` *** **最后更新**: 2026-06-26 --- --- url: /zh/vbman/database/chain-curd.md --- # 链式 CURD 操作 本文档详细介绍 cDataBase 类的链式查询构建器，提供类似 ORM 的优雅 API，无需手写复杂 SQL。 ## 详细文档 | 主题 | 说明 | | --- | --- | | [条件方法](./chain-curd-where) | Where, OrWhere, WhereIn, WhereLike, WhereNull 等 | | [排序/分组/连接/选择](./chain-curd-modifiers) | OrderBy, GroupBy, Having, Join, Columns, Distinct | | [限制与分页](./chain-curd-limit-page) | Limit, Offset, Page | | [终结方法](./chain-curd-terminal) | RowCreate, RowRead, RowUpdate, RowDelete, Field | | [聚合终结方法](./chain-curd-aggregate) | RowCount, RowExists, RowPluck, RowMax/Min/Sum/Avg | | [综合示例与最佳实践](./chain-curd-examples) | 实战示例、与传统SQL对比、FAQ、最佳实践 | *** ## 概述 ### 什么是链式 CURD 链式 CURD 是 cDataBase 类提供的一种优雅的数据库操作方式，通过方法链（Method Chaining）逐步构建 SQL 语句，最终以终结方法执行操作。 **核心优势**： * **代码可读性高** - 每个链式方法对应一个 SQL 子句，语义清晰 * **类型安全** - 方法参数自动转义，减少 SQL 注入风险 * **跨数据库兼容** - 自动适配 MySQL / SQL Server / Access 的语法差异 * **零手写 SQL** - 排序、分组、分页、JOIN 等常用操作无需拼接字符串 ### 设计理念 ``` 链式调用流程: 起始方法 → 条件方法(可叠加) → 修饰方法(可叠加) → 终结方法 ───────── ─────────────── ─────────────── ────────── Table() Where() Columns() RowRead WhereIn() OrderBy() RowCreate WhereLike() GroupBy() RowUpdate OrWhere() Join() RowDelete ... Limit() RowCount Page() RowExists RowPluck RowMax/Min/Sum/Avg ``` *** ## 链式构建器架构 ### 内部状态变量 链式构建器通过一组私有变量累积各子句，终结方法执行后自动重置（`ResetBuilder`）： | 变量 | 对应 SQL 子句 | 设置方法 | | ---------------------- | ----------------- | -------------------------- | | `pvTableName` | FROM | `Table()` | | `pvSelectFields` | SELECT 列列表 | `Columns()` | | `pvIsDistinct` | SELECT DISTINCT | `Distinct()` | | `pvWhereCondition` | WHERE (AND 条件) | `Where()`, `WhereLike()` | | `pvOrWhereCondition` | WHERE (OR 条件) | `OrWhere()` | | `pvWhereInClauses` | WHERE IN/NOT IN | `WhereIn()`, `WhereNotIn()`| | `pvWhereBetweenClauses`| WHERE BETWEEN | `WhereBetween()` | | `pvWhereNullClauses` | WHERE IS NULL | `WhereNull()`, `WhereNotNull()`| | `pvOrderByClause` | ORDER BY | `OrderBy()`, `OrderByDesc()`, `OrderByRaw()`| | `pvGroupByClause` | GROUP BY | `GroupBy()` | | `pvHavingClause` | HAVING | `Having()` | | `pvJoinClauses` | JOIN | `Join()`, `LeftJoin()`, `RightJoin()`| | `pvLimitValue` | LIMIT | `Limit()` | | `pvOffsetValue` | OFFSET | `Offset()` | | `pvPageNum/Limit` | ADO 分页 | `Page()` | | `pvFields` | INSERT/UPDATE 值 | `Field()` | ### SQL 拼接逻辑 终结方法调用 `BuildSelectSql()` 拼接完整 SQL： ```sql SELECT [DISTINCT] {字段} FROM {表名} {JOIN子句} WHERE {Where + WhereIn + WhereBetween + WhereNull} [OR (OrWhere)] GROUP BY {分组} HAVING {过滤} ORDER BY {排序} LIMIT/OFFSET 或 ADO 分页 ``` *** ## 起始方法 ### Table - 设置操作表 设置当前操作的表名，所有链式 CURD 操作的起点。 #### 语法 ```vb Function Table(ByVal TableName As String) As cDataBase ``` #### 示例 ```vb ' 基本用法 db.Table("users").RowRead ' 配合 Where 查询 db.Table("users").Where("age>?", 18).RowRead ' 配合 Field 插入 db.Table("users").Field("name", "张三").Field("age", 25).RowCreate ``` *** ## 完整方法速查表 ### 链式方法（返回 cDataBase，可继续链式调用） | 类别 | 方法 | 说明 | 对应 SQL 子句 | | -------- | --------------------- | ------------------ | -------------------------- | | **起始** | `Table(表名)` | 设置操作表 | FROM | | **条件** | `Where(条件,参数...)` | AND 条件 | WHERE | | | `OrWhere(条件,参数...)`| OR 条件 | WHERE ... OR (...) | | | `WhereIn(字段,值列表)` | IN 条件 | WHERE 字段 IN (...) | | | `WhereNotIn(字段,值列表)`| NOT IN 条件 | WHERE 字段 NOT IN (...) | | | `WhereBetween(字段,V1,V2)`| BETWEEN 条件 | WHERE 字段 BETWEEN V1 AND V2| | | `WhereNotBetween(字段,V1,V2)`| NOT BETWEEN | WHERE 字段 NOT BETWEEN ... | | | `WhereLike(字段,模式)` | LIKE 模糊匹配 | WHERE 字段 LIKE '模式' | | | `WhereNotLike(字段,模式)`| NOT LIKE | WHERE 字段 NOT LIKE '模式' | | | `WhereNull(字段)` | IS NULL | WHERE 字段 IS NULL | | | `WhereNotNull(字段)` | IS NOT NULL | WHERE 字段 IS NOT NULL | | **排序** | `OrderBy(字段)` | ASC 排序 | ORDER BY 字段 ASC | | | `OrderByDesc(字段)` | DESC 排序 | ORDER BY 字段 DESC | | | `OrderByRaw(子句)` | 自定义排序 | ORDER BY 子句 | | **分组** | `GroupBy(字段)` | 分组 | GROUP BY 字段 | | | `Having(条件)` | 分组过滤 | HAVING 条件 | | **连接** | `Join(表,ON条件)` | INNER JOIN | INNER JOIN 表 ON 条件 | | | `LeftJoin(表,ON条件)` | LEFT JOIN | LEFT JOIN 表 ON 条件 | | | `RightJoin(表,ON条件)`| RIGHT JOIN | RIGHT JOIN 表 ON 条件 | | **选择** | `Columns(列...)` | 指定查询列 | SELECT 列 | | | `Distinct()` | 去重 | SELECT DISTINCT | | **值** | `Field(字段,值)` | 设置字段值 | INSERT/UPDATE 值 | | **限制** | `Limit(N)` | 限制条数 | LIMIT N | | | `Offset(N)` | 偏移量 | OFFSET N | | | `Page(页码,每页数)` | ADO分页 | Rs.PageSize + AbsolutePage | ### 终结方法（执行操作，重置构建器） | 方法 | 返回值 | 说明 | | ------------------ | ----------- | ---------------------- | | `RowCreate` | cDataBase | 创建新行 | | `RowRead` | cDataBase | 查询行（结果在 Rs） | | `RowUpdate` | cDataBase | 更新行 | | `RowDelete` | cDataBase | 删除行 | | `RowCount` | Long | 统计行数 | | `RowExists` | Boolean | 判断是否存在 | | `RowPluck(字段)` | Collection | 提取单列值列表 | | `RowMax(字段)` | Variant | 聚合 MAX | | `RowMin(字段)` | Variant | 聚合 MIN | | `RowSum(字段)` | Variant | 聚合 SUM | | `RowAvg(字段)` | Variant | 聚合 AVG | *** **最后更新**: 2026-06-26 --- --- url: /zh/packages/vbccr/lists/listboxw.md description: 列表框控件（ListBoxW） - VBCCR 开发手册，基于源码的完整 API 参考 --- # 列表框控件（ListBoxW） 封装 Win32 原生列表框控件，支持复选框/单选样式、所有者绘制、插入标记和多列显示。 ## 枚举 ### LstStyleConstants | 常量 | 值 | 说明 | |------|-----|------| | LstStyleStandard | 0 | 标准列表框 | | LstStyleCheckbox | 1 | 复选框样式 | | LstStyleOption | 2 | 单选按钮样式 | ### LstDrawModeConstants | 常量 | 值 | 说明 | |------|-----|------| | LstDrawModeNormal | 0 | 系统绘制 | | LstDrawModeOwnerDrawFixed | 1 | 所有者绘制固定高度 | | LstDrawModeOwnerDrawVariable | 2 | 所有者绘制可变高度 | ### CCBorderStyleConstants 参见通用枚举。 ### CCMousePointerConstants 参见通用枚举。 ### CCRightToLeftModeConstants 参见通用枚举。 ## 属性 ### Text ```vb Property Get Text() As String Property Let Text(ByVal Value As String) ``` 当前选定项的文本。 ### List ```vb Property Get List(ByVal Index As Long) As String Property Let List(ByVal Index As Long, ByVal Value As String) ``` 按索引获取或设置列表项文本。 ### ItemData ```vb Property Get ItemData(ByVal Index As Long) As LongPtr Property Let ItemData(ByVal Index As Long, ByVal Value As LongPtr) ``` 按索引获取或设置列表项的关联数据。 ### ItemChecked ```vb Property Get ItemChecked(ByVal Index As Long) As Boolean Property Let ItemChecked(ByVal Index As Long, ByVal Value As Boolean) ``` 按索引获取或设置项的选中状态（Style 为 Checkbox 或 Option 时有效）。 ### ListCount ```vb Property Get ListCount() As Long ``` 列表项总数。只读。 ### ListIndex ```vb Property Get ListIndex() As Long Property Let ListIndex(ByVal Value As Long) ``` 当前选定项的索引。 ### NewIndex ```vb Property Get NewIndex() As Long ``` 最近添加项的索引。只读。 ### TopIndex ```vb Property Get TopIndex() As Long Property Let TopIndex(ByVal Value As Long) ``` 列表中第一个可见项的索引。 ### AnchorIndex ```vb Property Get AnchorIndex() As Long Property Let AnchorIndex(ByVal Value As Long) ``` 选择锚点的索引。 ### SelCount ```vb Property Get SelCount() As Long ``` 选定项数量。只读。 ### Selected ```vb Property Get Selected(ByVal Index As Long) As Boolean Property Let Selected(ByVal Index As Long, ByVal Value As Boolean) ``` 按索引获取或设置项的选定状态。 ### ItemHeight ```vb Property Get ItemHeight(Optional ByVal Index As Long) As Single Property Let ItemHeight(Optional ByVal Index As Long, ByVal Value As Single) ``` 项的高度。可变高度所有者绘制模式下可按索引设置。 ### InsertMark ```vb Property Get InsertMark(Optional ByRef After As Boolean) As Long Property Let InsertMark(Optional ByRef After As Boolean, ByVal Value As Long) ``` 插入标记的索引。 ### OptionIndex ```vb Property Get OptionIndex() As Long Property Let OptionIndex(ByVal Value As Long) ``` 单选按钮样式中选中项的索引。 ### OLEDraggedItem ```vb Property Get OLEDraggedItem() As Long ``` OLE 拖放操作中拖动项的索引。只读。 ### Style ```vb Property Get Style() As LstStyleConstants Property Let Style(ByVal Value As LstStyleConstants) ``` 列表框样式。设计时只读。 ### DrawMode ```vb Property Get DrawMode() As LstDrawModeConstants Property Let DrawMode(ByVal Value As LstDrawModeConstants) ``` 绘制模式。设计时只读。 ### MultiSelect ```vb Property Get MultiSelect() As VBRUN.MultiSelectConstants Property Let MultiSelect(ByVal Value As VBRUN.MultiSelectConstants) ``` 多选模式。 ### Sorted ```vb Property Get Sorted() As Boolean Property Let Sorted(ByVal Value As Boolean) ``` 是否自动排序。 ### MultiColumn ```vb Property Get MultiColumn() As Boolean Property Let MultiColumn(ByVal Value As Boolean) ``` 是否启用多列显示。 ### IntegralHeight ```vb Property Get IntegralHeight() As Boolean Property Let IntegralHeight(ByVal Value As Boolean) ``` 是否只显示完整项。设计时可设置。 ### AllowSelection ```vb Property Get AllowSelection() As Boolean Property Let AllowSelection(ByVal Value As Boolean) ``` 是否允许选择项。 ### UseTabStops ```vb Property Get UseTabStops() As Boolean Property Let UseTabStops(ByVal Value As Boolean) ``` 是否识别和展开制表符。 ### DisableNoScroll ```vb Property Get DisableNoScroll() As Boolean Property Let DisableNoScroll(ByVal Value As Boolean) ``` 无需滚动时是否禁用（而非隐藏）滚动条。 ### HorizontalExtent ```vb Property Get HorizontalExtent() As Single Property Let HorizontalExtent(ByVal Value As Single) ``` 水平滚动宽度。 ### InsertMarkColor ```vb Property Get InsertMarkColor() As OLE_COLOR Property Let InsertMarkColor(ByVal Value As OLE_COLOR) ``` 插入标记的颜色。 ### ScrollTrack ```vb Property Get ScrollTrack() As Boolean Property Let ScrollTrack(ByVal Value As Boolean) ``` 是否在拖动滚动条时实时滚动内容。 ### Redraw ```vb Property Get Redraw() As Boolean Property Let Redraw(ByVal Value As Boolean) ``` 是否在更改项时重绘列表框。禁用可加速批量添加。 ### BorderStyle ```vb Property Get BorderStyle() As CCBorderStyleConstants Property Let BorderStyle(ByVal Value As CCBorderStyleConstants) ``` 边框样式。参见通用枚举。 ### VisualStyles ```vb Property Get VisualStyles() As Boolean Property Let VisualStyles(ByVal Value As Boolean) ``` 是否启用视觉样式。 ### BackColor ```vb Property Get BackColor() As OLE_COLOR Property Let BackColor(ByVal Value As OLE_COLOR) ``` 背景色。 ### ForeColor ```vb Property Get ForeColor() As OLE_COLOR Property Let ForeColor(ByVal Value As OLE_COLOR) ``` 前景色。 ### Font ```vb Property Get Font() As StdFont Property Let Font(ByVal NewFont As StdFont) Property Set Font(ByVal NewFont As StdFont) ``` 字体。 ### Enabled ```vb Property Get Enabled() As Boolean Property Let Enabled(ByVal Value As Boolean) ``` 是否可用。 ### AllowDropFiles ```vb Property Get AllowDropFiles() As Boolean Property Let AllowDropFiles(ByVal Value As Boolean) ``` 是否允许拖放文件。 ### OLEDragMode ```vb Property Get OLEDragMode() As VBRUN.OLEDragConstants Property Let OLEDragMode(ByVal Value As VBRUN.OLEDragConstants) ``` OLE 拖动模式。 ### OLEDragDropScroll ```vb Property Get OLEDragDropScroll() As Boolean Property Let OLEDragDropScroll(ByVal Value As Boolean) ``` OLE 拖放时是否自动滚动。 ### OLEDropMode ```vb Property Get OLEDropMode() As OLEDropModeConstants Property Let OLEDropMode(ByVal Value As OLEDropModeConstants) ``` OLE 放置模式。 ### MousePointer ```vb Property Get MousePointer() As CCMousePointerConstants Property Let MousePointer(ByVal Value As CCMousePointerConstants) ``` 鼠标指针样式。参见通用枚举。 ### MouseIcon ```vb Property Get MouseIcon() As IPictureDisp Property Let MouseIcon(ByVal Value As IPictureDisp) Property Set MouseIcon(ByVal Value As IPictureDisp) ``` 自定义鼠标图标。 ### MouseTrack ```vb Property Get MouseTrack() As Boolean Property Let MouseTrack(ByVal Value As Boolean) ``` 是否启用鼠标进入/离开跟踪。 ### RightToLeft ```vb Property Get RightToLeft() As Boolean Property Let RightToLeft(ByVal Value As Boolean) ``` 从右到左显示方向。 ### RightToLeftMode ```vb Property Get RightToLeftMode() As CCRightToLeftModeConstants Property Let RightToLeftMode(ByVal Value As CCRightToLeftModeConstants) ``` 从右到左模式。参见通用枚举。 ### hWnd ```vb Property Get hWnd() As LongPtr ``` 列表框控件的窗口句柄。 ### hWndUserControl ```vb Property Get hWndUserControl() As LongPtr ``` 用户控件的窗口句柄。 ### ToolTipText ```vb Property Get ToolTipText() As String Property Let ToolTipText(ByVal Value As String) ``` 工具提示文本。 ### Name ```vb Property Get Name() As String ``` 控件名称。只读。 ### Tag ```vb Property Get Tag() As String Property Let Tag(ByVal Value As String) ``` 自定义数据。 ### Parent ```vb Property Get Parent() As Object ``` 父对象。只读。 ### Container ```vb Property Get Container() As Object Property Set Container(ByVal Value As Object) ``` 容器对象。 ### Left ```vb Property Get Left() As Single Property Let Left(ByVal Value As Single) ``` 左边距。 ### Top ```vb Property Get Top() As Single Property Let Top(ByVal Value As Single) ``` 顶边距。 ### Width ```vb Property Get Width() As Single Property Let Width(ByVal Value As Single) ``` 宽度。 ### Height ```vb Property Get Height() As Single Property Let Height(ByVal Value As Single) ``` 高度。 ### Visible ```vb Property Get Visible() As Boolean Property Let Visible(ByVal Value As Boolean) ``` 是否可见。 ### HelpContextID ```vb Property Get HelpContextID() As Long Property Let HelpContextID(ByVal Value As Long) ``` 帮助上下文 ID。 ### WhatsThisHelpID ```vb Property Get WhatsThisHelpID() As Long Property Let WhatsThisHelpID(ByVal Value As Long) ``` "这是什么"帮助 ID。 ### DragIcon ```vb Property Get DragIcon() As IPictureDisp Property Let DragIcon(ByVal Value As IPictureDisp) Property Set DragIcon(ByVal Value As IPictureDisp) ``` 拖动图标。 ### DragMode ```vb Property Get DragMode() As Integer Property Let DragMode(ByVal Value As Integer) ``` 拖动模式。 ## 方法 ### AddItem ```vb Public Sub AddItem(ByVal Item As String, Optional ByVal Index As Variant) ``` 添加列表项。 ### RemoveItem ```vb Public Sub RemoveItem(ByVal Index As Long) ``` 移除指定索引的列表项。 ### Clear ```vb Public Sub Clear() ``` 清除所有列表项。 ### Refresh ```vb Public Sub Refresh() ``` 强制重绘控件。 ### SetSelRange ```vb Public Sub SetSelRange(ByVal StartIndex As Long, ByVal EndIndex As Long) ``` 设置选择范围（多选模式下）。 ### SetColumnWidth ```vb Public Sub SetColumnWidth(ByVal Value As Single) ``` 设置多列模式下列的宽度。 ### SelectItem ```vb Public Function SelectItem(ByVal Text As String, Optional ByVal Index As Long = -1) As Long ``` 选择匹配文本的项，返回选中项索引。 ### FindItem ```vb Public Function FindItem(ByVal Text As String, Optional ByVal Index As Long = -1, Optional ByVal Partial As Boolean) As Long ``` 查找匹配文本的项，返回索引。 ### HitTest ```vb Public Function HitTest(ByVal X As Single, ByVal Y As Single) As Long ``` 命中测试，返回指定坐标处的项索引。 ### HitTestInsertMark ```vb Public Function HitTestInsertMark(ByVal X As Single, ByVal Y As Single, Optional ByRef After As Boolean) As Long ``` 插入标记命中测试，返回插入位置索引。 ### ItemsPerColumn ```vb Public Function ItemsPerColumn() As Long ``` 获取每列项数。 ### SelectedIndices ```vb Public Function SelectedIndices() As Collection ``` 获取所有选定项索引的集合。 ### CheckedIndices ```vb Public Function CheckedIndices() As Collection ``` 获取所有选中项（复选框/单选）索引的集合。 ### GetIdealHorizontalExtent ```vb Public Function GetIdealHorizontalExtent() As Single ``` 获取理想的水平滚动宽度。 ### OLEDrag ```vb Public Sub OLEDrag() ``` 启动 OLE 拖放操作。 ### Drag ```vb Public Sub Drag(Optional ByRef Action As Variant) ``` 开始、结束或取消拖动操作。 ### SetFocus ```vb Public Sub SetFocus() ``` 获取焦点。 ### ZOrder ```vb Public Sub ZOrder(Optional ByRef Position As Variant) ``` 调整 Z 顺序。 ### Move ```vb Public Sub Move(ByVal Left As Single, Optional ByVal Top As Variant, Optional ByVal Width As Variant, Optional ByVal Height As Variant) ``` 移动并调整控件位置和大小。 ## 事件 ### Click ```vb Public Event Click() ``` 单击。 ### DblClick ```vb Public Event DblClick() ``` 双击。 ### Scroll ```vb Public Event Scroll() ``` 滚动时触发。 ### ItemCheck ```vb Public Event ItemCheck(ByVal Item As Long) ``` 项被选中或取消选中时触发。 ### ItemBeforeCheck ```vb Public Event ItemBeforeCheck(ByVal Item As Long, ByRef Cancel As Boolean) ``` 项即将被选中或取消选中时触发，可取消。 ### ItemMeasure ```vb Public Event ItemMeasure(ByVal Item As Long, ByRef ItemHeight As Long) ``` 可变高度所有者绘制模式下测量项高度时触发。 ### ItemDraw ```vb Public Event ItemDraw(ByVal Item As Long, ByVal ItemAction As Long, ByVal ItemState As Long, ByVal hDC As Long, ByVal Left As Long, ByVal Top As Long, ByVal Right As Long, ByVal Bottom As Long) ``` 所有者绘制模式下绘制项时触发。 ### DropFiles ```vb Public Event DropFiles(ByRef FileList As Variant, ByVal X As Single, ByVal Y As Single) ``` 拖放文件到控件时触发。 ### ContextMenu ```vb Public Event ContextMenu(ByVal X As Single, ByVal Y As Single) ``` 右键菜单请求时触发。 ### PreviewKeyDown ```vb Public Event PreviewKeyDown(ByVal KeyCode As Integer, ByRef IsInputKey As Boolean) ``` 按键前事件，在 KeyDown 之前触发。 ### PreviewKeyUp ```vb Public Event PreviewKeyUp(ByVal KeyCode As Integer, ByRef IsInputKey As Boolean) ``` 按键释放前事件，在 KeyUp 之前触发。 ### KeyDown ```vb Public Event KeyDown(KeyCode As Integer, Shift As Integer) ``` 按键按下。 ### KeyUp ```vb Public Event KeyUp(KeyCode As Integer, Shift As Integer) ``` 按键释放。 ### KeyPress ```vb Public Event KeyPress(KeyChar As Integer) ``` 按键字符。 ### MouseDown ```vb Public Event MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` 鼠标按下。 ### MouseMove ```vb Public Event MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` 鼠标移动。 ### MouseUp ```vb Public Event MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` 鼠标释放。 ### MouseEnter ```vb Public Event MouseEnter() ``` 鼠标进入控件。 ### MouseLeave ```vb Public Event MouseLeave() ``` 鼠标离开控件。 ### OLECompleteDrag ```vb Public Event OLECompleteDrag(Effect As Long) ``` OLE 拖放完成。 ### OLEDragDrop ```vb Public Event OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single) ``` OLE 拖放落下。 ### OLEDragOver ```vb Public Event OLEDragOver(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single, State As Integer) ``` OLE 拖放悬停。 ### OLEGiveFeedback ```vb Public Event OLEGiveFeedback(Effect As Long, DefaultCursors As Boolean) ``` OLE 给出反馈。 ### OLESetData ```vb Public Event OLESetData(Data As DataObject, DataFormat As Integer) ``` OLE 设置数据。 ### OLEStartDrag ```vb Public Event OLEStartDrag(Data As DataObject, AllowedEffects As Long) ``` OLE 开始拖动。 ## 代码示例 ### 基本用法 ```vb ' 添加列表项 ListBoxW1.AddItem "项目 1" ListBoxW1.AddItem "项目 2", 0 ' 设置当前选中项 ListBoxW1.ListIndex = 0 ' 获取选中项文本 Dim s As String s = ListBoxW1.Text ``` ### 复选框和单选样式 ```vb ' 复选框样式（设计时设置） ' ListBoxW1.Style = LstStyleCheckbox ' 获取选中项 Dim i As Long For i = 0 To ListBoxW1.ListCount - 1 If ListBoxW1.ItemChecked(i) Then Debug.Print ListBoxW1.List(i) End If Next i ``` ### 所有者绘制 ```vb ' 可变高度所有者绘制（设计时设置 DrawMode = LstDrawModeOwnerDrawVariable） Private Sub ListBoxW1_ItemMeasure(ByVal Item As Long, ByRef ItemHeight As Long) ItemHeight = 30 End Sub Private Sub ListBoxW1_ItemDraw(ByVal Item As Long, ByVal ItemAction As Long, _ ByVal ItemState As Long, ByVal hDC As Long, _ ByVal Left As Long, ByVal Top As Long, ByVal Right As Long, ByVal Bottom As Long) ' 自定义绘制逻辑 End Sub ``` ### 批量添加 ```vb ' 禁用重绘加速批量添加 ListBoxW1.Redraw = False Dim i As Long For i = 1 To 1000 ListBoxW1.AddItem "Item " & i Next i ListBoxW1.Redraw = True ``` --- --- url: /zh/packages/vbccr/views/listview.md description: 列表视图控件（ListView） - VBCCR 开发手册，基于源码的完整 API 参考 --- # 列表视图控件（ListView） 封装 SysListView32 系统列表视图控件，支持大图标、小图标、列表、报表和平铺视图，以及分组、虚拟模式、列筛选等高级功能。 ## 枚举 ### LvwViewConstants | 常量 | 值 | 说明 | |------|-----|------| | LvwViewIcon | 0 | 大图标视图 | | LvwViewSmallIcon | 1 | 小图标视图 | | LvwViewList | 2 | 列表视图 | | LvwViewReport | 3 | 报表视图 | | LvwViewTile | 4 | 平铺视图 | ### LvwArrangeConstants | 常量 | 值 | 说明 | |------|-----|------| | LvwArrangeNone | 0 | 不排列 | | LvwArrangeAutoLeft | 1 | 自动靠左排列 | | LvwArrangeAutoTop | 2 | 自动靠顶排列 | | LvwArrangeLeft | 3 | 靠左排列 | | LvwArrangeTop | 4 | 靠顶排列 | ### LvwColumnHeaderAlignmentConstants | 常量 | 值 | 说明 | |------|-----|------| | LvwColumnHeaderAlignmentLeft | 0 | 左对齐 | | LvwColumnHeaderAlignmentRight | 1 | 右对齐 | | LvwColumnHeaderAlignmentCenter | 2 | 居中 | ### LvwColumnHeaderSortArrowConstants | 常量 | 值 | 说明 | |------|-----|------| | LvwColumnHeaderSortArrowNone | 0 | 无排序箭头 | | LvwColumnHeaderSortArrowDown | 1 | 向下箭头（升序） | | LvwColumnHeaderSortArrowUp | 2 | 向上箭头（降序） | ### LvwColumnHeaderAutoSizeConstants | 常量 | 值 | 说明 | |------|-----|------| | LvwColumnHeaderAutoSizeToItems | 0 | 根据项自动调整 | | LvwColumnHeaderAutoSizeToHeader | 1 | 根据表头自动调整 | ### LvwColumnHeaderFilterTypeConstants | 常量 | 值 | 说明 | |------|-----|------| | LvwColumnHeaderFilterTypeText | 0 | 文本筛选 | | LvwColumnHeaderFilterTypeNumber | 1 | 数值筛选 | ### LvwLabelEditConstants | 常量 | 值 | 说明 | |------|-----|------| | LvwLabelEditAutomatic | 0 | 自动标签编辑 | | LvwLabelEditManual | 1 | 手动标签编辑 | | LvwLabelEditDisabled | 2 | 禁用标签编辑 | ### LvwSortOrderConstants | 常量 | 值 | 说明 | |------|-----|------| | LvwSortOrderAscending | 0 | 升序 | | LvwSortOrderDescending | 1 | 降序 | ### LvwSortTypeConstants | 常量 | 值 | 说明 | |------|-----|------| | LvwSortTypeBinary | 0 | 二进制排序 | | LvwSortTypeText | 1 | 文本排序 | | LvwSortTypeNumeric | 2 | 数值排序 | | LvwSortTypeCurrency | 3 | 货币排序 | | LvwSortTypeDate | 4 | 日期排序 | | LvwSortTypeLogical | 5 | 逻辑排序 | ### LvwPictureAlignmentConstants | 常量 | 值 | 说明 | |------|-----|------| | LvwPictureAlignmentTopLeft | 0 | 左上 | | LvwPictureAlignmentTopRight | 1 | 右上 | | LvwPictureAlignmentBottomLeft | 2 | 左下 | | LvwPictureAlignmentBottomRight | 3 | 右下 | | LvwPictureAlignmentCenter | 4 | 居中 | | LvwPictureAlignmentTile | 5 | 平铺 | ### LvwGroupHeaderAlignmentConstants | 常量 | 值 | 说明 | |------|-----|------| | LvwGroupHeaderAlignmentLeft | 0 | 左对齐 | | LvwGroupHeaderAlignmentRight | 1 | 右对齐 | | LvwGroupHeaderAlignmentCenter | 2 | 居中 | ### LvwGroupFooterAlignmentConstants | 常量 | 值 | 说明 | |------|-----|------| | LvwGroupFooterAlignmentLeft | 0 | 左对齐 | | LvwGroupFooterAlignmentRight | 1 | 右对齐 | | LvwGroupFooterAlignmentCenter | 2 | 居中 | ### LvwVisualThemeConstants | 常量 | 值 | 说明 | |------|-----|------| | LvwVisualThemeStandard | 0 | 标准主题 | | LvwVisualThemeExplorer | 1 | 资源管理器主题 | ### LvwVirtualPropertyConstants | 常量 | 值 | 说明 | |------|-----|------| | LvwVirtualPropertyText | 1 | 文本属性 | | LvwVirtualPropertyIcon | 2 | 图标属性 | | LvwVirtualPropertyIndentation | 4 | 缩进属性 | | LvwVirtualPropertyToolTipText | 8 | 工具提示文本属性 | | LvwVirtualPropertyBold | 16 | 粗体属性 | | LvwVirtualPropertyForeColor | 32 | 前景色属性 | | LvwVirtualPropertyChecked | 64 | 选中属性 | ### LvwFindDirectionConstants | 常量 | 值 | 说明 | |------|-----|------| | LvwFindDirectionUndefined | 0 | 未定义 | | LvwFindDirectionPrior | vbKeyPageUp | 向上翻页方向 | | LvwFindDirectionNext | vbKeyPageDown | 向下翻页方向 | | LvwFindDirectionEnd | vbKeyEnd | End 方向 | | LvwFindDirectionHome | vbKeyHome | Home 方向 | | LvwFindDirectionLeft | vbKeyLeft | 左方向 | | LvwFindDirectionUp | vbKeyUp | 上方向 | | LvwFindDirectionRight | vbKeyRight | 右方向 | | LvwFindDirectionDown | vbKeyDown | 下方向 | ### CCBorderStyleConstants 参见通用枚举。 ### CCAppearanceConstants 参见通用枚举。 ### CCMousePointerConstants 参见通用枚举。 ### CCIMEModeConstants 参见通用枚举。 ### CCBackStyleConstants 参见通用枚举。 ### CCRightToLeftModeConstants 参见通用枚举。 ### CCScrollOrientationConstants 参见通用枚举。 ### OLEDropModeConstants 参见通用枚举。 ## 属性 ### View ```vb Property Get View() As LvwViewConstants Property Let View(ByVal Value As LvwViewConstants) ``` 视图模式。 ### Arrange ```vb Property Get Arrange() As LvwArrangeConstants Property Let Arrange(ByVal Value As LvwArrangeConstants) ``` 图标排列方式。 ### SortKey ```vb Property Get SortKey() As Integer Property Let SortKey(ByVal Value As Integer) ``` 排序关键列索引。 ### SortOrder ```vb Property Get SortOrder() As LvwSortOrderConstants Property Let SortOrder(ByVal Value As LvwSortOrderConstants) ``` 排序顺序。 ### SortType ```vb Property Get SortType() As LvwSortTypeConstants Property Let SortType(ByVal Value As LvwSortTypeConstants) ``` 排序类型。 ### Sorted ```vb Property Get Sorted() As Boolean Property Let Sorted(ByVal Value As Boolean) ``` 是否启用排序。 ### LabelEdit ```vb Property Get LabelEdit() As LvwLabelEditConstants Property Let LabelEdit(ByVal Value As LvwLabelEditConstants) ``` 标签编辑模式。 ### LabelWrap ```vb Property Get LabelWrap() As Boolean Property Let LabelWrap(ByVal Value As Boolean) ``` 是否允许标签换行。 ### MultiSelect ```vb Property Get MultiSelect() As Boolean Property Let MultiSelect(ByVal Value As Boolean) ``` 是否允许多选。 ### FullRowSelect ```vb Property Get FullRowSelect() As Boolean Property Let FullRowSelect(ByVal Value As Boolean) ``` 是否整行选中。 ### GridLines ```vb Property Get GridLines() As Boolean Property Let GridLines(ByVal Value As Boolean) ``` 是否显示网格线。 ### Checkboxes ```vb Property Get Checkboxes() As Boolean Property Let Checkboxes(ByVal Value As Boolean) ``` 是否显示复选框。 ### HideSelection ```vb Property Get HideSelection() As Boolean Property Let HideSelection(ByVal Value As Boolean) ``` 失去焦点时是否隐藏选中状态。 ### HideColumnHeaders ```vb Property Get HideColumnHeaders() As Boolean Property Let HideColumnHeaders(ByVal Value As Boolean) ``` 是否隐藏列标题。 ### AllowColumnReorder ```vb Property Get AllowColumnReorder() As Boolean Property Let AllowColumnReorder(ByVal Value As Boolean) ``` 是否允许拖动重排列。 ### AllowColumnCheckboxes ```vb Property Get AllowColumnCheckboxes() As Boolean Property Let AllowColumnCheckboxes(ByVal Value As Boolean) ``` 是否允许列复选框。 ### AllowDropFiles ```vb Property Get AllowDropFiles() As Boolean Property Let AllowDropFiles(ByVal Value As Boolean) ``` 是否允许拖放文件。 ### ShowInfoTips ```vb Property Get ShowInfoTips() As Boolean Property Let ShowInfoTips(ByVal Value As Boolean) ``` 是否显示信息提示。 ### ShowLabelTips ```vb Property Get ShowLabelTips() As Boolean Property Let ShowLabelTips(ByVal Value As Boolean) ``` 是否显示标签提示。 ### ShowColumnTips ```vb Property Get ShowColumnTips() As Boolean Property Let ShowColumnTips(ByVal Value As Boolean) ``` 是否显示列提示。 ### DoubleBuffer ```vb Property Get DoubleBuffer() As Boolean Property Let DoubleBuffer(ByVal Value As Boolean) ``` 是否启用双缓冲。 ### VisualStyles ```vb Property Get VisualStyles() As Boolean Property Let VisualStyles(ByVal Value As Boolean) ``` 是否启用视觉样式。 ### VisualTheme ```vb Property Get VisualTheme() As LvwVisualThemeConstants Property Let VisualTheme(ByVal Value As LvwVisualThemeConstants) ``` 视觉主题。 ### HoverSelection ```vb Property Get HoverSelection() As Boolean Property Let HoverSelection(ByVal Value As Boolean) ``` 是否启用悬停选择。 ### HoverSelectionTime ```vb Property Get HoverSelectionTime() As Long Property Let HoverSelectionTime(ByVal Value As Long) ``` 悬停选择延迟时间（毫秒）。 ### HotTracking ```vb Property Get HotTracking() As Boolean Property Let HotTracking(ByVal Value As Boolean) ``` 是否启用热跟踪。 ### HighlightHot ```vb Property Get HighlightHot() As Boolean Property Let HighlightHot(ByVal Value As Boolean) ``` 是否高亮显示热项。 ### UnderlineHot ```vb Property Get UnderlineHot() As Boolean Property Let UnderlineHot(ByVal Value As Boolean) ``` 是否为热项添加下划线。 ### InsertMarkColor ```vb Property Get InsertMarkColor() As OLE_COLOR Property Let InsertMarkColor(ByVal Value As OLE_COLOR) ``` 插入标记的颜色。 ### TextBackground ```vb Property Get TextBackground() As CCBackStyleConstants Property Let TextBackground(ByVal Value As CCBackStyleConstants) ``` 文本背景样式。参见通用枚举。 ### ClickableColumnHeaders ```vb Property Get ClickableColumnHeaders() As Boolean Property Let ClickableColumnHeaders(ByVal Value As Boolean) ``` 列标题是否可点击。 ### HighlightColumnHeaders ```vb Property Get HighlightColumnHeaders() As Boolean Property Let HighlightColumnHeaders(ByVal Value As Boolean) ``` 是否高亮显示列标题。 ### TrackSizeColumnHeaders ```vb Property Get TrackSizeColumnHeaders() As Boolean Property Let TrackSizeColumnHeaders(ByVal Value As Boolean) ``` 是否跟踪列标题大小。 ### ResizableColumnHeaders ```vb Property Get ResizableColumnHeaders() As Boolean Property Let ResizableColumnHeaders(ByVal Value As Boolean) ``` 列标题是否可调整大小。 ### Picture ```vb Property Get Picture() As IPictureDisp Property Let Picture(ByVal Value As IPictureDisp) Property Set Picture(ByVal Value As IPictureDisp) ``` 背景图片。 ### PictureAlignment ```vb Property Get PictureAlignment() As LvwPictureAlignmentConstants Property Let PictureAlignment(ByVal Value As LvwPictureAlignmentConstants) ``` 背景图片对齐方式。 ### PictureWatermark ```vb Property Get PictureWatermark() As Boolean Property Let PictureWatermark(ByVal Value As Boolean) ``` 是否将背景图片作为水印。 ### TileViewLines ```vb Property Get TileViewLines() As Long Property Let TileViewLines(ByVal Value As Long) ``` 平铺视图中的文本行数。 ### SnapToGrid ```vb Property Get SnapToGrid() As Boolean Property Let SnapToGrid(ByVal Value As Boolean) ``` 是否对齐到网格。 ### GroupView ```vb Property Get GroupView() As Boolean Property Let GroupView(ByVal Value As Boolean) ``` 是否启用分组视图。 ### GroupSubsetCount ```vb Property Get GroupSubsetCount() As Long Property Let GroupSubsetCount(ByVal Value As Long) ``` 分组子集显示数量。 ### UseColumnChevron ```vb Property Get UseColumnChevron() As Boolean Property Let UseColumnChevron(ByVal Value As Boolean) ``` 是否使用列折叠按钮。 ### UseColumnFilterBar ```vb Property Get UseColumnFilterBar() As Boolean Property Let UseColumnFilterBar(ByVal Value As Boolean) ``` 是否使用列筛选栏。 ### AutoSelectFirstItem ```vb Property Get AutoSelectFirstItem() As Boolean Property Let AutoSelectFirstItem(ByVal Value As Boolean) ``` 是否自动选择第一项。 ### IMEMode ```vb Property Get IMEMode() As CCIMEModeConstants Property Let IMEMode(ByVal Value As CCIMEModeConstants) ``` 输入法模式。参见通用枚举。 ### VirtualMode ```vb Property Get VirtualMode() As Boolean Property Let VirtualMode(ByVal Value As Boolean) ``` 是否启用虚拟模式。 ### VirtualItemCount ```vb Property Get VirtualItemCount() As Long Property Let VirtualItemCount(ByVal Value As Long) ``` 虚拟模式下的项总数。 ### VirtualDisabledInfos ```vb Property Get VirtualDisabledInfos() As LvwVirtualPropertyConstants Property Let VirtualDisabledInfos(ByVal Value As LvwVirtualPropertyConstants) ``` 虚拟模式下禁用的属性掩码。 ### ListItems ```vb Property Get ListItems() As LvwListItems ``` 列表项集合。只读。 ### VirtualListItems ```vb Property Get VirtualListItems() As LvwVirtualListItems ``` 虚拟列表项集合。只读。 ### ColumnHeaders ```vb Property Get ColumnHeaders() As LvwColumnHeaders ``` 列标题集合。只读。 ### Groups ```vb Property Get Groups() As LvwGroups ``` 分组集合。只读。 ### WorkAreas ```vb Property Get WorkAreas() As LvwWorkAreas ``` 工作区域集合。只读。 ### TopItem ```vb Property Get TopItem() As LvwListItem ``` 第一个可见项。只读。 ### SelectedItem ```vb Property Get SelectedItem() As LvwListItem Property Let SelectedItem(ByVal Value As LvwListItem) Property Set SelectedItem(ByVal Value As LvwListItem) ``` 当前选中项。 ### HotItem ```vb Property Get HotItem() As LvwListItem Property Let HotItem(ByVal Value As LvwListItem) Property Set HotItem(ByVal Value As LvwListItem) ``` 热项（鼠标悬停项）。 ### SelectionMark ```vb Property Get SelectionMark() As LvwListItem Property Let SelectionMark(ByVal Value As LvwListItem) Property Set SelectionMark(ByVal Value As LvwListItem) ``` 选择标记项。 ### DropHighlight ```vb Property Get DropHighlight() As LvwListItem Property Let DropHighlight(ByVal Value As LvwListItem) Property Set DropHighlight(ByVal Value As LvwListItem) ``` 拖放高亮项。 ### InsertMark ```vb Property Get InsertMark(Optional ByRef After As Boolean) As LvwListItem Property Let InsertMark(Optional ByRef After As Boolean, ByVal Value As LvwListItem) Property Set InsertMark(Optional ByRef After As Boolean, ByVal Value As LvwListItem) ``` 插入标记项。 ### OLEDraggedItem ```vb Property Get OLEDraggedItem() As LvwListItem ``` OLE 拖放操作中拖动的项。只读。 ### SelectedGroup ```vb Property Get SelectedGroup() As LvwGroup Property Let SelectedGroup(ByVal Value As LvwGroup) Property Set SelectedGroup(ByVal Value As LvwGroup) ``` 当前选中的分组。 ### SelectedColumn ```vb Property Get SelectedColumn() As LvwColumnHeader Property Let SelectedColumn(ByVal Value As LvwColumnHeader) Property Set SelectedColumn(ByVal Value As LvwColumnHeader) ``` 当前选中的列。 ### ColumnOrder ```vb Property Get ColumnOrder() As Variant Property Let ColumnOrder(ByVal ArgList As Variant) ``` 列顺序数组。 ### ColumnWidth ```vb Property Get ColumnWidth() As Single Property Let ColumnWidth(ByVal Value As Single) ``` 当前列宽。 ### ColumnFilterChangedTimeout ```vb Property Get ColumnFilterChangedTimeout() As Long Property Let ColumnFilterChangedTimeout(ByVal Value As Long) ``` 列筛选变更超时时间。 ### IconSpacingWidth ```vb Property Get IconSpacingWidth() As Single Property Let IconSpacingWidth(ByVal Value As Single) ``` 图标间距宽度。 ### IconSpacingHeight ```vb Property Get IconSpacingHeight() As Single Property Let IconSpacingHeight(ByVal Value As Single) ``` 图标间距高度。 ### IncrementalSearchString ```vb Property Get IncrementalSearchString() As String ``` 增量搜索字符串。只读。 ### Redraw ```vb Property Get Redraw() As Boolean Property Let Redraw(ByVal Value As Boolean) ``` 是否启用重绘。 ### BorderStyle ```vb Property Get BorderStyle() As CCBorderStyleConstants Property Let BorderStyle(ByVal Value As CCBorderStyleConstants) ``` 边框样式。参见通用枚举。 ### BackColor ```vb Property Get BackColor() As OLE_COLOR Property Let BackColor(ByVal Value As OLE_COLOR) ``` 背景色。 ### ForeColor ```vb Property Get ForeColor() As OLE_COLOR Property Let ForeColor(ByVal Value As OLE_COLOR) ``` 前景色。 ### Font ```vb Property Get Font() As StdFont Property Let Font(ByVal NewFont As StdFont) Property Set Font(ByVal NewFont As StdFont) ``` 字体。 ### Enabled ```vb Property Get Enabled() As Boolean Property Let Enabled(ByVal Value As Boolean) ``` 是否可用。 ### Icons ```vb Property Get Icons() As Variant Property Set Icons(ByVal Value As Variant) Property Let Icons(ByVal Value As Variant) ``` 大图标图像列表。 ### SmallIcons ```vb Property Get SmallIcons() As Variant Property Set SmallIcons(ByVal Value As Variant) Property Let SmallIcons(ByVal Value As Variant) ``` 小图标图像列表。 ### ColumnHeaderIcons ```vb Property Get ColumnHeaderIcons() As Variant Property Set ColumnHeaderIcons(ByVal Value As Variant) Property Let ColumnHeaderIcons(ByVal Value As Variant) ``` 列标题图像列表。 ### GroupIcons ```vb Property Get GroupIcons() As Variant Property Set GroupIcons(ByVal Value As Variant) Property Let GroupIcons(ByVal Value As Variant) ``` 分组标题图像列表。 ### OLEDragMode ```vb Property Get OLEDragMode() As VBRUN.OLEDragConstants Property Let OLEDragMode(ByVal Value As VBRUN.OLEDragConstants) ``` OLE 拖动模式。 ### OLEDragDropScroll ```vb Property Get OLEDragDropScroll() As Boolean Property Let OLEDragDropScroll(ByVal Value As Boolean) ``` OLE 拖放时是否自动滚动。 ### OLEDragDropScrollOrientation ```vb Property Get OLEDragDropScrollOrientation() As CCScrollOrientationConstants Property Let OLEDragDropScrollOrientation(ByVal Value As CCScrollOrientationConstants) ``` OLE 拖放自动滚动方向。参见通用枚举。 ### OLEDropMode ```vb Property Get OLEDropMode() As OLEDropModeConstants Property Let OLEDropMode(ByVal Value As OLEDropModeConstants) ``` OLE 放置模式。 ### MousePointer ```vb Property Get MousePointer() As CCMousePointerConstants Property Let MousePointer(ByVal Value As CCMousePointerConstants) ``` 鼠标指针样式。参见通用枚举。 ### MouseIcon ```vb Property Get MouseIcon() As IPictureDisp Property Let MouseIcon(ByVal Value As IPictureDisp) Property Set MouseIcon(ByVal Value As IPictureDisp) ``` 自定义鼠标图标。 ### HotMousePointer ```vb Property Get HotMousePointer() As CCMousePointerConstants Property Let HotMousePointer(ByVal Value As CCMousePointerConstants) ``` 热项鼠标指针样式。参见通用枚举。 ### HotMouseIcon ```vb Property Get HotMouseIcon() As IPictureDisp Property Let HotMouseIcon(ByVal Value As IPictureDisp) Property Set HotMouseIcon(ByVal Value As IPictureDisp) ``` 热项自定义鼠标图标。 ### HeaderMousePointer ```vb Property Get HeaderMousePointer() As CCMousePointerConstants Property Let HeaderMousePointer(ByVal Value As CCMousePointerConstants) ``` 列标题鼠标指针样式。参见通用枚举。 ### HeaderMouseIcon ```vb Property Get HeaderMouseIcon() As IPictureDisp Property Let HeaderMouseIcon(ByVal Value As IPictureDisp) Property Set HeaderMouseIcon(ByVal Value As IPictureDisp) ``` 列标题自定义鼠标图标。 ### MouseTrack ```vb Property Get MouseTrack() As Boolean Property Let MouseTrack(ByVal Value As Boolean) ``` 是否启用鼠标进入/离开跟踪。 ### RightToLeft ```vb Property Get RightToLeft() As Boolean Property Let RightToLeft(ByVal Value As Boolean) ``` 从右到左显示方向。 ### RightToLeftLayout ```vb Property Get RightToLeftLayout() As Boolean Property Let RightToLeftLayout(ByVal Value As Boolean) ``` 从右到左镜像布局。 ### RightToLeftMode ```vb Property Get RightToLeftMode() As CCRightToLeftModeConstants Property Let RightToLeftMode(ByVal Value As CCRightToLeftModeConstants) ``` 从右到左模式。参见通用枚举。 ### hWnd ```vb Property Get hWnd() As LongPtr ``` 列表视图控件的窗口句柄。 ### hWndUserControl ```vb Property Get hWndUserControl() As LongPtr ``` 用户控件的窗口句柄。 ### hWndHeader ```vb Property Get hWndHeader() As LongPtr ``` 列标题控件的窗口句柄。 ### hWndLabelEdit ```vb Property Get hWndLabelEdit() As LongPtr ``` 标签编辑框的窗口句柄。 ### ToolTipText ```vb Property Get ToolTipText() As String Property Let ToolTipText(ByVal Value As String) ``` 工具提示文本。 ### Name ```vb Property Get Name() As String ``` 控件名称。只读。 ### Tag ```vb Property Get Tag() As String Property Let Tag(ByVal Value As String) ``` 自定义数据。 ### Parent ```vb Property Get Parent() As Object ``` 父对象。只读。 ### Container ```vb Property Get Container() As Object Property Set Container(ByVal Value As Object) ``` 容器对象。 ### Left ```vb Property Get Left() As Single Property Let Left(ByVal Value As Single) ``` 左边距。 ### Top ```vb Property Get Top() As Single Property Let Top(ByVal Value As Single) ``` 顶边距。 ### Width ```vb Property Get Width() As Single Property Let Width(ByVal Value As Single) ``` 宽度。 ### Height ```vb Property Get Height() As Single Property Let Height(ByVal Value As Single) ``` 高度。 ### Visible ```vb Property Get Visible() As Boolean Property Let Visible(ByVal Value As Boolean) ``` 是否可见。 ### HelpContextID ```vb Property Get HelpContextID() As Long Property Let HelpContextID(ByVal Value As Long) ``` 帮助上下文 ID。 ### WhatsThisHelpID ```vb Property Get WhatsThisHelpID() As Long Property Let WhatsThisHelpID(ByVal Value As Long) ``` "这是什么"帮助 ID。 ### DragIcon ```vb Property Get DragIcon() As IPictureDisp Property Let DragIcon(ByVal Value As IPictureDisp) Property Set DragIcon(ByVal Value As IPictureDisp) ``` 拖动图标。 ### DragMode ```vb Property Get DragMode() As Integer Property Let DragMode(ByVal Value As Integer) ``` 拖动模式。 ## 方法 ### Refresh ```vb Public Sub Refresh() ``` 强制重绘控件。 ### HitTest ```vb Public Function HitTest(ByVal X As Single, ByVal Y As Single, Optional ByRef SubItemIndex As Variant) As LvwListItem ``` 命中测试，返回指定坐标处的列表项。 ### HitTestInsertMark ```vb Public Function HitTestInsertMark(ByVal X As Single, ByVal Y As Single, Optional ByRef After As Boolean) As LvwListItem ``` 插入标记命中测试，返回插入位置的列表项。 ### FindItem ```vb Public Function FindItem(ByVal Text As String, Optional ByVal Index As Long, Optional ByVal Partial As Boolean, Optional ByVal Wrap As Boolean) As LvwListItem ``` 查找匹配文本的列表项。 ### FindNearestItem ```vb Public Function FindNearestItem(ByVal X As Single, ByVal Y As Single, Optional ByVal Direction As LvwFindDirectionConstants) As LvwListItem ``` 查找指定方向最近的列表项。 ### FindSubItem ```vb Public Function FindSubItem(ByVal Text As String, Optional ByVal Index As Long, Optional ByRef SubItemIndex As Long, Optional ByVal Partial As Boolean, Optional ByVal Wrap As Boolean) As LvwListItem ``` 查找匹配文本的子项。 ### GetVisibleCount ```vb Public Function GetVisibleCount() As Long ``` 获取可见项数量。 ### GetSelectedCount ```vb Public Function GetSelectedCount() As Long ``` 获取选中项数量。 ### GetHeaderHeight ```vb Public Function GetHeaderHeight() As Single ``` 获取列标题高度。 ### StartLabelEdit ```vb Public Sub StartLabelEdit() ``` 开始标签编辑。 ### EndLabelEdit ```vb Public Sub EndLabelEdit() ``` 结束标签编辑。 ### Scroll ```vb Public Sub Scroll(ByVal X As Single, ByVal Y As Single) ``` 滚动列表视图内容。 ### ResetEmptyMarkup ```vb Public Sub ResetEmptyMarkup() ``` 重置空标记文本。 ### ComputeControlSize ```vb Public Sub ComputeControlSize(ByVal VisibleCount As Long, ByRef Width As Single, ByRef Height As Single, Optional ByVal ProposedWidth As Single, Optional ByVal ProposedHeight As Single) ``` 计算显示指定数量项所需的控件尺寸。 ### TextWidth ```vb Public Function TextWidth(ByVal Text As String) As Single ``` 计算文本宽度。 ### ResetForeColors ```vb Public Sub ResetForeColors() ``` 重置所有列表项和子项的前景色。 ### SelectedIndices ```vb Public Function SelectedIndices() As Collection ``` 获取所有选中项索引的集合。 ### GhostedIndices ```vb Public Function GhostedIndices() As Collection ``` 获取所有幻影项索引的集合。 ### CheckedIndices ```vb Public Function CheckedIndices() As Collection ``` 获取所有选中（复选框）项索引的集合。 ### ResetIconSpacing ```vb Public Sub ResetIconSpacing() ``` 重置图标间距为默认值。 ### OLEDrag ```vb Public Sub OLEDrag() ``` 启动 OLE 拖放操作。 ### Drag ```vb Public Sub Drag(Optional ByRef Action As Variant) ``` 开始、结束或取消拖动操作。 ### SetFocus ```vb Public Sub SetFocus() ``` 获取焦点。 ### ZOrder ```vb Public Sub ZOrder(Optional ByRef Position As Variant) ``` 调整 Z 顺序。 ### Move ```vb Public Sub Move(ByVal Left As Single, Optional ByVal Top As Variant, Optional ByVal Width As Variant, Optional ByVal Height As Variant) ``` 移动并调整控件位置和大小。 ## 事件 ### Click ```vb Public Event Click() ``` 单击。 ### DblClick ```vb Public Event DblClick() ``` 双击。 ### ItemClick ```vb Public Event ItemClick(ByVal Item As LvwListItem, ByVal Button As Integer) ``` 列表项被点击。 ### ItemDblClick ```vb Public Event ItemDblClick(ByVal Item As LvwListItem, ByVal Button As Integer) ``` 列表项被双击。 ### ItemFocus ```vb Public Event ItemFocus(ByVal Item As LvwListItem) ``` 列表项获得焦点。 ### ItemActivate ```vb Public Event ItemActivate(ByVal Item As LvwListItem, ByVal SubItemIndex As Long, ByVal Shift As Integer) ``` 列表项被激活。 ### ItemSelect ```vb Public Event ItemSelect(ByVal Item As LvwListItem, ByVal Selected As Boolean) ``` 列表项选中状态改变。 ### ItemCheck ```vb Public Event ItemCheck(ByVal Item As LvwListItem, ByVal Checked As Boolean) ``` 列表项复选框状态改变。 ### ItemDrag ```vb Public Event ItemDrag(ByVal Item As LvwListItem, ByVal Button As Integer) ``` 列表项启动拖放操作。 ### ItemBkColor ```vb Public Event ItemBkColor(ByVal Item As LvwListItem, ByRef RGBColor As Long) ``` 列表项背景色请求（报表视图），可提供替代背景色。 ### GetVirtualItem ```vb Public Event GetVirtualItem(ByVal ItemIndex As Long, ByVal SubItemIndex As Long, ByVal VirtualProperty As LvwVirtualPropertyConstants, ByRef Value As Variant) ``` 虚拟模式下请求项属性。 ### FindVirtualItem ```vb Public Event FindVirtualItem(ByVal StartIndex As Long, ByVal SearchText As String, ByVal Partial As Boolean, ByVal Wrap As Boolean, ByRef FoundIndex As Long) ``` 虚拟模式下查找项。 ### CacheVirtualItems ```vb Public Event CacheVirtualItems(ByVal FromIndex As Long, ByVal ToIndex As Long) ``` 虚拟模式下请求缓存项范围。 ### BeforeLabelEdit ```vb Public Event BeforeLabelEdit(ByRef Cancel As Boolean) ``` 标签编辑前触发，可取消。 ### AfterLabelEdit ```vb Public Event AfterLabelEdit(ByRef Cancel As Boolean, ByRef NewString As String) ``` 标签编辑后触发。 ### ColumnClick ```vb Public Event ColumnClick(ByVal ColumnHeader As LvwColumnHeader) ``` 列标题被点击。 ### ColumnDblClick ```vb Public Event ColumnDblClick(ByVal ColumnHeader As LvwColumnHeader) ``` 列标题被双击。 ### ColumnCheck ```vb Public Event ColumnCheck(ByVal ColumnHeader As LvwColumnHeader) ``` 列标题复选框状态改变。 ### ColumnBeforeResize ```vb Public Event ColumnBeforeResize(ByVal ColumnHeader As LvwColumnHeader, ByRef Cancel As Boolean) ``` 列宽即将调整，可取消。 ### ColumnAfterResize ```vb Public Event ColumnAfterResize(ByVal ColumnHeader As LvwColumnHeader, ByRef NewWidth As Single) ``` 列宽调整完成。 ### ColumnDividerDblClick ```vb Public Event ColumnDividerDblClick(ByVal ColumnHeader As LvwColumnHeader, ByRef Cancel As Boolean) ``` 列分隔线被双击。 ### ColumnBeforeDrag ```vb Public Event ColumnBeforeDrag(ByVal ColumnHeader As LvwColumnHeader) ``` 列标题开始拖动。 ### ColumnAfterDrag ```vb Public Event ColumnAfterDrag(ByVal ColumnHeader As LvwColumnHeader, ByVal NewPosition As Long, ByRef Cancel As Boolean) ``` 列标题拖动完成。 ### ColumnDropDown ```vb Public Event ColumnDropDown(ByVal ColumnHeader As LvwColumnHeader) ``` 列标题下拉按钮被点击。 ### ColumnChevronPushed ```vb Public Event ColumnChevronPushed(ByVal ColumnHeader As LvwColumnHeader) ``` 列折叠按钮被点击。 ### ColumnFilterChanged ```vb Public Event ColumnFilterChanged(ByVal ColumnHeader As LvwColumnHeader) ``` 列筛选条件变更。 ### ColumnFilterButtonClick ```vb Public Event ColumnFilterButtonClick(ByVal ColumnHeader As LvwColumnHeader, ByRef RaiseFilterChanged As Boolean, ByVal ButtonLeft As Long, ByVal ButtonTop As Long, ByVal ButtonRight As Long, ByVal ButtonBottom As Long) ``` 列筛选按钮被点击。 ### BeforeFilterEdit ```vb Public Event BeforeFilterEdit(ByVal ColumnHeader As LvwColumnHeader, ByVal hWndFilterEdit As LongPtr) ``` 列筛选编辑前触发。 ### AfterFilterEdit ```vb Public Event AfterFilterEdit(ByVal ColumnHeader As LvwColumnHeader) ``` 列筛选编辑后触发。 ### GetEmptyMarkup ```vb Public Event GetEmptyMarkup(ByRef Text As String, ByRef Center As Boolean) ``` 列表为空时请求标记文本。 ### GroupCollapsedChanged ```vb Public Event GroupCollapsedChanged(ByVal Group As LvwGroup) ``` 分组折叠状态变更。 ### GroupSelectedChanged ```vb Public Event GroupSelectedChanged(ByVal Group As LvwGroup) ``` 分组选中状态变更。 ### GroupLinkClick ```vb Public Event GroupLinkClick(ByVal Group As LvwGroup) ``` 分组链接被点击。 ### BeginMarqueeSelection ```vb Public Event BeginMarqueeSelection(ByRef Cancel As Boolean) ``` 框选开始，可取消。 ### BeforeScroll ```vb Public Event BeforeScroll(ByVal DeltaX As Single, ByVal DeltaY As Single) ``` 即将滚动前触发。 ### AfterScroll ```vb Public Event AfterScroll(ByVal DeltaX As Single, ByVal DeltaY As Single) ``` 滚动完成后触发。 ### DropFiles ```vb Public Event DropFiles(ByRef FileList As Variant, ByVal X As Single, ByVal Y As Single) ``` 拖放文件到控件时触发。 ### ContextMenu ```vb Public Event ContextMenu(ByVal X As Single, ByVal Y As Single) ``` 右键菜单请求时触发。 ### PreviewKeyDown ```vb Public Event PreviewKeyDown(ByVal KeyCode As Integer, ByRef IsInputKey As Boolean) ``` 按键前事件，在 KeyDown 之前触发。 ### PreviewKeyUp ```vb Public Event PreviewKeyUp(ByVal KeyCode As Integer, ByRef IsInputKey As Boolean) ``` 按键释放前事件，在 KeyUp 之前触发。 ### KeyDown ```vb Public Event KeyDown(KeyCode As Integer, Shift As Integer) ``` 按键按下。 ### KeyUp ```vb Public Event KeyUp(KeyCode As Integer, Shift As Integer) ``` 按键释放。 ### KeyPress ```vb Public Event KeyPress(KeyChar As Integer) ``` 按键字符。 ### MouseDown ```vb Public Event MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` 鼠标按下。 ### MouseMove ```vb Public Event MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` 鼠标移动。 ### MouseUp ```vb Public Event MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` 鼠标释放。 ### MouseEnter ```vb Public Event MouseEnter() ``` 鼠标进入控件。 ### MouseLeave ```vb Public Event MouseLeave() ``` 鼠标离开控件。 ### OLECompleteDrag ```vb Public Event OLECompleteDrag(Effect As Long) ``` OLE 拖放完成。 ### OLEDragDrop ```vb Public Event OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single) ``` OLE 拖放落下。 ### OLEDragOver ```vb Public Event OLEDragOver(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single, State As Integer) ``` OLE 拖放悬停。 ### OLEGiveFeedback ```vb Public Event OLEGiveFeedback(Effect As Long, DefaultCursors As Boolean) ``` OLE 给出反馈。 ### OLESetData ```vb Public Event OLESetData(Data As DataObject, DataFormat As Integer) ``` OLE 设置数据。 ### OLEStartDrag ```vb Public Event OLEStartDrag(Data As DataObject, AllowedEffects As Long) ``` OLE 开始拖动。 ## 子对象 ### LvwColumnHeader 列标题对象。 #### 属性 | 名称 | 签名 | 说明 | |------|------|------| | Index | `Property Get Index() As Long` | 索引。只读 | | Key | `Property Get Key() As String` / `Property Let Key(ByVal Value As String)` | 键值 | | Tag | `Property Get Tag() As Variant` / `Property Let Tag(ByVal Value As Variant)` / `Property Set Tag(ByVal Value As Variant)` | 自定义数据 | | Text | `Property Get Text() As String` / `Property Let Text(ByVal Value As String)` | 标题文本 | | Icon | `Property Get Icon() As Variant` / `Property Let Icon(ByVal Value As Variant)` | 图标 | | IconIndex | `Property Get IconIndex() As Long` | 图标索引。只读 | | Width | `Property Get Width() As Single` / `Property Let Width(ByVal Value As Single)` | 列宽 | | Alignment | `Property Get Alignment() As LvwColumnHeaderAlignmentConstants` / `Property Let Alignment(ByVal Value As LvwColumnHeaderAlignmentConstants)` | 对齐方式 | | Position | `Property Get Position() As Long` / `Property Let Position(ByVal Value As Long)` | 位置 | | SortArrow | `Property Get SortArrow() As LvwColumnHeaderSortArrowConstants` / `Property Let SortArrow(ByVal Value As LvwColumnHeaderSortArrowConstants)` | 排序箭头 | | IconOnRight | `Property Get IconOnRight() As Boolean` / `Property Let IconOnRight(ByVal Value As Boolean)` | 图标在右侧 | | Resizable | `Property Get Resizable() As Boolean` / `Property Let Resizable(ByVal Value As Boolean)` | 是否可调整大小 | | SplitButton | `Property Get SplitButton() As Boolean` / `Property Let SplitButton(ByVal Value As Boolean)` | 是否显示分割按钮 | | CheckBox | `Property Get CheckBox() As Boolean` / `Property Let CheckBox(ByVal Value As Boolean)` | 是否显示复选框 | | Checked | `Property Get Checked() As Boolean` / `Property Let Checked(ByVal Value As Boolean)` | 复选框选中状态 | | Bold | `Property Get Bold() As Boolean` / `Property Let Bold(ByVal Value As Boolean)` | 是否粗体 | | ForeColor | `Property Get ForeColor() As OLE_COLOR` / `Property Let ForeColor(ByVal Value As OLE_COLOR)` | 前景色 | | ToolTipText | `Property Get ToolTipText() As String` / `Property Let ToolTipText(ByVal Value As String)` | 工具提示文本 | | ToolTipTextFilterBtn | `Property Get ToolTipTextFilterBtn() As String` / `Property Let ToolTipTextFilterBtn(ByVal Value As String)` | 筛选按钮工具提示 | | ToolTipTextDropDown | `Property Get ToolTipTextDropDown() As String` / `Property Let ToolTipTextDropDown(ByVal Value As String)` | 下拉按钮工具提示 | | FilterType | `Property Get FilterType() As LvwColumnHeaderFilterTypeConstants` / `Property Let FilterType(ByVal Value As LvwColumnHeaderFilterTypeConstants)` | 筛选类型 | | FilterValue | `Property Get FilterValue() As Variant` / `Property Let FilterValue(ByVal Value As Variant)` | 筛选值 | | Left | `Property Get Left() As Single` / `Property Let Left(ByVal Value As Single)` | 左边距 | #### 方法 | 名称 | 签名 | 说明 | |------|------|------| | AutoSize | `Public Sub AutoSize(ByVal Value As LvwColumnHeaderAutoSizeConstants)` | 自动调整列宽 | | EditFilter | `Public Sub EditFilter()` | 编辑筛选条件 | | ClearFilter | `Public Sub ClearFilter()` | 清除筛选条件 | | SubItemIndex | `Public Function SubItemIndex() As Long` | 获取对应的子项索引 | ### LvwColumnHeaders 列标题集合。 #### 属性 | 名称 | 签名 | 说明 | |------|------|------| | Item | `Property Get Item(ByVal Index As Variant) As LvwColumnHeader` | 按索引获取列标题 | | ItemFromPosition | `Property Get ItemFromPosition(ByVal Position As Long) As LvwColumnHeader` | 按位置获取列标题 | | Count | `Property Get Count() As Long` | 列标题数量。只读 | #### 方法 | 名称 | 签名 | 说明 | |------|------|------| | Add | `Public Function Add(Optional ByVal Index As Long, Optional ByVal Key As String, Optional ByVal Text As String, Optional ByVal Width As Variant, Optional ByVal Alignment As LvwColumnHeaderAlignmentConstants, Optional ByVal Icon As Variant) As LvwColumnHeader` | 添加列标题 | | Exists | `Public Function Exists(ByVal Index As Variant) As Boolean` | 检查列标题是否存在 | | Clear | `Public Sub Clear()` | 清除所有列标题 | | Remove | `Public Sub Remove(ByVal Index As Variant)` | 移除列标题 | | NewEnum | `Public Function NewEnum() As IEnumVARIANT` | 枚举器 | ### LvwListItem 列表项对象。 #### 属性 | 名称 | 签名 | 说明 | |------|------|------| | Index | `Property Get Index() As Long` | 索引。只读 | | Key | `Property Get Key() As String` / `Property Let Key(ByVal Value As String)` | 键值 | | Tag | `Property Get Tag() As Variant` / `Property Let Tag(ByVal Value As Variant)` / `Property Set Tag(ByVal Value As Variant)` | 自定义数据 | | Text | `Property Get Text() As String` / `Property Let Text(ByVal Value As String)` | 文本 | | Icon | `Property Get Icon() As Variant` / `Property Let Icon(ByVal Value As Variant)` | 大图标 | | IconIndex | `Property Get IconIndex() As Long` | 大图标索引。只读 | | SmallIcon | `Property Get SmallIcon() As Variant` / `Property Let SmallIcon(ByVal Value As Variant)` | 小图标 | | SmallIconIndex | `Property Get SmallIconIndex() As Long` | 小图标索引。只读 | | Indentation | `Property Get Indentation() As Long` / `Property Let Indentation(ByVal Value As Long)` | 缩进 | | Selected | `Property Get Selected() As Boolean` / `Property Let Selected(ByVal Value As Boolean)` | 是否选中 | | Checked | `Property Get Checked() As Boolean` / `Property Let Checked(ByVal Value As Boolean)` | 复选框状态 | | Ghosted | `Property Get Ghosted() As Boolean` / `Property Let Ghosted(ByVal Value As Boolean)` | 是否幻影显示 | | Hot | `Property Get Hot() As Boolean` / `Property Let Hot(ByVal Value As Boolean)` | 是否为热项 | | Bold | `Property Get Bold() As Boolean` / `Property Let Bold(ByVal Value As Boolean)` | 是否粗体 | | ForeColor | `Property Get ForeColor() As OLE_COLOR` / `Property Let ForeColor(ByVal Value As OLE_COLOR)` | 前景色 | | ToolTipText | `Property Get ToolTipText() As String` / `Property Let ToolTipText(ByVal Value As String)` | 工具提示文本 | | Left | `Property Get Left() As Single` / `Property Let Left(ByVal Value As Single)` | 左边距 | | Top | `Property Get Top() As Single` / `Property Let Top(ByVal Value As Single)` | 顶边距 | | Width | `Property Get Width() As Single` / `Property Let Width(ByVal Value As Single)` | 宽度 | | Height | `Property Get Height() As Single` / `Property Let Height(ByVal Value As Single)` | 高度 | | Visible | `Property Get Visible() As Boolean` | 是否可见。只读 | | TileViewIndices | `Property Get TileViewIndices() As Variant` / `Property Let TileViewIndices(ByVal ArgList As Variant)` | 平铺视图子项列索引 | | Group | `Property Get Group() As LvwGroup` / `Property Let Group(ByVal Value As LvwGroup)` / `Property Set Group(ByVal Value As LvwGroup)` | 所属分组 | | WorkArea | `Property Get WorkArea() As LvwWorkArea` | 所属工作区域。只读 | | ListSubItems | `Property Get ListSubItems() As LvwListSubItems` | 子项集合。只读 | | SubItems | `Property Get SubItems(ByVal Index As Integer) As String` / `Property Let SubItems(ByVal Index As Integer, ByVal Value As String)` | 按索引获取或设置子项文本 | #### 方法 | 名称 | 签名 | 说明 | |------|------|------| | EnsureVisible | `Public Sub EnsureVisible()` | 确保项可见 | | CreateDragImage | `Public Function CreateDragImage(Optional ByRef X As Single, Optional ByRef Y As Single) As LongPtr` | 创建拖动图像 | ### LvwListItems 列表项集合。 #### 属性 | 名称 | 签名 | 说明 | |------|------|------| | Item | `Property Get Item(ByVal Index As Variant) As LvwListItem` | 按索引获取列表项 | | Count | `Property Get Count() As Long` | 列表项数量。只读 | #### 方法 | 名称 | 签名 | 说明 | |------|------|------| | Add | `Public Function Add(Optional ByVal Index As Long, Optional ByVal Key As String, Optional ByVal Text As String, Optional ByVal Icon As Variant, Optional ByVal SmallIcon As Variant) As LvwListItem` | 添加列表项 | | Exists | `Public Function Exists(ByVal Index As Variant) As Boolean` | 检查列表项是否存在 | | Clear | `Public Sub Clear()` | 清除所有列表项 | | Remove | `Public Sub Remove(ByVal Index As Variant)` | 移除列表项 | | NewEnum | `Public Function NewEnum() As IEnumVARIANT` | 枚举器 | ### LvwListSubItem 列表子项对象。 #### 属性 | 名称 | 签名 | 说明 | |------|------|------| | Index | `Property Get Index() As Long` | 索引。只读 | | Key | `Property Get Key() As String` | 键值。只读 | | Tag | `Property Get Tag() As Variant` / `Property Let Tag(ByVal Value As Variant)` / `Property Set Tag(ByVal Value As Variant)` | 自定义数据 | | Text | `Property Get Text() As String` / `Property Let Text(ByVal Value As String)` | 文本 | | ReportIcon | `Property Get ReportIcon() As Variant` / `Property Let ReportIcon(ByVal Value As Variant)` | 报表视图图标 | | ReportIconIndex | `Property Get ReportIconIndex() As Long` | 报表视图图标索引。只读 | | Bold | `Property Get Bold() As Boolean` / `Property Let Bold(ByVal Value As Boolean)` | 是否粗体 | | ForeColor | `Property Get ForeColor() As OLE_COLOR` / `Property Let ForeColor(ByVal Value As OLE_COLOR)` | 前景色 | | ToolTipText | `Property Get ToolTipText() As String` / `Property Let ToolTipText(ByVal Value As String)` | 工具提示文本 | | Left | `Property Get Left() As Single` / `Property Let Left(ByVal Value As Single)` | 左边距 | | Top | `Property Get Top() As Single` / `Property Let Top(ByVal Value As Single)` | 顶边距 | | Width | `Property Get Width() As Single` / `Property Let Width(ByVal Value As Single)` | 宽度 | | Height | `Property Get Height() As Single` / `Property Let Height(ByVal Value As Single)` | 高度 | ### LvwListSubItems 列表子项集合。 #### 属性 | 名称 | 签名 | 说明 | |------|------|------| | Item | `Property Get Item(ByVal Index As Variant) As LvwListSubItem` | 按索引获取子项 | | Count | `Property Get Count() As Long` | 子项数量。只读 | #### 方法 | 名称 | 签名 | 说明 | |------|------|------| | Add | `Public Function Add(Optional ByVal Index As Long, Optional ByVal Key As String, Optional ByVal Text As String, Optional ByVal ReportIcon As Variant, Optional ByVal ToolTipText As String) As LvwListSubItem` | 添加子项 | | Exists | `Public Function Exists(ByVal Index As Variant) As Boolean` | 检查子项是否存在 | | Clear | `Public Sub Clear()` | 清除所有子项 | | Remove | `Public Sub Remove(ByVal Index As Variant)` | 移除子项 | | NewEnum | `Public Function NewEnum() As IEnumVARIANT` | 枚举器 | ### LvwGroup 分组对象。 #### 属性 | 名称 | 签名 | 说明 | |------|------|------| | Index | `Property Get Index() As Long` | 索引。只读 | | Key | `Property Get Key() As String` / `Property Let Key(ByVal Value As String)` | 键值 | | Tag | `Property Get Tag() As Variant` / `Property Let Tag(ByVal Value As Variant)` / `Property Set Tag(ByVal Value As Variant)` | 自定义数据 | | ID | `Property Get ID() As Long` | 分组 ID。只读 | | Header | `Property Get Header() As String` / `Property Let Header(ByVal Value As String)` | 分组标题 | | HeaderAlignment | `Property Get HeaderAlignment() As LvwGroupHeaderAlignmentConstants` / `Property Let HeaderAlignment(ByVal Value As LvwGroupHeaderAlignmentConstants)` | 标题对齐方式 | | Footer | `Property Get Footer() As String` / `Property Let Footer(ByVal Value As String)` | 分组页脚 | | FooterAlignment | `Property Get FooterAlignment() As LvwGroupFooterAlignmentConstants` / `Property Let FooterAlignment(ByVal Value As LvwGroupFooterAlignmentConstants)` | 页脚对齐方式 | | Hint | `Property Get Hint() As String` / `Property Let Hint(ByVal Value As String)` | 提示文本 | | Link | `Property Get Link() As String` / `Property Let Link(ByVal Value As String)` | 链接文本 | | SubsetLink | `Property Get SubsetLink() As String` / `Property Let SubsetLink(ByVal Value As String)` | 子集链接文本 | | Collapsible | `Property Get Collapsible() As Boolean` / `Property Let Collapsible(ByVal Value As Boolean)` | 是否可折叠 | | Collapsed | `Property Get Collapsed() As Boolean` / `Property Let Collapsed(ByVal Value As Boolean)` | 是否已折叠 | | ShowHeader | `Property Get ShowHeader() As Boolean` / `Property Let ShowHeader(ByVal Value As Boolean)` | 是否显示标题 | | Selected | `Property Get Selected() As Boolean` / `Property Let Selected(ByVal Value As Boolean)` | 是否选中 | | Subseted | `Property Get Subseted() As Boolean` / `Property Let Subseted(ByVal Value As Boolean)` | 是否为子集 | | SubsetLinkSelected | `Property Get SubsetLinkSelected() As Boolean` / `Property Let SubsetLinkSelected(ByVal Value As Boolean)` | 子集链接是否选中 | | Icon | `Property Get Icon() As Variant` / `Property Let Icon(ByVal Value As Variant)` | 图标 | | IconIndex | `Property Get IconIndex() As Long` | 图标索引。只读 | | Position | `Property Get Position() As Long` / `Property Let Position(ByVal Value As Long)` | 位置 | | Left | `Property Get Left() As Single` / `Property Let Left(ByVal Value As Single)` | 左边距 | | Top | `Property Get Top() As Single` / `Property Let Top(ByVal Value As Single)` | 顶边距 | | Width | `Property Get Width() As Single` / `Property Let Width(ByVal Value As Single)` | 宽度 | | Height | `Property Get Height() As Single` / `Property Let Height(ByVal Value As Single)` | 高度 | | ListItemCount | `Property Get ListItemCount() As Long` | 列表项数量。只读 | | ListItemIndices | `Property Get ListItemIndices() As Collection` | 列表项索引集合。只读 | ### LvwGroups 分组集合。 #### 属性 | 名称 | 签名 | 说明 | |------|------|------| | Item | `Property Get Item(ByVal Index As Variant) As LvwGroup` | 按索引获取分组 | | Count | `Property Get Count() As Long` | 分组数量。只读 | | Sorted | `Property Get Sorted() As Boolean` / `Property Let Sorted(ByVal Value As Boolean)` | 是否排序 | | SortOrder | `Property Get SortOrder() As LvwSortOrderConstants` / `Property Let SortOrder(ByVal Value As LvwSortOrderConstants)` | 排序顺序 | | SortType | `Property Get SortType() As LvwSortTypeConstants` / `Property Let SortType(ByVal Value As LvwSortTypeConstants)` | 排序类型 | #### 方法 | 名称 | 签名 | 说明 | |------|------|------| | Add | `Public Function Add(Optional ByVal Index As Long, Optional ByVal Key As String, Optional ByVal Header As String, Optional ByVal HeaderAlignment As LvwGroupHeaderAlignmentConstants, Optional ByVal Footer As String, Optional ByVal FooterAlignment As LvwGroupFooterAlignmentConstants) As LvwGroup` | 添加分组 | | Exists | `Public Function Exists(ByVal Index As Variant) As Boolean` | 检查分组是否存在 | | Clear | `Public Sub Clear()` | 清除所有分组 | | Remove | `Public Sub Remove(ByVal Index As Variant)` | 移除分组 | | NewEnum | `Public Function NewEnum() As IEnumVARIANT` | 枚举器 | ### LvwVirtualListItem 虚拟列表项对象。 #### 属性 | 名称 | 签名 | 说明 | |------|------|------| | Index | `Property Get Index() As Long` | 索引。只读 | | Text | `Property Get Text() As String` | 文本。只读 | | Indentation | `Property Get Indentation() As Long` | 缩进。只读 | | Selected | `Property Get Selected() As Boolean` / `Property Let Selected(ByVal Value As Boolean)` | 是否选中 | | Checked | `Property Get Checked() As Boolean` | 复选框状态。只读 | | Hot | `Property Get Hot() As Boolean` / `Property Let Hot(ByVal Value As Boolean)` | 是否为热项 | | Left | `Property Get Left() As Single` / `Property Let Left(ByVal Value As Single)` | 左边距 | | Top | `Property Get Top() As Single` / `Property Let Top(ByVal Value As Single)` | 顶边距 | | Width | `Property Get Width() As Single` / `Property Let Width(ByVal Value As Single)` | 宽度 | | Height | `Property Get Height() As Single` / `Property Let Height(ByVal Value As Single)` | 高度 | | Visible | `Property Get Visible() As Boolean` | 是否可见。只读 | | SubItems | `Property Get SubItems(ByVal Index As Integer) As String` | 按索引获取子项文本。只读 | #### 方法 | 名称 | 签名 | 说明 | |------|------|------| | EnsureVisible | `Public Sub EnsureVisible()` | 确保项可见 | | CreateDragImage | `Public Function CreateDragImage(Optional ByRef X As Single, Optional ByRef Y As Single) As LongPtr` | 创建拖动图像 | ### LvwVirtualListItems 虚拟列表项集合。 #### 属性 | 名称 | 签名 | 说明 | |------|------|------| | Item | `Property Get Item(ByVal Index As Long) As LvwVirtualListItem` | 按索引获取虚拟列表项 | | Count | `Property Get Count() As Long` | 虚拟列表项数量。只读 | #### 方法 | 名称 | 签名 | 说明 | |------|------|------| | Exists | `Public Function Exists(ByVal Index As Long) As Boolean` | 检查虚拟列表项是否存在 | | NewEnum | `Public Function NewEnum() As IEnumVARIANT` | 枚举器 | ### LvwWorkArea 工作区域对象。 #### 属性 | 名称 | 签名 | 说明 | |------|------|------| | Index | `Property Get Index() As Long` | 索引。只读 | | Left | `Property Get Left() As Single` / `Property Let Left(ByVal Value As Single)` | 左边距 | | Top | `Property Get Top() As Single` / `Property Let Top(ByVal Value As Single)` | 顶边距 | | Width | `Property Get Width() As Single` / `Property Let Width(ByVal Value As Single)` | 宽度 | | Height | `Property Get Height() As Single` / `Property Let Height(ByVal Value As Single)` | 高度 | | ListItemIndices | `Property Get ListItemIndices() As Collection` | 工作区域中的列表项索引集合。只读 | ### LvwWorkAreas 工作区域集合。 #### 属性 | 名称 | 签名 | 说明 | |------|------|------| | Item | `Property Get Item(ByVal Index As Long) As LvwWorkArea` | 按索引获取工作区域 | | Count | `Property Get Count() As Long` | 工作区域数量。只读 | #### 方法 | 名称 | 签名 | 说明 | |------|------|------| | Add | `Public Function Add(ByVal Left As Single, ByVal Top As Single, ByVal Width As Single, ByVal Height As Single, Optional ByVal Index As Long) As LvwWorkArea` | 添加工作区域 | | Exists | `Public Function Exists(ByVal Index As Long) As Boolean` | 检查工作区域是否存在 | | Clear | `Public Sub Clear()` | 清除所有工作区域 | | Remove | `Public Sub Remove(ByVal Index As Long)` | 移除工作区域 | | NewEnum | `Public Function NewEnum() As IEnumVARIANT` | 枚举器 | ## 代码示例 ### 报表视图基本用法 ```vb ' 设置报表视图 ListView1.View = LvwViewReport ' 添加列标题 With ListView1.ColumnHeaders .Add , , "姓名", 120 .Add , , "年龄", 60, LvwColumnHeaderAlignmentCenter .Add , , "城市", 100 End With ' 添加列表项 Dim li As LvwListItem Set li = ListView1.ListItems.Add(, , "张三") li.SubItems(1) = "28" li.SubItems(2) = "北京" Set li = ListView1.ListItems.Add(, , "李四") li.SubItems(1) = "35" li.SubItems(2) = "上海" ``` ### 分组视图 ```vb ' 启用分组 ListView1.GroupView = True ListView1.View = LvwViewReport ' 添加分组 Dim grp1 As LvwGroup, grp2 As LvwGroup Set grp1 = ListView1.Groups.Add(, , "一组") Set grp2 = ListView1.Groups.Add(, , "二组") ' 将项分配到分组 Set ListView1.ListItems(1).Group = grp1 Set ListView1.ListItems(2).Group = grp2 ``` ### 虚拟模式 ```vb ' 启用虚拟模式 ListView1.VirtualMode = True ListView1.VirtualItemCount = 10000 ' 在 GetVirtualItem 事件中提供数据 Private Sub ListView1_GetVirtualItem(ByVal ItemIndex As Long, _ ByVal SubItemIndex As Long, _ ByVal VirtualProperty As LvwVirtualPropertyConstants, _ ByRef Value As Variant) If VirtualProperty = LvwVirtualPropertyText Then If SubItemIndex = 0 Then Value = "Item " & ItemIndex Else Value = "Sub " & SubItemIndex End If End If End Sub ``` ### 排序和筛选 ```vb ' 排序 ListView1.SortKey = 0 ListView1.SortOrder = LvwSortOrderAscending ListView1.SortType = LvwSortTypeText ListView1.Sorted = True ' 设置排序箭头 ListView1.ColumnHeaders(1).SortArrow = LvwColumnHeaderSortArrowDown ' 启用列筛选 ListView1.UseColumnFilterBar = True ``` --- --- url: /zh/vbman/httpserver/router.md --- # 路由系统详解 ## 简介 `cHttpServerRouter` 是 HttpServer 的核心组件，负责将 HTTP 请求映射到对应的处理程序。支持**手动路由**和**自动路由**两种模式，以及 HTTP 方法限定、参数路由、路由组等高级特性。 ## 路由执行流程 ``` ┌─────────────────────────────────────────────────────────────┐ │ 请求到达 │ └─────────────────────────────────────────────────────────────┘ │ ▼ ┌─────────────────────────────────────────────────────────────┐ │ 1. 静态文件检查 │ │ └─> 如果匹配 WebRoot 中的文件，直接返回静态文件 │ └─────────────────────────────────────────────────────────────┘ │ ▼ ┌─────────────────────────────────────────────────────────────┐ │ 2. 执行前置中间件 (RouteBefore) │ │ └─> 可以拦截请求、验证权限、记录日志等 │ └─────────────────────────────────────────────────────────────┘ │ ▼ ┌─────────────────────────────────────────────────────────────┐ │ 3. 路由匹配 │ │ ├─> a) 精确匹配手动路由（O(1) 字典查找） │ │ ├─> b) 参数路由模式匹配（{param} 通配） │ │ ├─> c) 检查自动路由 (如果开启) │ │ └─> d) 所有路由均未匹配 → 进入步骤 4 │ └─────────────────────────────────────────────────────────────┘ │ ▼ ┌─────────────────────────────────────────────────────────────┐ │ 4. 静态文件兜底（仅当配置了 WebRoot） │ │ ├─> 目录重定向：路径不以 / 结尾且对应物理目录 → 302 │ │ ├─> 默认文档查找：遍历 index.html / index.htm 等 │ │ ├─> 找到文件 → 返回静态文件 ✅ │ │ ├─> 目录无默认文档 → 403 Forbidden 🔒 │ │ └─> 不存在对应文件 → 进入步骤 5 │ └─────────────────────────────────────────────────────────────┘ │ ▼ ┌─────────────────────────────────────────────────────────────┐ │ 5. 404 未找到 │ └─────────────────────────────────────────────────────────────┘ │ ▼ ┌─────────────────────────────────────────────────────────────┐ │ 6. 执行控制器方法（仅在路由匹配成功时） │ │ └─> 调用匹配的 Controller@Action │ └─────────────────────────────────────────────────────────────┘ │ ▼ ┌─────────────────────────────────────────────────────────────┐ │ 7. 执行后置处理 (RouteAfter) │ │ └─> 可以添加响应头、记录响应日志等 │ └─────────────────────────────────────────────────────────────┘ ``` ## 手动路由 ### 基础路由 ```vb ' 注册控制器 Call Server.Router.Reg("User", New cUserController) Call Server.Router.Reg("Api", New cApiController) ' 添加路由 Call Server.Router.Add("/", "User@Index") ' GET/POST 均可访问 Call Server.Router.Add("/list", "User@List", OnlyGet) ' 仅 GET Call Server.Router.Add("/create", "User@Create", OnlyPost) ' 仅 POST ``` ### HTTP 方法限定 ```vb ' 任意方法（默认） Call Server.Router.Add("/any", "Home@Any", Any_) ' 仅 GET Call Server.Router.Add("/get", "Home@Get", OnlyGet) ' 仅 POST Call Server.Router.Add("/post", "Home@Post", OnlyPost) ' 仅 PUT Call Server.Router.Add("/put", "Home@Put", OnlyPut) ' 仅 DELETE Call Server.Router.Add("/delete", "Home@Delete", OnlyDelete) ``` ### RESTful API 路由示例 ```vb ' 用户资源 RESTful API Call Server.Router.Reg("User", New cUserController) ' GET /users -> 列表 Call Server.Router.Add("/users", "User@Index", OnlyGet) ' GET /users/detail?id=123 -> 详情（查询参数方式） Call Server.Router.Add("/users/detail", "User@Detail", OnlyGet) ' POST /users -> 创建 Call Server.Router.Add("/users", "User@Create", OnlyPost) ' PUT /users/update?id=123 -> 更新（查询参数方式） Call Server.Router.Add("/users/update", "User@Update", OnlyPut) ' DELETE /users/delete?id=123 -> 删除（查询参数方式） Call Server.Router.Add("/users/delete", "User@Delete", OnlyDelete) ``` > **更优雅的方式**：使用参数路由 `{param}` 可以直接在路径中传参，详见 [参数路由与路径段解析](./route-params.md) ### 控制器编写规范 ```vb ' cUserController.cls Option Explicit ' GET /users Public Sub Index(ctx As cHttpServerContext) Dim users As New Dictionary users("items") = Array("张三", "李四") users("total") = 2 ctx.Response.Json users, 0, "Success" End Sub ' GET /users/detail?id=123 Public Sub Detail(ctx As cHttpServerContext) Dim id As String id = ctx.Request.QueryString("id") Dim user As New Dictionary user("id") = id user("name") = "张三" ctx.Response.Json user End Sub ' POST /users Public Sub Create(ctx As cHttpServerContext) ' 获取表单数据 Dim name As String, email As String name = ctx.Request.Form("name") email = ctx.Request.Form("email") ' 或获取 JSON 数据 ' name = ctx.Request.Json.GetItem("name") ' 业务逻辑... ctx.Response.Json Nothing, 0, "创建成功" End Sub ' PUT /users/update Public Sub Update(ctx As cHttpServerContext) Dim id As String id = ctx.Request("id") ' 自动从 Query/Form/Json 获取 ctx.Response.Json Nothing, 0, "更新成功" End Sub ' DELETE /users/delete Public Sub Delete(ctx As cHttpServerContext) Dim id As String id = ctx.Request.QueryString("id") ctx.Response.Json Nothing, 0, "删除成功" End Sub ``` > **参数路由控制器示例**：使用 `RouteParams` 获取路径参数，详见 [参数路由与路径段解析](./route-params.md) ## 参数路由 支持在 URL 路径中使用 `{param}` 语法定义动态参数段，匹配后通过 `ctx.Request.RouteParams` 获取参数值。支持单参数、多参数、嵌套资源等场景。 👉 **完整文档**：[参数路由与路径段解析](./route-params.md) ## 自动路由 开启自动路由后，框架会根据 URL 路径自动解析控制器和方法。 ```vb ' 开启自动路由 Server.Router.AutoRoute = True ``` ### URL 解析规则 ``` 格式: /ControllerName/ActionName?param1=value1¶m2=value2 示例: /User/List -> User 控制器的 List 方法 /User/Detail?id=1 -> User 控制器的 Detail 方法 /Home/Index -> Home 控制器的 Index 方法 ``` ### 自动路由使用示例 ```vb ' 只需要注册控制器，不需要手动添加路由 Call Server.Router.Reg("User", New cUserController) Call Server.Router.Reg("Product", New cProductController) ' 开启自动路由 Server.Router.AutoRoute = True ' 以下 URL 会自动路由： ' GET /User/List -> 调用 cUserController.List ' GET /User/Detail -> 调用 cUserController.Detail ' POST /Product/Add -> 调用 cProductController.Add ``` ### 手动路由 vs 自动路由 | 特性 | 手动路由 | 自动路由 | | -------- | -------------------- | -------------------- | | 性能 | 更快（直接字典查找） | 稍慢（需要解析 URL） | | 灵活性 | 可自定义 URL 路径 | 遵循固定格式 | | 安全性 | 只暴露注册的路由 | 暴露所有公共方法 | | 参数路由 | ✅ 支持 `{param}` | ❌ 不支持 | | 适用场景 | API 服务、生产环境 | 快速开发、后台管理 | ## 路由与中间件配合 ```vb ' 前置中间件：登录验证 Public Sub AuthMiddleware(ctx As cHttpServerContext) ' 排除登录接口 If ctx.Request.PathInfo = "/login" Then Exit Sub ' 检查 Session If ctx.Session("user_id") = "" Then ctx.Response.State401 "请先登录" ctx.fIsAbort = True ' 终止后续处理 End If End Sub ' 注册中间件 Call Server.RouteBefore.Add("auth", New cAuthMiddleware) ' 路由注册（会被 auth 拦截检查） Call Server.Router.Add("/api/data", "Api@Data", OnlyGet) ``` ## 路由性能优化建议 1. **生产环境使用手动路由**：性能更好，安全性更高 2. **静态文件优先**：WebRoot 中的文件会优先返回，不进入路由 3. **合理使用 HTTP 方法限定**：可以更快匹配合适的路由字典 4. **控制器缓存**：控制器对象只注册一次，重复使用 5. **精确路由优先**：精确路由走 O(1) 字典查找，参数路由需遍历匹配，尽量用精确路由处理高频路径 6. **参数路由段数分组**（规划中）：将参数路由按段数分组索引，减少遍历范围 *** **最后更新**: 2026-06-22 --- --- url: /zh/emoji/0780-07BF.md --- # 马尔代夫语 (Thaana) 本页面展示了Unicode字符集中，位于U+0780到U+07BF范围的马尔代夫语字符。马尔代夫语（Thaana）是马尔代夫共和国的官方语言迪维希语使用的书写系统。 | 字符 | Unicode | VB函数值 | 名称 | |:---:|:---:|:---:|:---| | ހ | U+0780 | ChrW(\&H0780) | 塔纳字母HAA | | ށ | U+0781 | ChrW(\&H0781) | 塔纳字母SHAVIYANI | | ނ | U+0782 | ChrW(\&H0782) | 塔纳字母NOONU | | ރ | U+0783 | ChrW(\&H0783) | 塔纳字母RAA | | ބ | U+0784 | ChrW(\&H0784) | 塔纳字母BAA | | ޅ | U+0785 | ChrW(\&H0785) | 塔纳字母LHAVIYANI | | ކ | U+0786 | ChrW(\&H0786) | 塔纳字母KAAFU | | އ | U+0787 | ChrW(\&H0787) | 塔纳字母ALIFU | | ވ | U+0788 | ChrW(\&H0788) | 塔纳字母VAAVU | | މ | U+0789 | ChrW(\&H0789) | 塔纳字母MEEMU | --- --- url: /zh/emoji/0860-087F.md --- # 曼底安文 (Mandaic) 本页面展示了Unicode字符集中，位于U+0860到U+087F范围的曼底安文字符。曼底安文字是由曼底安人使用的阿拉米语支系文字，主要用于宗教文献。 | 字符 | Unicode | VB函数值 | 名称 | |:---:|:---:|:---:|:---| | ࡀ | U+0860 | ChrW(\&H0860) | 曼底安字母HALQA | | ࡁ | U+0861 | ChrW(\&H0861) | 曼底安字母AB | | ࡂ | U+0862 | ChrW(\&H0862) | 曼底安字母AG | | ࡃ | U+0863 | ChrW(\&H0863) | 曼底安字母AD | | ࡄ | U+0864 | ChrW(\&H0864) | 曼底安字母AH | | ࡅ | U+0865 | ChrW(\&H0865) | 曼底安字母USHENNA | | ࡆ | U+0866 | ChrW(\&H0866) | 曼底安字母AZ | | ࡇ | U+0867 | ChrW(\&H0867) | 曼底安字母IT | | ࡈ | U+0868 | ChrW(\&H0868) | 曼底安字母ATT | | ࡉ | U+0869 | ChrW(\&H0869) | 曼底安字母AKSA | --- --- url: /zh/emoji/0980-09FF.md --- # 孟加拉语 (Bengali) 本页面展示了Unicode字符集中，位于U+0980到U+09FF范围的孟加拉文字符。孟加拉文字是印度-雅利安语支最东端的文字，主要用于书写孟加拉语和阿萨姆语。 | 字符 | Unicode | VB函数值 | 名称 | |:---:|:---:|:---:|:---| | ঀ | U+0980 | ChrW(\&H0980) | 孟加拉文占位符 | | ঁ | U+0981 | ChrW(\&H0981) | 孟加拉文标记CANDRABINDU | | ং | U+0982 | ChrW(\&H0982) | 孟加拉文标记ANUSVARA | | ঃ | U+0983 | ChrW(\&H0983) | 孟加拉文标记VISARGA | | অ | U+0984 | ChrW(\&H0984) | 孟加拉文字母A | | আ | U+0985 | ChrW(\&H0985) | 孟加拉文字母AA | | ই | U+0986 | ChrW(\&H0986) | 孟加拉文字母I | | ঈ | U+0987 | ChrW(\&H0987) | 孟加拉文字母II | | উ | U+0988 | ChrW(\&H0988) | 孟加拉文字母U | | ঊ | U+0989 | ChrW(\&H0989) | 孟加拉文字母UU | --- --- url: /zh/emoji/1000-109F.md --- # 缅甸语 (Myanmar) 本页面展示了Unicode字符集中，位于U+1000到U+109F范围的缅甸文字符。缅甸文是缅甸的官方文字，用于书写缅甸语和其他少数民族语言。 | 字符 | Unicode | VB函数值 | 名称 | |:---:|:---:|:---:|:---| | က | U+1000 | ChrW(\&H1000) | 缅甸文字母KA | | ခ | U+1001 | ChrW(\&H1001) | 缅甸文字母KHA | | ဂ | U+1002 | ChrW(\&H1002) | 缅甸文字母GA | | ဃ | U+1003 | ChrW(\&H1003) | 缅甸文字母GHA | | င | U+1004 | ChrW(\&H1004) | 缅甸文字母NGA | | စ | U+1005 | ChrW(\&H1005) | 缅甸文字母CA | | ဆ | U+1006 | ChrW(\&H1006) | 缅甸文字母CHA | | ဇ | U+1007 | ChrW(\&H1007) | 缅甸文字母JA | | ဈ | U+1008 | ChrW(\&H1008) | 缅甸文字母JHA | | ဉ | U+1009 | ChrW(\&H1009) | 缅甸文字母NYA | | ည | U+100A | ChrW(\&H100A) | 缅甸文字母NNYA | | ဋ | U+100B | ChrW(\&H100B) | 缅甸文字母TTA | | ဌ | U+100C | ChrW(\&H100C) | 缅甸文字母TTHA | | ဍ | U+100D | ChrW(\&H100D) | 缅甸文字母DDA | | ဎ | U+100E | ChrW(\&H100E) | 缅甸文字母DDHA | | ဏ | U+100F | ChrW(\&H100F) | 缅甸文字母NNA | | တ | U+1010 | ChrW(\&H1010) | 缅甸文字母TA | | ထ | U+1011 | ChrW(\&H1011) | 缅甸文字母THA | | ဒ | U+1012 | ChrW(\&H1012) | 缅甸文字母DA | | ဓ | U+1013 | ChrW(\&H1013) | 缅甸文字母DHA | | န | U+1014 | ChrW(\&H1014) | 缅甸文字母NA | | ပ | U+1015 | ChrW(\&H1015) | 缅甸文字母PA | | ဖ | U+1016 | ChrW(\&H1016) | 缅甸文字母PHA | | ဗ | U+1017 | ChrW(\&H1017) | 缅甸文字母BA | | ဘ | U+1018 | ChrW(\&H1018) | 缅甸文字母BHA | | မ | U+1019 | ChrW(\&H1019) | 缅甸文字母MA | | ယ | U+101A | ChrW(\&H101A) | 缅甸文字母YA | | ရ | U+101B | ChrW(\&H101B) | 缅甸文字母RA | | လ | U+101C | ChrW(\&H101C) | 缅甸文字母LA | | ဝ | U+101D | ChrW(\&H101D) | 缅甸文字母WA | | သ | U+101E | ChrW(\&H101E) | 缅甸文字母SA | | ဟ | U+101F | ChrW(\&H101F) | 缅甸文字母HA | | ဠ | U+1020 | ChrW(\&H1020) | 缅甸文字母LLA | | အ | U+1021 | ChrW(\&H1021) | 缅甸文字母A | | ဢ | U+1022 | ChrW(\&H1022) | 缅甸文字母SHAN A | | ဣ | U+1023 | ChrW(\&H1023) | 缅甸文字母I | | ဤ | U+1024 | ChrW(\&H1024) | 缅甸文字母II | | ဥ | U+1025 | ChrW(\&H1025) | 缅甸文字母U | | ဦ | U+1026 | ChrW(\&H1026) | 缅甸文字母UU | | ဧ | U+1027 | ChrW(\&H1027) | 缅甸文字母E | | ဨ | U+1028 | ChrW(\&H1028) | 缅甸文字母MON E | | ဩ | U+1029 | ChrW(\&H1029) | 缅甸文字母O | | ဪ | U+102A | ChrW(\&H102A) | 缅甸文字母AU | | ါ | U+102B | ChrW(\&H102B) | 缅甸元音记号TALL AA | | ာ | U+102C | ChrW(\&H102C) | 缅甸元音记号AA | | ိ | U+102D | ChrW(\&H102D) | 缅甸元音记号I | | ီ | U+102E | ChrW(\&H102E) | 缅甸元音记号II | | ု | U+102F | ChrW(\&H102F) | 缅甸元音记号U | | ူ | U+1030 | ChrW(\&H1030) | 缅甸元音记号UU | | ေ | U+1031 | ChrW(\&H1031) | 缅甸元音记号E | | ဲ | U+1032 | ChrW(\&H1032) | 缅甸元音记号AI | | ဳ | U+1033 | ChrW(\&H1033) | 缅甸元音记号MON II | | ဴ | U+1034 | ChrW(\&H1034) | 缅甸元音记号MON O | | ဵ | U+1035 | ChrW(\&H1035) | 缅甸元音记号E ABOVE | | ံ | U+1036 | ChrW(\&H1036) | 缅甸记号ANUSVARA | | ့ | U+1037 | ChrW(\&H1037) | 缅甸记号DOT BELOW | | း | U+1038 | ChrW(\&H1038) | 缅甸记号VISARGA | | ္ | U+1039 | ChrW(\&H1039) | 缅甸记号VIRAMA | | ် | U+103A | ChrW(\&H103A) | 缅甸记号ASAT | | ျ | U+103B | ChrW(\&H103B) | 缅甸辅音记号MEDIAL YA | | ြ | U+103C | ChrW(\&H103C) | 缅甸辅音记号MEDIAL RA | | ွ | U+103D | ChrW(\&H103D) | 缅甸辅音记号MEDIAL WA | | ှ | U+103E | ChrW(\&H103E) | 缅甸辅音记号MEDIAL HA | | ဿ | U+103F | ChrW(\&H103F) | 缅甸字母GREAT SA | --- --- url: /zh/packages/vbccr/buttons/commandbuttonw.md description: 命令按钮控件（CommandButtonW） - VBCCR 开发手册，基于源码的完整 API 参考 --- # 命令按钮控件（CommandButtonW） 增强型命令按钮控件，支持视觉样式、分割按钮、自绘和图片标题共存。 ## 枚举 ### CmdImageListAlignmentConstants | 常量 | 值 | 说明 | |------|-----|------| | CmdImageListAlignmentLeft | 0 | 左对齐 | | CmdImageListAlignmentRight | 1 | 右对齐 | | CmdImageListAlignmentTop | 2 | 顶部对齐 | | CmdImageListAlignmentBottom | 3 | 底部对齐 | | CmdImageListAlignmentCenter | 4 | 居中对齐 | ### CmdDrawModeConstants | 常量 | 值 | 说明 | |------|-----|------| | CmdDrawModeNormal | 0 | 正常模式 | | CmdDrawModeOwnerDraw | 1 | 自绘模式 | ## 属性 ### Default ```vb Property Get Default() As Boolean Property Let Default(ByVal Value As Boolean) ``` 是否为默认按钮（Enter 键触发）。 ### Cancel ```vb Property Get Cancel() As Boolean Property Let Cancel(ByVal Value As Boolean) ``` 是否为取消按钮（Esc 键触发）。 ### VisualStyles ```vb Property Get VisualStyles() As Boolean Property Let VisualStyles(ByVal Value As Boolean) ``` 是否启用视觉样式。 ### Appearance ```vb Property Get Appearance() As CCAppearanceConstants Property Let Appearance(ByVal Value As CCAppearanceConstants) ``` 外观样式。参见通用枚举。 ### BackColor ```vb Property Get BackColor() As OLE_COLOR Property Let BackColor(ByVal Value As OLE_COLOR) ``` 背景色。 ### ForeColor ```vb Property Get ForeColor() As OLE_COLOR Property Let ForeColor(ByVal Value As OLE_COLOR) ``` 前景色。 ### ImageList ```vb Property Get ImageList() As Variant Property Let ImageList(ByVal Value As Variant) Property Set ImageList(ByVal Value As Variant) ``` 关联的 ImageList 控件。 ### ImageListAlignment ```vb Property Get ImageListAlignment() As CmdImageListAlignmentConstants Property Let ImageListAlignment(ByVal Value As CmdImageListAlignmentConstants) ``` ImageList 图标对齐方式。 ### ImageListMargin ```vb Property Get ImageListMargin() As Single Property Let ImageListMargin(ByVal Value As Single) ``` ImageList 图标边距。 ### Caption ```vb Property Get Caption() As String Property Let Caption(ByVal Value As String) ``` 标题文本。 ### Alignment ```vb Property Get Alignment() As VBRUN.AlignmentConstants Property Let Alignment(ByVal Value As VBRUN.AlignmentConstants) ``` 文本水平对齐。 ### VerticalAlignment ```vb Property Get VerticalAlignment() As CCVerticalAlignmentConstants Property Let VerticalAlignment(ByVal Value As CCVerticalAlignmentConstants) ``` 文本垂直对齐。参见通用枚举。 ### Picture ```vb Property Get Picture() As IPictureDisp Property Let Picture(ByVal Value As IPictureDisp) Property Set Picture(ByVal Value As IPictureDisp) ``` 图片。 ### PictureAndCaption ```vb Property Get PictureAndCaption() As Boolean Property Let PictureAndCaption(ByVal Value As Boolean) ``` 是否同时显示图片和标题。需要 comctl32.dll 6.1 或更高版本。 ### WordWrap ```vb Property Get WordWrap() As Boolean Property Let WordWrap(ByVal Value As Boolean) ``` 是否自动换行。 ### Transparent ```vb Property Get Transparent() As Boolean Property Let Transparent(ByVal Value As Boolean) ``` 是否透明背景（运行时有效）。 ### SplitButton ```vb Property Get SplitButton() As Boolean Property Let SplitButton(ByVal Value As Boolean) ``` 是否显示为分割按钮。需要 comctl32.dll 6.1 或更高版本。 ### SplitButtonAlignment ```vb Property Get SplitButtonAlignment() As CCLeftRightAlignmentConstants Property Let SplitButtonAlignment(ByVal Value As CCLeftRightAlignmentConstants) ``` 分割按钮对齐方式。参见通用枚举。 ### SplitButtonNoSplit ```vb Property Get SplitButtonNoSplit() As Boolean Property Let SplitButtonNoSplit(ByVal Value As Boolean) ``` 分割按钮不显示分割线。 ### SplitButtonGlyph ```vb Property Get SplitButtonGlyph() As IPictureDisp Property Let SplitButtonGlyph(ByVal Value As IPictureDisp) Property Set SplitButtonGlyph(ByVal Value As IPictureDisp) ``` 分割按钮的下拉箭头图标。 ### Style ```vb Property Get Style() As VBRUN.ButtonConstants Property Let Style(ByVal Value As VBRUN.ButtonConstants) ``` 按钮样式（标准或图形）。 ### DisabledPicture ```vb Property Get DisabledPicture() As IPictureDisp Property Let DisabledPicture(ByVal Value As IPictureDisp) Property Set DisabledPicture(ByVal Value As IPictureDisp) ``` 禁用状态图片。 ### DownPicture ```vb Property Get DownPicture() As IPictureDisp Property Let DownPicture(ByVal Value As IPictureDisp) Property Set DownPicture(ByVal Value As IPictureDisp) ``` 按下状态图片。 ### UseMaskColor ```vb Property Get UseMaskColor() As Boolean Property Let UseMaskColor(ByVal Value As Boolean) ``` 是否使用遮罩色。 ### MaskColor ```vb Property Get MaskColor() As OLE_COLOR Property Let MaskColor(ByVal Value As OLE_COLOR) ``` 遮罩色。 ### DrawMode ```vb Property Get DrawMode() As CmdDrawModeConstants Property Let DrawMode(ByVal Value As CmdDrawModeConstants) ``` 绘制模式。 ### Value ```vb Property Get Value() As Boolean Property Let Value(ByVal NewValue As Boolean) ``` 按钮值，设为 True 时触发 Click 事件。 ### Pushed ```vb Property Get Pushed() As Boolean Property Let Pushed(ByVal Value As Boolean) ``` 是否处于按下状态。 ### Hot ```vb Property Get Hot() As Boolean ``` 是否处于热状态。只读。 ### DroppedDown ```vb Property Get DroppedDown() As Boolean Property Let DroppedDown(ByVal Value As Boolean) ``` 分割按钮是否已下拉。 ### hWnd / hWndUserControl / Font / Enabled / OLEDropMode / MousePointer / MouseIcon / MouseTrack / RightToLeft / RightToLeftLayout / RightToLeftMode 参见公共属性。 ### Name / Tag / Parent / Container / Left / Top / Width / Height / Visible / ToolTipText / HelpContextID / WhatsThisHelpID / DragIcon / DragMode 参见标准扩展器属性。 ## 方法 ### Refresh ```vb Public Sub Refresh() ``` 强制重绘。 ### PerformClick ```vb Public Sub PerformClick() ``` 模拟用户点击按钮。 ### SetShield ```vb Public Function SetShield(ByVal State As Boolean) As Long ``` 设置 UAC 提升图标。成功返回 1。需要 comctl32.dll 6.1 或更高版本。 ### GetIdealSize ```vb Public Sub GetIdealSize(ByRef Width As Single, ByRef Height As Single) ``` 获取按钮的理想尺寸。需要 comctl32.dll 6.0 或更高版本。 ### OLEDrag ```vb Public Sub OLEDrag() ``` ### Drag / ZOrder / SetFocus / Move 参见标准方法。 ## 事件 ### Click ```vb Public Event Click() ``` 单击。 ### DblClick ```vb Public Event DblClick() ``` 双击。 ### HotChanged ```vb Public Event HotChanged() ``` 热状态改变。 ### DropDown ```vb Public Event DropDown() ``` 分割按钮下拉时触发。 ### OwnerDraw ```vb Public Event OwnerDraw(ByVal DisplayAsDefault As Boolean, ByVal ItemAction As Long, ByVal ItemState As Long, ByVal hDC As LongPtr, ByVal Left As Long, ByVal Top As Long, ByVal Right As Long, ByVal Bottom As Long) ``` 自绘事件。 ### KeyDown / KeyUp / KeyPress ### MouseDown / MouseMove / MouseUp / MouseEnter / MouseLeave ### OLECompleteDrag / OLEDragDrop / OLEDragOver / OLEGiveFeedback / OLESetData / OLEStartDrag ## 代码示例 ### 基本用法 ```vb ' 设置默认按钮 CommandButtonW1.Default = True CommandButtonW1.Caption = "确定" ' 图形按钮 CommandButtonW1.Style = vbButtonGraphical Set CommandButtonW1.Picture = LoadPicture("ok.bmp") ' 图片和标题共存 CommandButtonW1.PictureAndCaption = True ``` ### 分割按钮 ```vb CommandButtonW1.SplitButton = True Private Sub CommandButtonW1_DropDown() ' 显示上下文菜单 PopupMenu mnuOptions End Sub ``` ### UAC 提升图标 ```vb CommandButtonW1.SetShield True ``` ### 获取理想尺寸 ```vb Dim w As Single, h As Single CommandButtonW1.GetIdealSize w, h CommandButtonW1.Width = w CommandButtonW1.Height = h ``` --- --- url: /zh/packages/vbccr/buttons/commandlink.md description: 命令链接控件（CommandLink） - VBCCR 开发手册，基于源码的完整 API 参考 --- # 命令链接控件（CommandLink） Windows 命令链接按钮控件，显示标题、提示文本和可选图标。 ## 枚举 无控件专用枚举。 ## 属性 ### Default ```vb Property Get Default() As Boolean Property Let Default(ByVal Value As Boolean) ``` 是否为默认按钮。 ### Cancel ```vb Property Get Cancel() As Boolean Property Let Cancel(ByVal Value As Boolean) ``` 是否为取消按钮。 ### VisualStyles ```vb Property Get VisualStyles() As Boolean Property Let VisualStyles(ByVal Value As Boolean) ``` 是否启用视觉样式。 ### BackColor ```vb Property Get BackColor() As OLE_COLOR Property Let BackColor(ByVal Value As OLE_COLOR) ``` 背景色。 ### ImageList ```vb Property Get ImageList() As Variant Property Let ImageList(ByVal Value As Variant) Property Set ImageList(ByVal Value As Variant) ``` 关联的 ImageList 控件。 ### Caption ```vb Property Get Caption() As String Property Let Caption(ByVal Value As String) ``` 标题文本。 ### Hint ```vb Property Get Hint() As String Property Let Hint(ByVal Value As String) ``` 提示文本（标题下方的说明文字）。 ### Picture ```vb Property Get Picture() As IPictureDisp Property Let Picture(ByVal Value As IPictureDisp) Property Set Picture(ByVal Value As IPictureDisp) ``` 图标。 ### Transparent ```vb Property Get Transparent() As Boolean Property Let Transparent(ByVal Value As Boolean) ``` 透明背景（运行时有效）。 ### RightToLeft ```vb Property Get RightToLeft() As Boolean Property Let RightToLeft(ByVal Value As Boolean) ``` 从右到左显示。 ### RightToLeftLayout ```vb Property Get RightToLeftLayout() As Boolean Property Let RightToLeftLayout(ByVal Value As Boolean) ``` 从右到左镜像布局。 ### RightToLeftMode ```vb Property Get RightToLeftMode() As CCRightToLeftModeConstants Property Let RightToLeftMode(ByVal Value As CCRightToLeftModeConstants) ``` 从右到左模式。参见通用枚举。 ### Value ```vb Property Get Value() As Boolean Property Let Value(ByVal NewValue As Boolean) ``` 按钮值，设为 True 时触发 Click 事件。 ### Pushed ```vb Property Get Pushed() As Boolean Property Let Pushed(ByVal Value As Boolean) ``` 是否处于按下状态。 ### Hot ```vb Property Get Hot() As Boolean ``` 是否处于热状态。只读。 ### hWnd / hWndUserControl / Font / Enabled / OLEDropMode / MousePointer / MouseIcon / MouseTrack 参见公共属性。 ### Name / Tag / Parent / Container / Left / Top / Width / Height / Visible / ToolTipText / HelpContextID / WhatsThisHelpID / DragIcon / DragMode 参见标准扩展器属性。 ## 方法 ### Refresh ```vb Public Sub Refresh() ``` 强制重绘。 ### PerformClick ```vb Public Sub PerformClick() ``` 模拟用户点击。 ### SetShield ```vb Public Function SetShield(ByVal State As Boolean) As Long ``` 设置 UAC 提升图标。成功返回 1。 ### GetIdealHeight ```vb Public Function GetIdealHeight() As Single ``` 获取控件的理想高度。 ### OLEDrag ```vb Public Sub OLEDrag() ``` ### Drag / ZOrder / SetFocus / Move 参见标准方法。 ## 事件 ### Click ```vb Public Event Click() ``` 单击。 ### DblClick ```vb Public Event DblClick() ``` 双击。 ### HotChanged ```vb Public Event HotChanged() ``` 热状态改变。 ### KeyDown / KeyUp / KeyPress ### MouseDown / MouseMove / MouseUp / MouseEnter / MouseLeave ### OLECompleteDrag / OLEDragDrop / OLEDragOver / OLEGiveFeedback / OLESetData / OLEStartDrag ## 代码示例 ### 基本用法 ```vb ' 设置命令链接 CommandLink1.Caption = "保存文件" CommandLink1.Hint = "将当前文档保存到磁盘" CommandLink1.Default = True ' 设置 UAC 提升图标 CommandLink1.SetShield True ' 获取理想高度并调整 CommandLink1.Height = CommandLink1.GetIdealHeight ``` ### 响应点击 ```vb Private Sub CommandLink1_Click() MsgBox "您点击了: " & CommandLink1.Caption End Sub ``` --- --- url: /zh/vbman/tls/certmemory.md --- # 内存证书集合模式 (TlsCertMemory) ## 概述 内存证书集合模式是最灵活的 TLS 配置方式。证书数据不来自磁盘文件或 Windows 证书存储，而是由程序在运行时动态构造并保存在 VB6 `Collection` 对象中，直接传入 TLS 引擎。 ## 函数签名 ```vb Public Function TlsCertMemory( _ ByVal Certificates As Collection, _ ByVal PrivateKey As Collection, _ Optional ByVal AlpnProtocols As String = "...") As <组件类型> ``` ### 参数 | 参数 | 类型 | 必要 | 说明 | |------|------|------|------| | `Certificates` | Collection | 是 | 证书链集合，每个元素为 PEM 格式证书文本 | | `PrivateKey` | Collection | 是 | 私钥集合，每个元素为 PEM 格式私钥文本 | | `AlpnProtocols` | String | 否 | ALPN 协议协商。各组件默认值不同 | | 组件 | AlpnProtocols 默认值 | |------|---------------------| | cHttpServer | `"http/1.1"` | | cWinsock | `"http/1.1"` | | cWebSocketServer | `""`（空） | ## Collection 数据格式 ### Certificates 集合 每个元素是一段 PEM 编码的证书文本字符串： ```vb Dim certs As New Collection certs.Add "-----BEGIN CERTIFICATE-----" & vbCrLf & _ "MIIFazCCBFOgAwIBAgISA2Q3p..." & vbCrLf & _ "-----END CERTIFICATE-----" ' 中间证书（如有） certs.Add "-----BEGIN CERTIFICATE-----" & vbCrLf & _ "MIIFazCCBFOgAwIBAgISA3B4q..." & vbCrLf & _ "-----END CERTIFICATE-----" ``` **顺序要求：** 第一个元素必须是服务器证书（叶证书），后续为中间证书。 ### PrivateKey 集合 每个元素是一段 PEM 编码的私钥文本字符串： ```vb Dim pkeys As New Collection pkeys.Add "-----BEGIN PRIVATE KEY-----" & vbCrLf & _ "MIIEvgIBADANBgkqhkiG9w0BAQ..." & vbCrLf & _ "-----END PRIVATE KEY-----" ``` **支持的私钥格式：** * `-----BEGIN PRIVATE KEY-----`（PKCS#8 无加密） * `-----BEGIN RSA PRIVATE KEY-----`（PKCS#1 RSA） * `-----BEGIN EC PRIVATE KEY-----`（EC） * `-----BEGIN ENCRYPTED PRIVATE KEY-----`（PKCS#8 加密） ## 典型应用场景 ### 1. 证书嵌入可执行文件 将证书作为资源编译进 EXE/DLL，运行时提取到 Collection，无需分发独立的 .pfx 文件。 ```vb ' 从资源文件加载证书 Dim certs As New Collection Dim pkeys As New Collection certs.Add LoadResData(101, "CERT") ' 自定义资源类型 pkeys.Add LoadResData(102, "KEY") Server.TlsCertMemory(certs, pkeys).Start 443 ``` **优势：** * 部署简单，只需一个 EXE 文件 * 证书不暴露在磁盘上（一定程度上增加安全性） * 不依赖外部文件路径 **局限：** * 证书更新需要重新编译 * EXE 体积增大 ### 2. ACME / Let's Encrypt 自动签发 程序运行时通过 ACME 协议自动申请证书，获取后直接存内存，无需写盘。 ```vb ' ACME 签发流程（伪代码） Dim certs As New Collection Dim pkeys As New Collection ' 1. 创建账户 AcmeClient.Register "admin@example.com" ' 2. 验证域名所有权（HTTP-01 或 DNS-01） AcmeClient.VerifyDomain "www.example.com" ' 3. 签发证书 Dim pemCert As String Dim pemKey As String pemCert = AcmeClient.IssueCertificate("www.example.com", pemKey) ' 4. 加载到 Collection certs.Add pemCert pkeys.Add pemKey ' 5. 启动 HTTPS Server.TlsCertMemory(certs, pkeys).Start 443 ``` **优势：** * 全自动，无需人工干预 * 证书不落盘，减少泄露风险 * 可实现定时自动续期 ### 3. 动态 SNI 路由 根据客户端请求的域名（SNI），从数据库或配置中心动态加载对应证书。 ```vb ' 概念示例：多域名 HTTPS 服务器 ' 注意：当前 cTlsSocket 在 Listen 阶段初始化证书，不支持单端口多证书 ' 多域名场景建议使用通配符证书或为每个域名创建独立的 cHttpServer 实例 Dim certs As New Collection Dim pkeys As New Collection ' 从配置数据库加载指定域名的证书 Dim rs As Recordset Set rs = DB.Execute("SELECT cert_pem, key_pem FROM certs WHERE domain='www.example.com'") certs.Add rs!cert_pem pkeys.Add rs!key_pem Server.TlsCertMemory(certs, pkeys).Start 443 ``` ### 4. 测试场景 程序自签发临时证书用于开发和测试。 ```vb ' 使用 OpenSSL 命令行预生成测试证书，或用 COM 组件在运行时生成 Dim certs As New Collection Dim pkeys As New Collection ' 假设 TestCertGenerator 是自定义的证书生成类 Dim gen As New TestCertGenerator gen.CommonName = "localhost" gen.ValidDays = 1 certs.Add gen.GenerateCertificate() pkeys.Add gen.GeneratePrivateKey() Server.TlsCertMemory(certs, pkeys).Start 443 ``` ### 5. 从文件加载到内存 将文件内容读入 Collection，实现延迟加载或缓存控制。 ```vb Private Function LoadPemToCollections( _ ByVal CertPaths As String, _ ByVal KeyPath As String) As Boolean Dim certs As New Collection Dim pkeys As New Collection ' 加载证书（支持 | 分隔多文件） Dim arrCerts() As String arrCerts = Split(CertPaths, "|") Dim i As Long For i = 0 To UBound(arrCerts) certs.Add ReadTextFile(Trim(arrCerts(i))) Next ' 加载私钥 pkeys.Add ReadTextFile(KeyPath) ' 使用 Server.TlsCertMemory certs, pkeys LoadPemToCollections = True End Function Private Function ReadTextFile(ByVal Path As String) As String Dim f As Integer f = FreeFile Open Path For Input As #f ReadTextFile = Input$(LOF(f), f) Close #f End Function ``` ## 各组件使用示例 ### cHttpServer（HTTPS） ```vb Dim certs As New Collection Dim pkeys As New Collection ' 从数据库加载 certs.Add DB_GetCertPem("www.example.com") pkeys.Add DB_GetKeyPem("www.example.com") Server.TlsCertMemory(certs, pkeys).WebRoot("C:\www").Start 443 ``` ### cWinsock（TLS TCP 服务端） ```vb Dim certs As New Collection Dim pkeys As New Collection certs.Add LoadFromResource(101) pkeys.Add LoadFromResource(102) Dim svr As New cWinsock svr.TlsCertMemory(certs, pkeys).Listen 443 ``` ### cWebSocketServer（wss://） ```vb Dim certs As New Collection Dim pkeys As New Collection certs.Add GetCertFromConfig() pkeys.Add GetKeyFromConfig() Dim wsSvr As New cWebSocketServer wsSvr.TlsCertMemory(certs, pkeys).Listen 443 ``` ## 内存中的 PEM 文本格式 Collection 中的每个元素必须是完整的 PEM 块，包含起止标记： ``` ✅ 正确：完整的 PEM 块 -----BEGIN CERTIFICATE----- MIIFazCCBFOgAwIBAgISA2Q3p... （Base64 内容，可含换行） -----END CERTIFICATE----- ❌ 错误：仅 Base64 内容，无 PEM 标记 MIIFazCCBFOgAwIBAgISA2Q3p... ❌ 错误：DER 二进制数据（字节数组） ``` **换行符：** PEM 文本中的换行可以是 `vbCr`、`vbLf` 或 `vbCrLf`，底层 OpenSSL 均能识别。 ## 底层处理流程 ```vb ' cTlsSocket.InitServerTls 内部 If pvCollectionCount(Certificates) > 0 And pvCollectionCount(PrivateKey) > 0 Then Set cCerts = Certificates Set cPrivKey = PrivateKey GoTo StartTls End If ``` ``` TlsCertMemory(certs, pkeys) │ └─ InitServerTls(Certificates:=certs, PrivateKey:=pkeys) │ ├─ 检查 Certificates.Count > 0 And PrivateKey.Count > 0 │ └─ TlsInitServer(ctx, hostname, cCerts, cPrivKey, alpn, features) │ ├─ 遍历 Certificates 集合 │ └─ PEM_read_bio_X509() → 逐一解析证书 │ ├─ 遍历 PrivateKey 集合 │ └─ PEM_read_bio_PrivateKey() → 解析私钥 │ └─ SSL_CTX_use_certificate() + SSL_CTX_use_PrivateKey() ``` ## 安全注意事项 ### 1. 内存中的私钥保护 私钥以明文 PEM 文本形式存储在 Collection 中，在进程内存中可被调试器读取。 **建议：** * 使用后尽快清除 Collection 和字符串变量 * 避免在日志中输出私钥内容 * 考虑使用 Windows DPAPI 加密存储的私钥文本 ```vb ' 使用后清除 Set certs = Nothing Set pkeys = Nothing ``` ### 2. 证书来源验证 从外部来源（数据库、API、配置中心）加载证书时，需验证数据的完整性和来源。 **建议：** * 使用 TLS 连接获取证书数据 * 对配置数据进行签名验证 * 限制数据库访问权限 ### 3. 内存限制 大量证书或超大证书链会占用较多内存。 **建议：** * 只加载必要的证书链 * 避免在 Collection 中存储冗余的中间证书 * 及时释放不再使用的 Collection ## 与其他模式对比 | 特性 | TlsCertFile | TlsCertSubject | TlsCertMemory | |------|-------------|----------------|---------------| | 证书来源 | 磁盘文件 | Windows 证书库 | 内存 Collection | | 部署便利 | 文件分发 | 系统导入 | 嵌入/动态加载 | | 证书更新 | 替换文件 | 续期到存储 | 重新加载 | | 私钥保护 | 文件系统权限 | 操作系统保护 | 进程内存 | | 运行时生成 | 不支持 | 不支持 | **支持** | | ACME 自动签发 | 需写盘 | 需导入 | **天然支持** | | 资源嵌入 | 不支持 | 不支持 | **支持** | | 部署复杂度 | 低 | 中 | 高 | | 适用场景 | 生产部署 | 企业共享 | 动态/嵌入式 | ## 证书来源优先级 在 `cTlsSocket.InitServerTls` 中，三种证书来源的检测优先级： 1. **内存集合** (`Certificates` + `PrivateKey`) — 最高优先级 2. **证书文件** (`CertFile`) 3. **Windows 证书存储** (`CertSubject`) — 最低优先级 如果同时传入多个来源参数，只有优先级最高的生效。 ## 常见问题 ### 1. PEM 格式错误 ``` LastError: 证书文件不存在或格式错误 ``` **解决：** 确保 Collection 中的每个元素是完整的 PEM 块，包含 `-----BEGIN...-----` 和 `-----END...-----` 标记。 ### 2. 证书与私钥不匹配 ``` TLS 握手失败 ``` **解决：** 确保证书和私钥是配对的。可以用 OpenSSL 验证： ```bash openssl x509 -noout -modulus -in cert.pem | openssl md5 openssl rsa -noout -modulus -in key.pem | openssl md5 # 两个 MD5 值应相同 ``` ### 3. 证书顺序错误 ``` 客户端报证书链不完整 ``` **解决：** Certificates 集合中第一个元素必须是服务器证书（叶证书），后续是中间证书。 ### 4. Collection 为空 ``` InitServerTls 跳过内存证书，尝试其他来源 ``` **解决：** 确保 `Certificates.Count > 0` 且 `PrivateKey.Count > 0`，否则底层会跳过内存模式。 ## 相关文档 * [TLS 证书配置总览](./overview.md) * [证书文件模式](./certfile.md) * [Windows 证书存储模式](./certsubject.md) * [cHttpServer TLS 支持](../httpserver/tls.md) * [cWinsock TLS 支持](../winsock/tls.md) * [cWebSocket TLS 支持](../websocket/tls.md) *** **最后更新**: 2026-06-09 --- --- url: /zh/cases/case-iot-cloud.md description: 拼个 URL 就能读写数据 - 基于 VBMAN HttpServer 构建的轻量级 IoT 数据存储服务 --- # 轻量物联网云平台 > **拼个 URL 就能读写数据** — 基于 VBMAN `cHttpServer` 构建的轻量级 HTTP 数据存储服务，让物联网设备数据上云变得极其简单。 > > 📎 来源地址：[轻量物联网云平台 - 用户文档](http://101.43.146.127:800/3.html) ## 项目概览 | 项目信息 | 详情 | | ------------ | ---------------------------- | | **项目名称** | 轻量物联网云平台 | | **作者** | 技术宅老白 | | **核心模块** | VBMAN `cHttpServer` | | **应用领域** | 物联网 / 智能硬件 / 数据采集 | | **技术难度** | 进阶 | | **更新日期** | 2026-06-12 | ## 适用场景 * 🌡️ 物联网传感器数据上传（温湿度、空气质量、水位等） * 💡 设备远程控制（开关、调光、电机等） * 📱 网页/小程序数据展示 * 🏠 智能家居数据中枢 * 🔧 项目原型快速验证 ## 核心优势 | 特点 | 说明 | | ----------- | ---------------------------------------- | | ⚡ 极速接入 | 无需 SDK，发个 HTTP 请求就能用，30秒跑通 | | 💰 读不扣费 | 读操作全免费，只有写才扣次数 | | 🌐 跨域友好 | 原生支持 CORS，前端直接调用 | | 🔒 数据安全 | 每个 Key 独立存储空间，互不干扰 | | 💾 持久存储 | 数据自动落盘，服务重启不丢失 | ## VBMAN 技术实现 本项目核心基于 VBMAN `cHttpServer` 的以下能力： ### 1. 自定义路由映射 利用 VBMAN `cHttpServer` 的路由系统，将 `/yun/w/{key}/{var}/{val}`、`/yun/r/{key}/{var}` 等路径映射到业务处理类： ```vb ' === 注册业务类 === Dim HttpServer As New cHttpServer With HttpServer .Router.Reg "Yun", New bYunCloud ' 注册云平台业务类 .Router.AutoRoute = True ' 开启自动路由 .Start 800 ' 监听 800 端口 End With ``` ### 2. 业务处理类 ```vb ' === bYunCloud.cls - 云平台核心业务 === ' 写数据: /yun/w/{key}/{var}/{val} Public Sub W(ctx As cHttpServerContext) Dim sKey As String: sKey = ctx.Request.UrlParam(1) Dim sVar As String: sVar = ctx.Request.UrlParam(2) Dim sVal As String: sVal = ctx.Request.UrlParam(3) ' 验证 Key 合法性 If Not ValidateKey(sKey) Then ctx.Response.Json "{""status"":""fail"",""msg"":""invalid key""}" Exit Sub End If ' 检查写次数 If GetWriteCount(sKey) <= 0 Then ctx.Response.Json "{""status"":""fail"",""msg"":""no count""}" Exit Sub End If ' 存储数据并扣减次数 SaveData sKey, sVar, sVal DeductCount sKey ctx.Response.Json "{""status"":""ok"",""var"":""" & sVar & """,""val"":""" & sVal & """,""count"":" & GetWriteCount(sKey) & "}" End Sub ' 读数据: /yun/r/{key}/{var} Public Sub R(ctx As cHttpServerContext) Dim sKey As String: sKey = ctx.Request.UrlParam(1) Dim sVar As String: sVar = ctx.Request.UrlParam(2) Dim sVal As String: sVal = ReadData(sKey, sVar) If sVal = "" Then ctx.Response.Json "{""status"":""notfound""}" Else ctx.Response.Json "{""status"":""ok"",""var"":""" & sVar & """,""val"":""" & sVal & """}" End If End Sub ' 查次数: /yun/q/{key} Public Sub Q(ctx As cHttpServerContext) Dim sKey As String: sKey = ctx.Request.UrlParam(1) ctx.Response.Json "{""status"":""ok"",""count"":" & GetWriteCount(sKey) & "}" End Sub ``` ### 3. CORS 跨域支持 VBMAN `cHttpServer` 原生支持 CORS 配置，前端可直接跨域调用： ```vb With HttpServer .Cors.AllowOrigin = "*" ' 允许所有来源 .Cors.AllowMethods = "GET" ' 仅允许 GET 方法 End With ``` ## API 接口说明 ### 写数据 向云平台写入一个变量的值。 ``` GET /yun/w/{key}/{var}/{val} ``` | 参数 | 说明 | 示例 | | ----- | ---------------- | -------------------- | | `key` | 32位授权Key | `a1b2c3d4...` | | `var` | 变量名（自定义） | `temp`、`led_state` | | `val` | 变量值（字符串） | `25.6`、`1`、`hello` | **返回示例：** ```json { "status": "ok", "var": "temp", "val": "25.6", "count": 999999 } ``` ### 读数据 从云平台读取一个变量的值。 ``` GET /yun/r/{key}/{var} ``` **返回示例：** ```json { "status": "ok", "var": "temp", "val": "25.6" } ``` :::: tip 读操作不扣费 读操作完全免费，想读多少次就读多少次。 :::: ### 查剩余次数 查询 Key 还剩多少次写次数。 ``` GET /yun/q/{key} ``` **返回示例：** ```json { "status": "ok", "count": 999999 } ``` ### 错误状态 | status | 说明 | | ---------- | --------------------------- | | `ok` | 成功 | | `fail` | 失败（Key无效、次数不足等） | | `notfound` | 变量不存在 | ## 多语言调用示例 ### 浏览器 / 网页端 (fetch) ```javascript // 写数据 async function yunWrite(key, varName, value) { const res = await fetch( `http://你的服务器地址/yun/w/${key}/${varName}/${value}`, ); return res.json(); } // 读数据 async function yunRead(key, varName) { const res = await fetch(`http://你的服务器地址/yun/r/${key}/${varName}`); return res.json(); } // 使用示例 yunWrite("你的Key", "temp", "25.6").then((data) => { console.log("写入成功，剩余次数：" + data.count); }); yunRead("你的Key", "temp").then((data) => { console.log("温度是：" + data.val); }); ``` ### JSONP 跨域方案 如果遇到跨域问题且 CORS 不可用，可使用路径式 JSONP（无需 `?` 参数）： ```javascript // JSONP 读数据 function yunReadJSONP(key, varName, callbackName) { var script = document.createElement("script"); script.src = "http://你的服务器地址/yun/r/" + key + "/" + varName + "/" + callbackName; document.body.appendChild(script); script.onload = function () { document.body.removeChild(script); }; } // 定义全局回调函数 function handleTempData(data) { console.log("温度是：" + data.val); } // 调用 yunReadJSONP("你的Key", "temp", "handleTempData"); ``` :::: warning 注意 路径式 JSONP 需要服务器端支持。如果不确定，请优先使用 fetch + CORS 方案。 :::: ### ESP32 / Arduino ```cpp #include // 写数据 void yunWrite(String key, String varName, String value) { HTTPClient http; String url = "http://你的服务器地址/yun/w/" + key + "/" + varName + "/" + value; http.begin(url); int httpCode = http.GET(); if (httpCode == 200) { Serial.println("写入成功"); } http.end(); } // 读数据 String yunRead(String key, String varName) { HTTPClient http; String url = "http://你的服务器地址/yun/r/" + key + "/" + varName; http.begin(url); int httpCode = http.GET(); if (httpCode == 200) { return http.getString(); } return ""; } ``` ### Python ```python import requests BASE_URL = "http://你的服务器地址" KEY = "你的32位Key" # 写数据 r = requests.get(f"{BASE_URL}/yun/w/{KEY}/temp/25.6") print(r.json()) # 读数据 r = requests.get(f"{BASE_URL}/yun/r/{KEY}/temp") print(r.json()) # 查次数 r = requests.get(f"{BASE_URL}/yun/q/{KEY}") print(r.json()) ``` ### cURL 命令行 ```bash # 写数据 curl "http://你的服务器地址/yun/w/你的Key/temp/25.6" # 读数据 curl "http://你的服务器地址/yun/r/你的Key/temp" # 查次数 curl "http://你的服务器地址/yun/q/你的Key" ``` ## 重要注意事项 :::: danger 禁止使用 QueryString **绝对不要**在 URL 末尾加 `?` 参数： * ❌ 错误：`/yun/r/key/temp?_=123456` * ✅ 正确：`/yun/r/key/temp` 平台不支持 `?` 后的参数，加了会导致变量名识别错误，数据读不出来。 ::: info 技术原因 该案例的开发者**没有使用 VBMAN 的路由参数（Route Params）机制**，而是自行实现了 URL 路径的分割解析（将 `/yun/r/key/var` 按 `/` 切割提取参数）。这种自定义解析方式只处理路径段，不处理 QueryString 部分。如果在 URL 后面加了 `?_=123456`，自定义解析器会将 `?_=123456` 误当作路径的一部分，导致变量名识别出错。 相比之下，VBMAN `cHttpServer` 提供了标准的路由参数功能（`ctx.Request.UrlParam`、`ctx.Request.QueryString`），可以正确区分路径参数和查询参数。如果你在自己的项目中使用 VBMAN 路由参数，则无需担心此问题。 ::: :::: ### 变量名规则 * 变量名可用：字母、数字、下划线 `_`、减号 `-` * 变量名区分大小写：`Temp` 和 `temp` 是两个不同的变量 * 建议不要用中文变量名 ### 值的限制 * 值的长度建议控制在 1024 字符以内 * 支持中英文、数字、常见符号 * 特殊字符建议使用 URL 编码 ### 数据持久化 * 数据自动保存，服务器重启不丢失 * 数据每 50 秒批量落盘，极端情况下（如突然断电）可能丢失最近 50 秒内的写入 ## 资费说明 | 项目 | 价格 | 说明 | | -------- | -------------- | ----------- | | 读数据 | 免费 | 不限次数 | | 写数据 | 10元 / 100万次 | 每次写扣1次 | | 查询次数 | 免费 | 不限次数 | **充值方式：** 联系管理员续费，次数到账后可在 `/yun/q/{key}` 接口查询到最新余额。 ## 常见问题 ### Q: 忘记 Key 了怎么办？ 联系管理员找回。 ### Q: 数据会被别人看到吗？ 只要你的 Key 不泄露，别人就读不到你的数据。Key 相当于密码，请勿公开。 ### Q: 支持 HTTPS 吗？ 目前仅支持 HTTP。如需要 HTTPS 可联系管理员配置，也可结合 VBMAN HttpServer 的 TLS 功能自行部署。 ### Q: 最多能存多少个变量？ 每个 Key 下的变量数量没有限制。 ### Q: 数据会自动删除吗？ 数据永久保存，除非主动覆盖或删除。 ### Q: 次数用完了会怎样？ 写接口会返回失败状态，读和查询仍可正常使用。续费后自动恢复。 ## 项目亮点总结 | 维度 | 亮点 | | ------------------ | ------------------------------------------------------ | | **VBMAN 能力展示** | `cHttpServer` 路由系统 + CORS + JSON 响应 + 数据持久化 | | **接入极简** | URL 即 API，零 SDK，30 秒跑通 | | **跨平台调用** | 浏览器 / ESP32 / Arduino / Python / cURL 全覆盖 | | **商业模式** | 读免费、写按次计费，数据即服务的轻量云 | --- --- url: /zh/packages/vbccr/text/hotkey.md description: 热键控件（HotKey） - VBCCR 开发手册，基于源码的完整 API 参考 --- # 热键控件（HotKey） 提供 Windows 标准热键输入控件，允许用户选择快捷键组合。 ## 枚举 ### HkeInvalidKeyCombinationConstants | 常量 | 值 | 说明 | |------|-----|------| | HkeInvalidKeyCombinationNone | 1 | 无效组合：无修饰键 | | HkeInvalidKeyCombinationShift | 2 | 无效组合：仅 Shift | | HkeInvalidKeyCombinationCtrl | 4 | 无效组合：仅 Ctrl | | HkeInvalidKeyCombinationAlt | 8 | 无效组合：仅 Alt | | HkeInvalidKeyCombinationShiftCtrl | 16 | 无效组合：Shift+Ctrl | | HkeInvalidKeyCombinationShiftAlt | 32 | 无效组合：Shift+Alt | | HkeInvalidKeyCombinationCtrlAlt | 64 | 无效组合：Ctrl+Alt | | HkeInvalidKeyCombinationShiftCtrlAlt | 128 | 无效组合：Shift+Ctrl+Alt | ## 属性 ### Name ```vb Property Get Name() As String ``` 返回控件的名称。 ### Tag ```vb Property Get/Let Tag() As String ``` 返回/设置控件的标记值。 ### Parent ```vb Property Get Parent() As Object ``` 返回控件的父对象。 ### Container ```vb Property Get/Set Container() As Object ``` 返回/设置控件的容器。 ### Left ```vb Property Get/Let Left() As Single ``` 返回/设置控件左边缘的位置。 ### Top ```vb Property Get/Let Top() As Single ``` 返回/设置控件上边缘的位置。 ### Width ```vb Property Get/Let Width() As Single ``` 返回/设置控件的宽度。 ### Height ```vb Property Get/Let Height() As Single ``` 返回/设置控件的高度。 ### Visible ```vb Property Get/Let Visible() As Boolean ``` 返回/设置控件是否可见。 ### ToolTipText ```vb Property Get/Let ToolTipText() As String ``` 返回/设置控件的工具提示文本。 ### HelpContextID ```vb Property Get/Let HelpContextID() As Long ``` 返回/设置控件的帮助上下文 ID。 ### WhatsThisHelpID ```vb Property Get/Let WhatsThisHelpID() As Long ``` 返回/设置控件的"这是什么"帮助 ID。 ### DragIcon ```vb Property Get/Let/Set DragIcon() As IPictureDisp ``` 返回/设置拖动操作时显示的图标。 ### DragMode ```vb Property Get/Let DragMode() As Integer ``` 返回/设置拖动模式（手动或自动）。 ### hWnd ```vb Property Get hWnd() As LongPtr ``` 返回热键控件的窗口句柄。 ### hWndUserControl ```vb Property Get hWndUserControl() As LongPtr ``` 返回 UserControl 的窗口句柄。 ### Font ```vb Property Get/Let/Set Font() As StdFont ``` 返回/设置控件使用的字体。 ### VisualStyles ```vb Property Get/Let VisualStyles() As Boolean ``` 返回/设置是否启用视觉样式。 ### Enabled ```vb Property Get/Let Enabled() As Boolean ``` 返回/设置控件是否可用。 ### OLEDropMode ```vb Property Get/Let OLEDropMode() As OLEDropModeConstants ``` 返回/设置 OLE 放置模式。参见通用枚举。 ### MousePointer ```vb Property Get/Let MousePointer() As CCMousePointerConstants ``` 返回/设置鼠标指针类型。参见通用枚举。 ### MouseIcon ```vb Property Get/Let/Set MouseIcon() As IPictureDisp ``` 返回/设置自定义鼠标图标。 ### MouseTrack ```vb Property Get/Let MouseTrack() As Boolean ``` 返回/设置是否启用鼠标进入/离开跟踪。 ### BackColor ```vb Property Get/Let BackColor() As OLE_COLOR ``` 返回/设置控件的背景色。 ### BorderStyle ```vb Property Get/Let BorderStyle() As CCBorderStyleConstants ``` 返回/设置控件的边框样式。参见通用枚举。 ### Value ```vb Property Get/Let Value(Optional ByRef Modifiers As Integer) As VBRUN.KeyCodeConstants ``` 返回/设置热键的键码。Modifiers 参数接收修饰键标志（Shift=1, Ctrl=2, Alt=4）。 ### RawValue ```vb Property Get/Let RawValue() As Long ``` 返回/设置热键的原始数值（低字节为键码，高字节为修饰键标志）。 ### Text ```vb Property Get Text() As String ``` 返回热键的显示文本。只读。 ## 方法 ### OLEDrag ```vb Public Sub OLEDrag() ``` 启动 OLE 拖动操作。 ### Drag ```vb Public Sub Drag(Optional ByRef Action As Variant) ``` 开始、结束或取消拖动操作。 ### SetFocus ```vb Public Sub SetFocus() ``` 将焦点移到该控件。 ### ZOrder ```vb Public Sub ZOrder(Optional ByRef Position As Variant) ``` 设置控件在其层级中的 Z 顺序位置。 ### Refresh ```vb Public Sub Refresh() ``` 强制完全重绘控件。 ### SetRules ```vb Public Sub SetRules(ByVal InvalidKeyCombinations As HkeInvalidKeyCombinationConstants, Optional ByVal DefaultModifiers As VBRUN.ShiftConstants) ``` 设置无效键组合规则和默认修饰键。InvalidKeyCombinations 指定不允许的修饰键组合，DefaultModifiers 指定用户输入无效组合时替换为的默认修饰键。 ### SetApplicationHotKey ```vb Public Function SetApplicationHotKey(Optional ByVal hWnd As LongPtr) As Long ``` 将当前热键注册为窗口的应用程序热键。返回值为 WM\_SETHOTKEY 消息的返回值。 ## 事件 ### Click ```vb Public Event Click() ``` 单击控件时发生。 ### DblClick ```vb Public Event DblClick() ``` 双击控件时发生。 ### Change ```vb Public Event Change() ``` 热键值发生变化时发生。 ### PreviewKeyDown ```vb Public Event PreviewKeyDown(ByVal KeyCode As Integer, ByRef IsInputKey As Boolean) ``` 在 KeyDown 事件之前发生，可设置 IsInputKey 标记按键是否为输入键。 ### PreviewKeyUp ```vb Public Event PreviewKeyUp(ByVal KeyCode As Integer, ByRef IsInputKey As Boolean) ``` 在 KeyUp 事件之前发生。 ### KeyDown ```vb Public Event KeyDown(KeyCode As Integer, Shift As Integer) ``` 按下键盘键时发生。 ### KeyUp ```vb Public Event KeyUp(KeyCode As Integer, Shift As Integer) ``` 释放键盘键时发生。 ### KeyPress ```vb Public Event KeyPress(KeyChar As Integer) ``` 按下并释放字符键时发生。 ### MouseDown ```vb Public Event MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` 按下鼠标按钮时发生。 ### MouseMove ```vb Public Event MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` 移动鼠标时发生。 ### MouseUp ```vb Public Event MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` 释放鼠标按钮时发生。 ### MouseEnter ```vb Public Event MouseEnter() ``` 鼠标进入控件时发生。 ### MouseLeave ```vb Public Event MouseLeave() ``` 鼠标离开控件时发生。 ### OLECompleteDrag ```vb Public Event OLECompleteDrag(Effect As Long) ``` OLE 拖放操作完成或取消后，在源控件上发生。 ### OLEDragDrop ```vb Public Event OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single) ``` 数据通过 OLE 拖放操作放置到控件上时发生。 ### OLEDragOver ```vb Public Event OLEDragOver(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single, State As Integer) ``` OLE 拖放操作期间鼠标移过控件时发生。 ### OLEGiveFeedback ```vb Public Event OLEGiveFeedback(Effect As Long, DefaultCursors As Boolean) ``` OLE 拖放操作期间需要更改鼠标光标时，在源控件上发生。 ### OLESetData ```vb Public Event OLESetData(Data As DataObject, DataFormat As Integer) ``` 放置目标请求数据时，在源控件上发生。 ### OLEStartDrag ```vb Public Event OLEStartDrag(Data As DataObject, AllowedEffects As Long) ``` OLE 拖放操作启动时发生。 ## 代码示例 ### 基本用法 ```vb Private Sub Form_Load() With HotKey1 .SetRules HkeInvalidKeyCombinationNone Or _ HkeInvalidKeyCombinationShift, vbCtrlMask .VisualStyles = True End With End Sub Private Sub HotKey1_Change() Dim Modifiers As Integer Dim KeyCode As VBRUN.KeyCodeConstants KeyCode = HotKey1.Value(Modifiers) Debug.Print "热键: " & HotKey1.Text Debug.Print "原始值: " & HotKey1.RawValue End Sub Private Sub cmdRegisterHotKey_Click() Dim Result As Long Result = HotKey1.SetApplicationHotKey(Me.hWnd) If Result = 1 Then Debug.Print "热键注册成功" Else Debug.Print "热键注册失败" End If End Sub ``` --- --- url: /zh/packages/vbccr/datetime/dtpicker.md description: 日期时间选择器控件（DTPicker） - VBCCR 开发手册，基于源码的完整 API 参考 --- # 日期时间选择器控件（DTPicker） 基于 Windows 日期时间选择器通用控件，提供日期和时间的选取与自定义格式化功能。 ## 枚举 ### DtpFormatConstants | 常量 | 值 | 说明 | |------|-----|------| | DtpFormatLongDate | 0 | 长日期格式 | | DtpFormatShortDate | 1 | 短日期格式 | | DtpFormatTime | 2 | 时间格式 | | DtpFormatCustom | 3 | 自定义格式 | ## 属性 ### Name ```vb Property Get Name() As String ``` 返回在代码中标识对象的名称。 ### Tag ```vb Property Get/Let Tag() As String ``` 存储程序所需的附加数据。 ### Parent ```vb Property Get Parent() As Object ``` 返回包含此对象的对象。 ### Container `Property Get Container() As Object` / `Property Set Container(ByVal Value As Object)` 返回/设置对象的容器。 ### Left ```vb Property Get/Let Left() As Single ``` 返回/设置对象左边缘与其容器左边缘的距离。 ### Top ```vb Property Get/Let Top() As Single ``` 返回/设置对象上边缘与其容器上边缘的距离。 ### Width ```vb Property Get/Let Width() As Single ``` 返回/设置对象的宽度。 ### Height ```vb Property Get/Let Height() As Single ``` 返回/设置对象的高度。 ### Visible ```vb Property Get/Let Visible() As Boolean ``` 返回/设置对象是否可见。 ### ToolTipText ```vb Property Get/Let ToolTipText() As String ``` 返回/设置鼠标悬停时显示的提示文本。 ### HelpContextID ```vb Property Get/Let HelpContextID() As Long ``` 指定对象的默认帮助文件上下文 ID。 ### WhatsThisHelpID ```vb Property Get/Let WhatsThisHelpID() As Long ``` 返回/设置与对象关联的上下文编号。 ### DragIcon ```vb Property Get/Let/Set DragIcon() As IPictureDisp ``` 返回/设置拖放操作中显示的图标。 ### DragMode ```vb Property Get/Let DragMode() As Integer ``` 返回/设置拖动模式（手动或自动）。 ### hWnd ```vb Property Get hWnd() As LongPtr ``` 返回日期时间选择器控件的窗口句柄。 ### hWndUserControl ```vb Property Get hWndUserControl() As LongPtr ``` 返回 UserControl 的窗口句柄。 ### hWndCalendar ```vb Property Get hWndCalendar() As LongPtr ``` 返回下拉日历控件的窗口句柄。 ### Font ```vb Property Get/Let/Set Font() As StdFont ``` 返回/设置控件字体。 ### CalendarFont ```vb Property Get/Let/Set CalendarFont() As StdFont ``` 返回/设置下拉日历字体。 ### VisualStyles ```vb Property Get/Let VisualStyles() As Boolean ``` 返回/设置是否启用视觉样式。 ### Enabled ```vb Property Get/Let Enabled() As Boolean ``` 返回/设置控件是否响应用户事件。 ### OLEDropMode ```vb Property Get/Let OLEDropMode() As OLEDropModeConstants ``` 返回/设置对象是否可作为 OLE 放置目标。参见通用枚举。 ### MousePointer ```vb Property Get/Let MousePointer() As CCMousePointerConstants ``` 返回/设置鼠标指针类型。参见通用枚举。 ### MouseIcon ```vb Property Get/Let/Set MouseIcon() As IPictureDisp ``` 返回/设置自定义鼠标图标。 ### MouseTrack ```vb Property Get/Let MouseTrack() As Boolean ``` 返回/设置是否触发 MouseEnter/MouseLeave 事件。 ### RightToLeft ```vb Property Get/Let RightToLeft() As Boolean ``` 决定双向系统上的文本显示方向和控件视觉外观。 ### RightToLeftLayout ```vb Property Get/Let RightToLeftLayout() As Boolean ``` 返回/设置是否启用从右到左镜像布局。 ### RightToLeftMode ```vb Property Get/Let RightToLeftMode() As CCRightToLeftModeConstants ``` 返回/设置从右到左模式。参见通用枚举。 ### CalendarBackColor ```vb Property Get/Let CalendarBackColor() As OLE_COLOR ``` 返回/设置日历月份区域的背景色。 ### CalendarForeColor ```vb Property Get/Let CalendarForeColor() As OLE_COLOR ``` 返回/设置日历月份区域的前景色。 ### CalendarTitleBackColor ```vb Property Get/Let CalendarTitleBackColor() As OLE_COLOR ``` 返回/设置日历标题的背景色。 ### CalendarTitleForeColor ```vb Property Get/Let CalendarTitleForeColor() As OLE_COLOR ``` 返回/设置日历标题的前景色。 ### CalendarTrailingForeColor ```vb Property Get/Let CalendarTrailingForeColor() As OLE_COLOR ``` 返回/设置日历末尾日期的前景色。 ### CalendarShowToday ```vb Property Get/Let CalendarShowToday() As Boolean ``` 返回/设置日历是否在底部显示"今天"日期。 ### CalendarShowTodayCircle ```vb Property Get/Let CalendarShowTodayCircle() As Boolean ``` 返回/设置是否在今天的日期上画圆圈。 ### CalendarShowWeekNumbers ```vb Property Get/Let CalendarShowWeekNumbers() As Boolean ``` 返回/设置日历是否显示周数。 ### CalendarShowTrailingDates ```vb Property Get/Let CalendarShowTrailingDates() As Boolean ``` 返回/设置日历是否显示上/下月的日期。 ### CalendarAlignment ```vb Property Get/Let CalendarAlignment() As CCLeftRightAlignmentConstants ``` 返回/设置日历的对齐方式。参见通用枚举。 ### CalendarDayState ```vb Property Get/Let CalendarDayState() As Boolean ``` 返回/设置日历是否支持 CalendarGetDayBold 事件中的粗体日期。 ### CalendarUseShortestDayNames ```vb Property Get/Let CalendarUseShortestDayNames() As Boolean ``` 返回/设置日历是否使用最短日期名称。 ### MinDate ```vb Property Get/Let MinDate() As Date ``` 返回/设置可选择的最小日期。 ### MaxDate ```vb Property Get/Let MaxDate() As Date ``` 返回/设置可选择的最大日期。 ### Value ```vb Property Get/Let Value() As Variant ``` 返回/设置当前日期时间值。 ### Year ```vb Property Get Year() As Integer ``` 返回当前日期的年份（只读）。 ### Month ```vb Property Get Month() As Integer ``` 返回当前日期的月份（只读）。 ### Week ```vb Property Get Week() As Integer ``` 返回当前日期的周数（只读）。 ### Day ```vb Property Get Day() As Integer ``` 返回当前日期的日（只读）。 ### Hour ```vb Property Get Hour() As Integer ``` 返回当前时间的小时（只读）。 ### Minute ```vb Property Get Minute() As Integer ``` 返回当前时间的分钟（只读）。 ### Second ```vb Property Get Second() As Integer ``` 返回当前时间的秒（只读）。 ### Format ```vb Property Get/Let Format() As DtpFormatConstants ``` 返回/设置日期时间的显示格式。 ### CustomFormat ```vb Property Get/Let CustomFormat() As String ``` 返回/设置自定义格式字符串。 ### UpDown ```vb Property Get/Let UpDown() As Boolean ``` 返回/设置是否使用上下按钮代替下拉日历。 ### CheckBox ```vb Property Get/Let CheckBox() As Boolean ``` 返回/设置是否在控件中显示复选框。 ### AllowUserInput ```vb Property Get/Let AllowUserInput() As Boolean ``` 返回/设置是否允许用户直接输入日期。 ### StartOfWeek ```vb Property Get/Let StartOfWeek() As Integer ``` 返回/设置一周的起始日（0=系统默认, 1=周一, ..., 7=周日）。 ### DroppedDown ```vb Property Get DroppedDown() As Boolean ``` 返回日历是否处于下拉状态（只读）。 ### Selected ```vb Property Get Selected() As Boolean ``` 返回复选框是否被选中（只读）。 ### DayCount ```vb Property Get DayCount() As Long ``` 返回当前可见的日期数（只读）。 ### DayOfWeek ```vb Property Get DayOfWeek() As Integer ``` 返回当前日期是星期几（只读）。 ### SystemStartOfWeek ```vb Property Get SystemStartOfWeek() As Integer ``` 返回系统一周起始日（只读）。 ## 方法 ### OLEDrag ```vb Public Sub OLEDrag() ``` 启动 OLE 拖放操作。 ### Drag ```vb Public Sub Drag(Optional ByRef Action As Variant) ``` 开始、结束或取消拖动操作。 ### SetFocus ```vb Public Sub SetFocus() ``` 将焦点移到控件上。 ### ZOrder ```vb Public Sub ZOrder(Optional ByRef Position As Variant) ``` 将控件放置在 Z 轴顺序的前面或后面。 ### Refresh ```vb Public Sub Refresh() ``` 强制重绘控件。 ### GetIdealSize ```vb Public Sub GetIdealSize(ByRef Width As Long, ByRef Height As Long) ``` 获取控件的理想尺寸。 ## 事件 ### Click ```vb Public Event Click() ``` 用户按下并释放鼠标按钮时发生。 ### DropDown ```vb Public Event DropDown() ``` 下拉日历即将展开时发生。 ### CloseUp ```vb Public Event CloseUp() ``` 用户关闭日历时发生。 ### Change ```vb Public Event Change() ``` 控件内容发生变化时发生。 ### ContextMenu ```vb Public Event ContextMenu(ByRef Handled As Boolean, ByVal X As Single, ByVal Y As Single) ``` 用户右键点击或按 Shift+F10 时发生。 ### CalendarGetDayBold ```vb Public Event CalendarGetDayBold(ByVal StartDate As Date, ByVal Count As Long, ByRef State() As Boolean) ``` 日历请求日期粗体信息时发生。需要 comctl32.dll 版本 6.1 或更高。 ### CalendarContextMenu ```vb Public Event CalendarContextMenu(ByRef Handled As Boolean, ByVal X As Single, ByVal Y As Single) ``` 日历区域右键点击时发生。 ### CallbackKeyDown ```vb Public Event CallbackKeyDown(ByVal KeyCode As Integer, ByVal Shift As Integer, ByVal CallbackField As String, ByRef CallbackDate As Date) ``` 用户在回调字段上按键时发生。 ### FormatString ```vb Public Event FormatString(ByVal CallbackField As String, ByRef FormattedString As String) ``` 控件请求回调字段的显示文本时发生。 ### FormatSize ```vb Public Event FormatSize(ByVal CallbackField As String, ByRef Size As Integer) ``` 控件需要知道回调字段的最大允许大小时发生。 ### BeforeUserInput ```vb Public Event BeforeUserInput(ByVal hWndEdit As LongPtr) ``` 用户尝试输入字符串时发生。 ### ParseUserInput ```vb Public Event ParseUserInput(ByVal Text As String, ByRef ParseDate As Variant) ``` 用户输入完成时发生，需要解析输入字符串。 ### AfterUserInput ```vb Public Event AfterUserInput() ``` 用户输入已完成或取消时发生。 ### PreviewKeyDown ```vb Public Event PreviewKeyDown(ByVal KeyCode As Integer, ByRef IsInputKey As Boolean) ``` 在 KeyDown 事件之前发生。 ### PreviewKeyUp ```vb Public Event PreviewKeyUp(ByVal KeyCode As Integer, ByRef IsInputKey As Boolean) ``` 在 KeyUp 事件之前发生。 ### KeyDown ```vb Public Event KeyDown(KeyCode As Integer, Shift As Integer) ``` 用户按下键时发生。 ### KeyUp ```vb Public Event KeyUp(KeyCode As Integer, Shift As Integer) ``` 用户释放键时发生。 ### KeyPress ```vb Public Event KeyPress(KeyChar As Integer) ``` 用户按下并释放字符键时发生。 ### MouseDown ```vb Public Event MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` 用户按下鼠标按钮时发生。 ### MouseMove ```vb Public Event MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` 用户移动鼠标时发生。 ### MouseUp ```vb Public Event MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` 用户释放鼠标按钮时发生。 ### MouseEnter ```vb Public Event MouseEnter() ``` 鼠标进入控件时发生。 ### MouseLeave ```vb Public Event MouseLeave() ``` 鼠标离开控件时发生。 ### OLECompleteDrag ```vb Public Event OLECompleteDrag(Effect As Long) ``` OLE 拖放操作完成后发生。 ### OLEDragDrop ```vb Public Event OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single) ``` 数据通过 OLE 拖放操作放置到控件上时发生。 ### OLEDragOver ```vb Public Event OLEDragOver(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single, State As Integer) ``` 鼠标在 OLE 拖放操作期间移过控件时发生。 ### OLEGiveFeedback ```vb Public Event OLEGiveFeedback(Effect As Long, DefaultCursors As Boolean) ``` 需要更改鼠标光标时发生。 ### OLESetData ```vb Public Event OLESetData(Data As DataObject, DataFormat As Integer) ``` 放置目标请求数据时发生。 ### OLEStartDrag ```vb Public Event OLEStartDrag(Data As DataObject, AllowedEffects As Long) ``` OLE 拖放操作启动时发生。 ## 代码示例 ### 基本用法 ```vb Private Sub Form_Load() With DTPicker1 .Format = DtpFormatShortDate .Value = Date .MinDate = #1/1/1900# .MaxDate = #12/31/9999# End With End Sub Private Sub DTPicker1_Change() MsgBox "选择的日期: " & DTPicker1.Value End Sub ``` ### 自定义格式与回调 ```vb Private Sub Form_Load() DTPicker1.Format = DtpFormatCustom DTPicker1.CustomFormat = "yyyy年MM月dd日 '第' w '周'" End Sub Private Sub DTPicker1_FormatString(ByVal CallbackField As String, ByRef FormattedString As String) Select Case CallbackField Case "w" FormattedString = CStr(DatePart("ww", DTPicker1.Value, vbMonday)) End Select End Sub ``` --- --- url: /zh/biz/cs-auther/logging.md --- # 日志系统详解 本文档详细介绍服务端的多级日志体系，包括全局系统日志和各业务模块的专用日志。 *** ## 日志架构概览 服务端采用**分层日志设计**： ``` ┌─────────────────────────────────────────────────────────┐ │ 全局系统日志 (Insts.AddLog) │ │ └── 记录：系统启动、客户端连接/断开、登录认证等 │ ├─────────────────────────────────────────────────────────┤ │ 业务专用日志 (cLogs) │ │ ├── bCalc.cls → logs/JsonData/ │ │ ├── bFileManage.cls → logs/FileServer/ │ │ └── fNotify.frm → logs/Notify/ │ └─────────────────────────────────────────────────────────┘ ``` *** ## 全局系统日志 ### 位置 `src-server/Insts.bas` ### 接口定义 ```vb Public Sub AddLog(ByVal Msg As String, Optional Level As EnumLogLevel = LvInfo, Optional Title As String) ``` ### 参数说明 | 参数 | 类型 | 默认值 | 说明 | |------|------|--------|------| | `Msg` | String | - | 日志内容 | | `Level` | EnumLogLevel | `LvInfo` | 日志级别 | | `Title` | String | `""` | 日志标题/分类 | ### 日志级别 | 级别 | 常量 | 用途 | |------|------|------| | 信息 | `LvInfo` | 正常操作记录 | | 警告 | `LvWarning` | 需要注意的非错误事件 | | 危险 | `LvDanger` | 错误、异常、安全事件 | ### 输出目标 1. **文件日志**: 通过 `VBMAN.Logs` 写入 `logs/年/月/年月日.txt` 2. **界面显示**: 实时显示在 `Form1.List2` 列表框 ### 使用示例 ```vb AddLog "系统启动完成", LvInfo, "系统启动" AddLog "客户端断开，当前在线: 5", LvWarning, "断开" AddLog "认证失败: 凭证为空", LvDanger, "认证失败" ``` *** ## 系统日志记录场景 ### Form1.frm — 主窗体系统事件 | 事件 | 日志级别 | 记录内容 | |------|---------|---------| | 系统启动 | Info | "系统启动中..."、"TCP 服务已启动，端口: 800"、"数据库连接成功"、"路由注册完成"、"系统启动完成" | | 客户端连接 | Info | "新客户端连接请求"、"新客户端连接，当前在线: N" | | 客户端断开 | Warning | "客户端断开，当前在线: N"、"客户端断开连接: \[用户名]" | ### mAuth.cls — 认证中间件 | 场景 | 日志级别 | 记录内容 | |------|---------|---------| | 凭证为空 | Danger | "认证失败: 凭证为空 \[用户: xxx]" | | 未绑定用户 | Danger | "认证失败: 当前客户端未绑定用户" | | 凭证验证失败 | Danger | "认证失败: 凭证验证失败 \[用户: xxx]" | ### bUser.cls — 用户登录 | 场景 | 日志级别 | 记录内容 | |------|---------|---------| | 用户名不存在 | Warning | "登录失败: 用户名不存在 \[xxx]" | | 密码未设置 | Warning | "登录失败: 用户密码未设置 \[xxx]" | | 密码错误 | Warning | "登录失败: 密码错误 \[xxx]" | | 踢掉旧连接 | Warning | "账号在另外一个地方登录，踢掉旧连接: xxx" | | 登录成功 | Info | "用户登录成功: xxx \[昵称]" | ### bNotify.cls — 公告查询 | 场景 | 日志级别 | 记录内容 | |------|---------|---------| | 用户获取公告 | Info | "用户获取公告: xxx" | *** ## 业务专用日志 各业务模块使用独立的 `cLogs` 实例，日志存储在各自的子目录中，与系统日志分离。 ### bCalc.cls — 计算参数日志 **日志目录**: `logs/JsonData/` **用途**: 记录客户端提交的参数数据和服务端修改后的数据，用于数据核对和调试。 ```vb Dim LogInst As New cLogs Private Sub Class_Initialize() LogInst.LogSubDir = "JsonData" LogInst.HostApp App End Sub Public Sub Submit(Inst As cWinsock, Data As cJson) ' 记录客户端发来的数据 LogInst.DataLine Data.Encode(, 2, True), "客户端发来数据" ' ... 处理数据 ... ' 记录修改后的数据 LogInst.DataLine Data.Encode(, 2, True), "服务端修改数据" LogInst.Save End Sub ``` **记录格式**: JSON 格式，带缩进便于阅读 *** ### bFileManage.cls — 文件传输日志 **日志目录**: `logs/FileServer/` **用途**: 记录文件上传、下载、归档、删除等操作。 ```vb Dim LogInst As New cLogs Public Sub StartMe(ByVal Port As Long) ' ... 启动服务 ... LogInst.LogSubDir = "FileServer" LogInst.HostApp App LogInst.DataLine "文件传输服务已启动，端口: " & Port, "启动" LogInst.Save End Sub ``` **记录场景**: | 场景 | 日志级别 | 记录内容 | |------|---------|---------| | 服务启动/停止 | Info | "文件传输服务已启动/停止，端口: xxx" | | 文件上传归档 | Info | "文件已归档 \[用户名]: 原文件名 -> 目标路径" | | 临时文件不存在 | Danger | "错误: 临时文件不存在 \[用户名]: 路径" | | 归档失败 | Danger | "归档失败 \[用户名]: 文件名 - 错误描述" | | 发送完成 | Info | "发送完成 \[用户名]: 文件名" | | 文件下发 | Info/Danger | 开始发送、文件不存在、发送失败等 | | 文件删除 | Warning | "用户删除文件 \[用户名]: 文件路径" | *** ### fNotify.frm — 公告推送日志 **日志目录**: `logs/Notify/` **用途**: 记录公告的推送和清空操作。 ```vb Dim LogInst As New cLogs Private Sub Form_Load() LogInst.LogSubDir = "Notify" LogInst.HostApp App End Sub Private Sub Command1_Click() ' 推送按钮 ' ... 推送公告 ... Dim Content As String Content = VBMAN.Json.Decode(VBMAN.Ini("Notify")).Encode(, 2, True) LogInst.DataLine(Content, "推送了新公告").Save End Sub Private Sub Command2_Click() ' 清空按钮 ' ... 清空公告 ... LogInst.Data("", "清空了公告", LvDanger).Save End Sub ``` **记录场景**: | 场景 | 日志级别 | 记录内容 | |------|---------|---------| | 推送公告 | Info | 完整的公告 JSON 内容，标题"推送了新公告" | | 清空公告 | Danger | 空内容，标题"清空了公告" | *** ## 日志文件结构 ``` logs/ ├── 2026/ │ └── 04/ │ └── 20260430.txt # 系统日志（全局） ├── JsonData/ │ └── 2026/ │ └── 04/ │ └── 20260430.txt # 计算参数日志 ├── FileServer/ │ └── 2026/ │ └── 04/ │ └── 20260430.txt # 文件传输日志 └── Notify/ └── 2026/ └── 04/ └── 20260430.txt # 公告操作日志 ``` *** ## 配置说明 ### 全局日志配置 (Form1.Form\_Load) ```vb ' 如果 vbman.dll 和 exe 不在同一目录，必须配置 HostApp VBMAN.Logs.HostApp App ``` ### 专用日志配置 (各业务模块) ```vb With LogInst .LogSubDir = "子目录名" ' 指定日志子目录 .HostApp App ' 配置宿主程序 End With ``` *** ## 最佳实践 1. **系统级事件**使用全局 `AddLog`，便于统一监控系统运行状态 2. **业务数据**使用专用 `cLogs` 实例，避免系统日志被大量业务数据淹没 3. **敏感操作**（登录失败、密码修改、文件删除等）务必记录，用于安全审计 4. **日志级别选择**: * `LvInfo` - 正常流程记录 * `LvWarning` - 需要注意但非错误的事件 * `LvDanger` - 错误、异常、安全风险事件 --- --- url: /zh/emoji/0880-08AF.md --- # 撒马利亚语 (Samaritan) 本页面展示了Unicode字符集中，位于U+0880到U+08AF范围的撒马利亚文字符。撒马利亚字母是闪米特语系文字之一，用于书写撒马利亚希伯来语和阿拉米语。 | 字符 | Unicode | VB函数值 | 名称 | |:---:|:---:|:---:|:---| | ࢠ | U+0880 | ChrW(\&H0880) | 撒马利亚字母ALAF | | ࢡ | U+0881 | ChrW(\&H0881) | 撒马利亚字母BIT | | ࢢ | U+0882 | ChrW(\&H0882) | 撒马利亚字母GAMAN | | ࢣ | U+0883 | ChrW(\&H0883) | 撒马利亚字母DALAT | | ࢤ | U+0884 | ChrW(\&H0884) | 撒马利亚字母IY | | ࢥ | U+0885 | ChrW(\&H0885) | 撒马利亚字母BAA | | ࢦ | U+0886 | ChrW(\&H0886) | 撒马利亚字母ZEN | | ࢧ | U+0887 | ChrW(\&H0887) | 撒马利亚字母IT | | ࢨ | U+0888 | ChrW(\&H0888) | 撒马利亚字母TIT | | ࢩ | U+0889 | ChrW(\&H0889) | 撒马利亚字母YUT | --- --- url: /zh/emoji/0D80-0DFF.md --- # 僧伽罗语 (Sinhala) 本页面展示了Unicode字符集中，位于U+0D80到U+0DFF范围的僧伽罗文字符。僧伽罗文是斯里兰卡的官方文字，用于书写僧伽罗语。 | 字符 | Unicode | VB函数值 | 名称 | |:---:|:---:|:---:|:---| | ඁ | U+0D81 | ChrW(\&H0D81) | 僧伽罗文标记CANDRABINDU | | ං | U+0D82 | ChrW(\&H0D82) | 僧伽罗文标记ANUSVARAYA | | ඃ | U+0D83 | ChrW(\&H0D83) | 僧伽罗文标记VISARGAYA | | අ | U+0D85 | ChrW(\&H0D85) | 僧伽罗文字母AYANNA | | ආ | U+0D86 | ChrW(\&H0D86) | 僧伽罗文字母AAYANNA | | ඇ | U+0D87 | ChrW(\&H0D87) | 僧伽罗文字母AEYANNA | | ඈ | U+0D88 | ChrW(\&H0D88) | 僧伽罗文字母AEEYANNA | | ඉ | U+0D89 | ChrW(\&H0D89) | 僧伽罗文字母IYANNA | | ඊ | U+0D8A | ChrW(\&H0D8A) | 僧伽罗文字母IIYANNA | | උ | U+0D8B | ChrW(\&H0D8B) | 僧伽罗文字母UYANNA | --- --- url: /zh/emoji/2070-209F.md --- # 上标及下标 (Superscripts and Subscripts) 本页面展示了Unicode字符集中，位于U+2070到U+209F范围的上标和下标字符。这些字符常用于数学和科学符号中。 | 字符 | Unicode | VB函数值 | 名称 | |:---:|:---:|:---:|:---| | ⁰ | U+2070 | ChrW(\&H2070) | 上标数字零 | | ⁱ | U+2071 | ChrW(\&H2071) | 上标字母i | | ⁲ | U+2072 | ChrW(\&H2072) | 上标数字二 | | ⁳ | U+2073 | ChrW(\&H2073) | 上标数字三 | | ⁴ | U+2074 | ChrW(\&H2074) | 上标数字四 | | ⁵ | U+2075 | ChrW(\&H2075) | 上标数字五 | | ⁶ | U+2076 | ChrW(\&H2076) | 上标数字六 | | ⁷ | U+2077 | ChrW(\&H2077) | 上标数字七 | | ⁸ | U+2078 | ChrW(\&H2078) | 上标数字八 | | ⁹ | U+2079 | ChrW(\&H2079) | 上标数字九 | | ⁺ | U+207A | ChrW(\&H207A) | 上标加号 | | ⁻ | U+207B | ChrW(\&H207B) | 上标减号 | | ⁼ | U+207C | ChrW(\&H207C) | 上标等号 | | ⁽ | U+207D | ChrW(\&H207D) | 上标左括号 | | ⁾ | U+207E | ChrW(\&H207E) | 上标右括号 | | ⁿ | U+207F | ChrW(\&H207F) | 上标字母n | | ₀ | U+2080 | ChrW(\&H2080) | 下标数字零 | | ₁ | U+2081 | ChrW(\&H2081) | 下标数字一 | | ₂ | U+2082 | ChrW(\&H2082) | 下标数字二 | | ₃ | U+2083 | ChrW(\&H2083) | 下标数字三 | | ₄ | U+2084 | ChrW(\&H2084) | 下标数字四 | | ₅ | U+2085 | ChrW(\&H2085) | 下标数字五 | | ₆ | U+2086 | ChrW(\&H2086) | 下标数字六 | | ₇ | U+2087 | ChrW(\&H2087) | 下标数字七 | | ₈ | U+2088 | ChrW(\&H2088) | 下标数字八 | | ₉ | U+2089 | ChrW(\&H2089) | 下标数字九 | | ₊ | U+208A | ChrW(\&H208A) | 下标加号 | | ₋ | U+208B | ChrW(\&H208B) | 下标减号 | | ₌ | U+208C | ChrW(\&H208C) | 下标等号 | | ₍ | U+208D | ChrW(\&H208D) | 下标左括号 | | ₎ | U+208E | ChrW(\&H208E) | 下标右括号 | | ₏ | U+208F | ChrW(\&H208F) | 下标字母n | --- --- url: /zh/packages/vbccr/ranges/updown.md description: 上下调整控件（UpDown） - VBCCR 开发手册，基于源码的完整 API 参考 --- # 上下调整控件（UpDown） 提供数值递增/递减的旋转按钮，支持伙伴控件同步、循环和十六进制显示。 ## 枚举 ### UdnOrientationConstants 控件方向常量。 | 常量 | 值 | 说明 | |------|-----|------| | UdnOrientationVertical | 0 | 垂直方向 | | UdnOrientationHorizontal | 1 | 水平方向 | ### UdnNumberStyleConstants 数字显示样式常量。 | 常量 | 值 | 说明 | |------|-----|------| | UdnNumberStyleDecimal | 0 | 十进制 | | UdnNumberStyleHexadecimal | 1 | 十六进制 | ## 属性 ### Name ```vb Public Property Get Name() As String ``` 返回在代码中标识对象的名称。 ### Tag ```vb Public Property Get Tag() As String Public Property Let Tag(ByVal Value As String) ``` 存储程序所需的额外数据。 ### Parent ```vb Public Property Get Parent() As Object ``` 返回对象所在的对象。 ### Container ```vb Public Property Get Container() As Object Public Property Set Container(ByVal Value As Object) ``` 返回/设置对象的容器。 ### Left ```vb Public Property Get Left() As Single Public Property Let Left(ByVal Value As Single) ``` 返回/设置对象与其容器左边缘的距离。 ### Top ```vb Public Property Get Top() As Single Public Property Let Top(ByVal Value As Single) ``` 返回/设置对象与其容器顶边缘的距离。 ### Width ```vb Public Property Get Width() As Single Public Property Let Width(ByVal Value As Single) ``` 返回/设置对象的宽度。 ### Height ```vb Public Property Get Height() As Single Public Property Let Height(ByVal Value As Single) ``` 返回/设置对象的高度。 ### Visible ```vb Public Property Get Visible() As Boolean Public Property Let Visible(ByVal Value As Boolean) ``` 返回/设置对象是否可见。 ### ToolTipText ```vb Public Property Get ToolTipText() As String Public Property Let ToolTipText(ByVal Value As String) ``` 返回/设置鼠标悬停时显示的提示文本。 ### WhatsThisHelpID ```vb Public Property Get WhatsThisHelpID() As Long Public Property Let WhatsThisHelpID(ByVal Value As Long) ``` 返回/设置关联的上下文帮助ID。 ### DragIcon ```vb Public Property Get DragIcon() As IPictureDisp Public Property Let DragIcon(ByVal Value As IPictureDisp) Public Property Set DragIcon(ByVal Value As IPictureDisp) ``` 返回/设置拖放操作中显示的图标。 ### DragMode ```vb Public Property Get DragMode() As Integer Public Property Let DragMode(ByVal Value As Integer) ``` 返回/设置拖动模式。 ### hWnd ```vb Public Property Get hWnd() As LongPtr ``` 返回控件句柄。 ### hWndUserControl ```vb Public Property Get hWndUserControl() As LongPtr ``` 返回UserControl句柄。 ### VisualStyles ```vb Public Property Get VisualStyles() As Boolean Public Property Let VisualStyles(ByVal Value As Boolean) ``` 返回/设置是否启用视觉样式。需要comctl32.dll 6.0或更高版本。 ### Enabled ```vb Public Property Get Enabled() As Boolean Public Property Let Enabled(ByVal Value As Boolean) ``` 返回/设置对象是否能响应用户事件。 ### OLEDropMode ```vb Public Property Get OLEDropMode() As OLEDropModeConstants Public Property Let OLEDropMode(ByVal Value As OLEDropModeConstants) ``` 返回/设置对象是否可以作为OLE放置目标。 ### MousePointer ```vb Public Property Get MousePointer() As CCMousePointerConstants Public Property Let MousePointer(ByVal Value As CCMousePointerConstants) ``` 返回/设置鼠标悬停时显示的指针类型。参见通用枚举。 ### MouseIcon ```vb Public Property Get MouseIcon() As IPictureDisp Public Property Let MouseIcon(ByVal Value As IPictureDisp) Public Property Set MouseIcon(ByVal Value As IPictureDisp) ``` 返回/设置自定义鼠标图标。 ### MouseTrack ```vb Public Property Get MouseTrack() As Boolean Public Property Let MouseTrack(ByVal Value As Boolean) ``` 返回/设置是否在鼠标进入或离开控件时触发事件。 ### RightToLeft ```vb Public Property Get RightToLeft() As Boolean Public Property Let RightToLeft(ByVal Value As Boolean) ``` 返回/设置从右到左显示方向。 ### RightToLeftLayout ```vb Public Property Get RightToLeftLayout() As Boolean Public Property Let RightToLeftLayout(ByVal Value As Boolean) ``` 返回/设置从右到左布局。 ### RightToLeftMode ```vb Public Property Get RightToLeftMode() As CCRightToLeftModeConstants Public Property Let RightToLeftMode(ByVal Value As CCRightToLeftModeConstants) ``` 返回/设置从右到左模式。参见通用枚举。 ### BuddyControl ```vb Public Property Get BuddyControl() As Variant Public Property Let BuddyControl(ByVal Value As Variant) Public Property Set BuddyControl(ByVal Value As Variant) ``` 返回/设置关联的伙伴控件。 ### BuddyProperty ```vb Public Property Get BuddyProperty() As String Public Property Let BuddyProperty(ByVal Value As String) ``` 返回/设置伙伴控件的属性名，用于同步数据。 ### SyncBuddy ```vb Public Property Get SyncBuddy() As Boolean Public Property Let SyncBuddy(ByVal Value As Boolean) ``` 返回/设置是否与伙伴控件自动同步值。 ### Min ```vb Public Property Get Min() As Long Public Property Let Min(ByVal Value As Long) ``` 返回/设置最小值。 ### Max ```vb Public Property Get Max() As Long Public Property Let Max(ByVal Value As Long) ``` 返回/设置最大值。 ### Value ```vb Public Property Get Value() As Long Public Property Let Value(ByVal Value As Long) ``` 返回/设置当前值。 ### Increment ```vb Public Property Get Increment() As Long Public Property Let Increment(ByVal Value As Long) ``` 返回/设置每次点击的递增/递减量。 ### Wrap ```vb Public Property Get Wrap() As Boolean Public Property Let Wrap(ByVal Value As Boolean) ``` 返回/设置值是否循环。当为True时，超过最大值回到最小值，反之亦然。 ### HotTracking ```vb Public Property Get HotTracking() As Boolean Public Property Let HotTracking(ByVal Value As Boolean) ``` 返回/设置是否启用热点跟踪。 ### Orientation ```vb Public Property Get Orientation() As UdnOrientationConstants Public Property Let Orientation(ByVal Value As UdnOrientationConstants) ``` 返回/设置控件方向。 ### ThousandsSeparator ```vb Public Property Get ThousandsSeparator() As Boolean Public Property Let ThousandsSeparator(ByVal Value As Boolean) ``` 返回/设置是否显示千位分隔符。 ### NumberStyle ```vb Public Property Get NumberStyle() As UdnNumberStyleConstants Public Property Let NumberStyle(ByVal Value As UdnNumberStyleConstants) ``` 返回/设置数字显示样式。 ## 方法 ### OLEDrag ```vb Public Sub OLEDrag() ``` 启动OLE拖放操作。 ### Drag ```vb Public Sub Drag(Optional ByRef Action As Variant) ``` 开始、结束或取消拖动操作。 ### ZOrder ```vb Public Sub ZOrder(Optional ByRef Position As Variant) ``` 设置Z顺序。 ### Refresh ```vb Public Sub Refresh() ``` 强制完全重绘对象。 ### SyncFromBuddy ```vb Public Sub SyncFromBuddy() ``` 从伙伴控件同步值到UpDown控件。 ## 事件 ### DownClick ```vb Public Event DownClick() ``` 点击向下/向左按钮时触发。 ### UpClick ```vb Public Event UpClick() ``` 点击向上/向右按钮时触发。 ### BeforeChange ```vb Public Event BeforeChange(ByVal Value As Long, ByRef Delta As Long) ``` 值即将改变时触发。Value为当前值，Delta为预期变化量，可修改Delta控制实际变化。 ### Change ```vb Public Event Change() ``` 值改变后触发。 ### MouseDown ```vb Public Event MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` 按下鼠标按钮时触发。 ### MouseMove ```vb Public Event MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` 移动鼠标时触发。 ### MouseUp ```vb Public Event MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` 释放鼠标按钮时触发。 ### MouseEnter ```vb Public Event MouseEnter() ``` 鼠标进入控件区域时触发。 ### MouseLeave ```vb Public Event MouseLeave() ``` 鼠标离开控件区域时触发。 ### OLECompleteDrag ```vb Public Event OLECompleteDrag(Effect As Long) ``` OLE拖放操作完成时触发。 ### OLEDragDrop ```vb Public Event OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single) ``` OLE拖放操作放置时触发。 ### OLEDragOver ```vb Public Event OLEDragOver(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single, State As Integer) ``` OLE拖放操作悬停时触发。 ### OLEGiveFeedback ```vb Public Event OLEGiveFeedback(Effect As Long, DefaultCursors As Boolean) ``` OLE拖放操作给反馈时触发。 ### OLESetData ```vb Public Event OLESetData(Data As DataObject, DataFormat As Integer) ``` OLE拖放操作设置数据时触发。 ### OLEStartDrag ```vb Public Event OLEStartDrag(Data As DataObject, AllowedEffects As Long) ``` OLE拖放操作开始时触发。 ## 代码示例 ### 基本用法 ```vb ' 设置UpDown控件 With UpDown1 .Min = 0 .Max = 100 .Value = 50 .Increment = 5 .Wrap = True Set .BuddyControl = Text1 .BuddyProperty = "Text" .SyncBuddy = True End With ' 限制值变化范围 Private Sub UpDown1_BeforeChange(ByVal Value As Long, ByRef Delta As Long) If Value + Delta > 100 Then Delta = 0 End Sub ' 响应值变化 Private Sub UpDown1_Change() Debug.Print "当前值: " & UpDown1.Value End Sub ``` --- --- url: /zh/vbman/Toast/examples.md --- # 使用示例 本文档提供 cToast 组件的各种使用场景示例代码。 ## 目录 * [基础示例](#基础示例) * [位置控制](#位置控制) * [状态和主题](#状态和主题) * [堆叠管理](#堆叠管理) * [弹窗管理](#弹窗管理) * [事件监听](#事件监听) * [实际应用场景](#实际应用场景) *** ## 基础示例 ### 示例1：最简单的弹窗 ```vb ' 默认居中显示，3秒后自动关闭 With New cToast .Show "欢迎使用 VBMan！" End With ``` ### 示例2：指定显示时间 ```vb ' 1秒后自动关闭 With New cToast .Show "快速提示", 1000 End With ' 持久显示（不自动关闭） With New cToast .Show "重要通知，请关注", 0 End With ``` ### 示例3：自定义标题 ```vb With New cToast .Show "文件保存成功", 2000, "成功" End With With New cToast .Show "网络连接失败", 5000, "错误" End With ``` *** ## 位置控制 ### 示例1：9种位置对比 ```vb Dim Toast As New cToast ' 左上 Toast.Pos(LeftTop).State(Info).Show "左上角", 0, "LeftTop" ' 左中 Toast.Pos(LeftCenter).State(Success).Show "左中覆盖", 0, "LeftCenter" ' 左下 Toast.Pos(LeftBottom).State(Warning).Show "左下角", 0, "LeftBottom" ' 居上 Toast.Pos(CenterTop).State(Danger).Show "居上堆叠", 0, "CenterTop" ' 居中 Toast.Pos(Center).State(Info).Show "居中覆盖", 0, "Center" ' 居下 Toast.Pos(CenterBottom).State(Success).Show "居下堆叠", 0, "CenterBottom" ' 右上 Toast.Pos(RightTop).State(Warning).Show "右上角", 0, "RightTop" ' 右中 Toast.Pos(RightCenter).State(Danger).Show "右中覆盖", 0, "RightCenter" ' 右下 Toast.Pos(RightBottom).State(Info).Show "右下角", 0, "RightBottom" ``` ### 示例2：常用位置组合 ```vb Dim Toast As New cToast ' 右上角成功提示 Toast.Pos(RightTop).State(Success).Show "操作成功", 2000 ' 右下角警告提示 Toast.Pos(RightBottom).State(Warning).Show "请注意", 3000 ' 居中错误提示 Toast.Pos(Center).State(Danger).Show "发生错误", 4000 ``` *** ## 状态和主题 ### 示例1：4种状态 ```vb Dim Toast As New cToast ' 信息提示 Toast.State(Info).Show "这是一条信息提示", 3000 ' 成功提示 Toast.State(Success).Show "操作成功完成！", 2000 ' 警告提示 Toast.State(Warning).Show "请注意此操作", 3000 ' 危险提示 Toast.State(Danger).Show "操作失败，请重试", 4000 ``` ### 示例2：深色主题 ```vb Dim Toast As New cToast ' 深色主题 + 信息 Toast.Theme(Dark).State(Info).Show "深色信息提示", 3000 ' 深色主题 + 成功 Toast.Theme(Dark).State(Success).Show "深色成功提示", 2000 ' 深色主题 + 警告 Toast.Theme(Dark).State(Warning).Show "深色警告提示", 3000 ' 深色主题 + 危险 Toast.Theme(Dark).State(Danger).Show "深色危险提示", 4000 ``` ### 示例3：混合使用 ```vb Dim Toast As New cToast ' 浅色 + 成功 + 右上 Toast.Theme(Light).State(Success).Pos(RightTop).Show "保存成功", 2000 ' 深色 + 警告 + 右下 Toast.Theme(Dark).State(Warning).Pos(RightBottom).Show "网络不稳定", 0 ' 深色 + 危险 + 居中 Toast.Theme(Dark).State(Danger).Pos(Center).Show "严重错误", 0 ``` *** ## 堆叠管理 ### 示例1：自动堆叠（顶部顺序） ```vb Dim Toast As New cToast Toast.Pos(RightTop).State(Info) Toast.Show "第一条消息", 0 ' 自动索引0（最上） Toast.Show "第二条消息", 0 ' 自动索引1 Toast.Show "第三条消息", 0 ' 自动索引2 Toast.Show "第四条消息", 0 ' 自动索引3 Toast.Show "第五条消息", 0 ' 自动索引4（最下） ``` ### 示例2：自动堆叠（底部倒序） ```vb Dim Toast As New cToast Toast.Pos(RightBottom).State(Warning) Toast.Show "第一条（最下）", 0 ' 自动索引0（最下） Toast.Show "第二条", 0 ' 自动索引1 Toast.Show "第三条", 0 ' 自动索引2 Toast.Show "第四条", 0 ' 自动索引3 Toast.Show "第五条（最上）", 0 ' 自动索引4（最上） ``` ### 示例3：手动指定堆叠位置 ```vb Dim Toast As New cToast ' 手动指定每个位置 Toast.Pos(RightTop).InstIndex(0).Show "第1条", 0 Toast.Pos(RightTop).InstIndex(1).Show "第2条", 0 Toast.Pos(RightTop).InstIndex(2).Show "第3条", 0 Toast.Pos(RightTop).InstIndex(3).Show "第4条", 0 ``` ### 示例4：混合状态堆叠 ```vb Dim Toast As New cToast Toast.Pos(CenterTop) Toast.State(Info).Show "信息提示", 0 ' 自动索引0 Toast.State(Success).Show "操作成功", 0 ' 自动索引1 Toast.State(Warning).Show "注意警告", 0 ' 自动索引2 Toast.State(Danger).Show "错误提示", 0 ' 自动索引3 Toast.State(Info).Show "再次提示", 0 ' 自动索引4 ``` *** ## 弹窗管理 ### 示例1：命名和单独关闭 ```vb Dim Toast As New cToast ' 显示多个弹窗并命名 Toast.Tag("msg1").Pos(RightTop).State(Success).Show "消息1", 0 Toast.Tag("msg2").Pos(RightTop).State(Warning).Show "消息2", 0 Toast.Tag("msg3").Pos(RightBottom).State(Danger).Show "消息3", 0 ' 单独关闭指定弹窗 Toast.CloseMe "msg1" ' 检查是否成功关闭 If Toast.Exists("msg1") Then Debug.Print "弹窗还存在" Else Debug.Print "弹窗已关闭" End If ``` ### 示例2：批量管理 ```vb Dim Toast As New cToast ' 显示多个弹窗 Toast.Pos(RightTop).State(Success).Show "成功1", 0 Toast.Pos(RightTop).State(Success).Show "成功2", 0 Toast.Pos(RightBottom).State(Warning).Show "警告1", 0 Toast.Pos(RightBottom).State(Warning).Show "警告2", 0 ' 查看当前数量 Debug.Print "当前弹窗数: " & Toast.Count ' 输出: 4 ' 关闭所有弹窗 Toast.CloseAll ' 再次查看数量 Debug.Print "当前弹窗数: " & Toast.Count ' 输出: 0 ``` ### 示例3：遍历所有弹窗 ```vb Dim Toast As New cToast Dim Keys As Collection Dim Key As Variant ' 显示一些弹窗 Toast.Tag("msg1").Pos(RightTop).Show "消息1", 0 Toast.Tag("msg2").Pos(RightTop).Show "消息2", 0 Toast.Tag("msg3").Pos(RightBottom).Show "消息3", 0 ' 获取所有弹窗名称 Set Keys = Toast.ActiveKeys ' 遍历并输出 For Each Key In Keys Debug.Print "活动弹窗: " & Key Next Key ' 输出： ' 活动弹窗: msg1 ' 活动弹窗: msg2 ' 活动弹窗: msg3 ``` *** ## 事件监听 ### 示例1：监听数量变化 ```vb Private WithEvents Toast As cToast Private Sub Form_Load() Set Toast = New cToast End Sub Private Sub btnShow_Click() Toast.Pos(RightTop).State(Info).Show "新消息", 0 End Sub Private Sub Toast_OnToastCountChange(ByVal TagName As String, ByVal IsDelete As Boolean, ByVal CurrentCount As Long) ' 更新UI显示 lblCount.Caption = "当前活动弹窗: " & CurrentCount ' 更新列表 RefreshList ' 记录日志 If IsDelete Then Debug.Print "弹窗 [" & TagName & "] 已关闭，剩余 " & CurrentCount & " 个" Else Debug.Print "弹窗 [" & TagName & "] 已创建，共 " & CurrentCount & " 个" End If End Sub ``` ### 示例2：监听批量关闭 ```vb Private WithEvents Toast As cToast Private Sub Form_Load() Set Toast = New cToast End Sub Private Sub btnCloseAll_Click() Toast.CloseAll End Sub Private Sub Toast_OnCloseAll(ByVal ClosedCount As Long) ' 批量关闭后刷新UI RefreshList ' 显示提示 If ClosedCount > 0 Then MsgBox "已关闭 " & ClosedCount & " 个弹窗", vbInformation Else MsgBox "没有活动弹窗", vbInformation End If End Sub ``` ### 示例3：完整的事件监听示例 ```vb Private WithEvents Toast As cToast Private Sub Form_Load() Set Toast = New cToast UpdateUI End Sub Private Sub btnAdd_Click() Toast.Tag("msg" & Toast.Count + 1).Pos(RightTop).State(Info).Show "新消息 " & Toast.Count + 1, 0 End Sub Private Sub btnCloseAll_Click() Toast.CloseAll End Sub Private Sub Toast_OnToastCountChange(ByVal TagName As String, ByVal IsDelete As Boolean, ByVal CurrentCount As Long) UpdateUI UpdateList End Sub Private Sub Toast_OnCloseAll(ByVal ClosedCount As Long) UpdateUI UpdateList If ClosedCount > 0 Then Debug.Print "批量关闭了 " & ClosedCount & " 个弹窗" End If End Sub Private Sub UpdateUI() lblCount.Caption = "当前弹窗: " & Toast.Count btnCloseAll.Enabled = (Toast.Count > 0) End Sub Private Sub UpdateList() Dim Keys As Collection Dim Key As Variant lstToasts.Clear Set Keys = Toast.ActiveKeys For Each Key In Keys lstToasts.AddItem CStr(Key) Next Key End Sub ``` *** ## 实际应用场景 ### 场景1：表单提交成功提示 ```vb Private Sub btnSave_Click() ' 保存数据 If SaveData() Then With New cToast .State(Success).Show "数据保存成功！", 2000, "成功" End With Else With New cToast .State(Danger).Show "保存失败，请重试", 3000, "错误" End With End If End Sub ``` ### 场景2：后台任务进度通知 ```vb Private Sub btnStartTask_Click() Dim taskId As Long ' 开始后台任务 taskId = StartBackgroundTask() ' 显示任务开始通知（持久显示） With New cToast .Tag("task" & taskId).Pos(RightTop).State(Info).Show "任务 " & taskId & " 开始执行", 0, "任务" End With ' ... 后续任务完成时 ... End Sub Private Sub OnTaskComplete(ByVal taskId As Long) ' 关闭任务通知 Dim Toast As New cToast Toast.CloseMe "task" & taskId ' 显示完成通知 With New cToast .State(Success).Show "任务 " & taskId & " 已完成", 3000, "完成" End With End Sub ``` ### 场景3：系统消息通知中心 ```vb Private WithEvents Toast As cToast Private notificationCount As Long Private Sub Form_Load() Set Toast = New cToast notificationCount = 0 End Sub Private Sub OnNewNotification(ByVal msg As String, ByVal level As EnumState) ' 增加计数 notificationCount = notificationCount + 1 ' 显示通知（右侧堆叠，持久显示） Toast.Tag("notif_" & notificationCount).Pos(RightTop).State(level).Show msg, 0, "通知" ' 更新图标 UpdateNotificationIcon notificationCount End Sub Private Sub btnClearNotifications_Click() Toast.CloseAll notificationCount = 0 UpdateNotificationIcon 0 End Sub Private Sub Toast_OnCloseAll(ByVal ClosedCount As Long) notificationCount = 0 UpdateNotificationIcon 0 End Sub ``` ### 场景4：操作日志实时显示 ```vb Private WithEvents Toast As cToast Private logCount As Long Private Sub Form_Load() Set Toast = New cToast logCount = 0 End Sub Private Sub AddLog(ByVal msg As String, ByVal level As EnumState) logCount = logCount + 1 ' 日志从右上开始堆叠，自动管理数量（最多显示10条） If logCount > 10 Then Toast.CloseMe "log_" & (logCount - 10) End If Toast.Tag("log_" & logCount).Pos(RightTop).State(level).Show msg, 5000, "日志" End Sub Private Sub btnTest_Click() AddLog "开始测试", Info AddLog "步骤1完成", Success AddLog "步骤2完成", Success AddLog "发现警告", Warning AddLog "测试完成", Info End Sub ``` ### 场景5：多状态操作反馈 ```vb Private Sub btnProcess_Click() Dim Toast As New cToast ' 步骤1：验证 Toast.Pos(RightTop).State(Info).Show "正在验证数据...", 0, "处理中" If ValidateData() Then Toast.CloseMe "验证提示" Toast.State(Success).Show "验证通过", 2000 ' 步骤2：处理 Toast.State(Info).Show "正在处理数据...", 0, "处理中" If ProcessData() Then Toast.CloseMe "处理提示" Toast.State(Success).Show "处理完成", 2000, "成功" Else Toast.CloseMe "处理提示" Toast.State(Danger).Show "处理失败", 3000, "错误" End If Else Toast.CloseMe "验证提示" Toast.State(Danger).Show "验证失败", 3000, "错误" End If End Sub ``` ### 场景6：网络状态监控 ```vb Private WithEvents Toast As cToast Private isOnline As Boolean Private Sub Form_Load() Set Toast = New cToast isOnline = True CheckNetworkStatus End Sub Private Sub Timer1_Timer() CheckNetworkStatus End Sub Private Sub CheckNetworkStatus() Dim currentStatus As Boolean currentStatus = PingServer() ' 状态变化时显示通知 If currentStatus <> isOnline Then isOnline = currentStatus If isOnline Then ' 网络恢复 Toast.Pos(Center).State(Success).Show "网络已恢复连接", 3000, "网络状态" Else ' 网络断开（持久显示） Toast.Tag("offline").Pos(Center).State(Danger).Show "网络连接已断开", 0, "网络状态" End If End If End Sub Private Sub OnNetworkReconnected() ' 关闭断网通知 Toast.CloseMe "offline" End Sub ``` ### 场景7：文件操作进度 ```vb Private WithEvents Toast As cToast Private Sub btnCopy_Click() Dim fileList As Collection Dim fileName As Variant Set fileList = GetSelectedFiles() ' 开始复制 Toast.Tag("copy_progress").Pos(RightBottom).State(Info).Show "开始复制 " & fileList.Count & " 个文件", 0, "复制" Dim i As Long i = 1 For Each fileName In fileList CopyFile fileName, "D:\Backup\" ' 更新进度 Toast.CloseMe "copy_progress" Toast.State(Info).Show "正在复制 (" & i & "/" & fileList.Count & ")...", 0, "复制" i = i + 1 Next fileName ' 完成 Toast.CloseMe "copy_progress" Toast.State(Success).Show "复制完成！共 " & fileList.Count & " 个文件", 3000, "完成" End Sub ``` ### 场景8：一键满屏演示 ```vb Private Sub Command1_Click() Dim Toast As New cToast ' Center 系列（使用 FToastCenter） Toast.Pos(Center).State(Info).Theme(Light).Tag("center_info").Show "居中覆盖", 0, "Center" Toast.Pos(CenterTop).State(Success).Tag("ctop_1").Show "居上第1条", 0, "CenterTop" Toast.Pos(CenterTop).State(Warning).Tag("ctop_2").Show "居上第2条", 0, "CenterTop" Toast.Pos(CenterBottom).State(Danger).Tag("cbottom_1").Show "居下第1条", 0, "CenterBottom" Toast.Pos(CenterBottom).State(Info).Tag("cbottom_2").Show "居下第2条", 0, "CenterBottom" ' Left 系列（使用 FToastDrawer） Toast.Pos(LeftTop).State(Success).Theme(Light).Tag("ltop_1").Show "左上堆叠", 0, "LeftTop" Toast.Pos(LeftTop).State(Warning).Tag("ltop_2").Show "左上堆叠", 0, "LeftTop" Toast.Pos(LeftBottom).State(Info).Tag("lbottom_1").Show "左下堆叠", 0, "LeftBottom" Toast.Pos(LeftCenter).State(Warning).Tag("lcenter").Show "左中覆盖", 0, "LeftCenter" ' Right 系列（使用 FToastDrawer） Toast.Pos(RightTop).State(Info).Theme(Light).Tag("rtop_1").Show "右上堆叠", 0, "RightTop" Toast.Pos(RightTop).State(Success).Tag("rtop_2").Show "右上堆叠", 0, "RightTop" Toast.Pos(RightBottom).State(Danger).Tag("rbottom_1").Show "右下堆叠", 0, "RightBottom" Toast.Pos(RightCenter).State(Success).Tag("rcenter").Show "右中覆盖", 0, "RightCenter" End Sub ``` *** ## 最佳实践 ### 1. 使用 With 语句简化代码 ```vb ' 推荐写法 With New cToast .Pos(RightTop).State(Success).Show "操作成功", 2000 End With ' 不推荐写法 Dim t As cToast Set t = New cToast t.Pos RightTop t.State Success t.Show "操作成功", 2000 ``` ### 2. 为持久显示的弹窗命名 ```vb ' 推荐写法 Toast.Tag("notification").Pos(RightBottom).Show "重要通知", 0 ' 不推荐写法（无法单独关闭） Toast.Pos(RightBottom).Show "重要通知", 0 ``` ### 3. 使用事件监听保持UI同步 ```vb ' 推荐写法 Private WithEvents Toast As cToast Private Sub Toast_OnToastCountChange(ByVal TagName As String, ByVal IsDelete As Boolean, ByVal CurrentCount As Long) lblCount.Caption = CurrentCount End Sub ' 不推荐写法（需要手动更新） Toast.Show "消息" lblCount.Caption = Toast.Count ``` ### 4. 合理选择显示位置 ```vb ' 临时提示使用右上角 Toast.Pos(RightTop).State(Success).Show "保存成功", 2000 ' 重要通知使用右下角（持久显示） Toast.Tag("important").Pos(RightBottom).State(Danger).Show "系统维护通知", 0 ' 关键信息使用居中 Toast.Pos(Center).State(Danger).Show "严重错误，请立即处理", 0 ``` ### 5. 合理设置显示时间 ```vb ' 快速反馈：1-2秒 Toast.State(Success).Show "操作成功", 1500 ' 普通提示：3-5秒 Toast.State(Info).Show "数据已更新", 3000 ' 警告提示：5-8秒 Toast.State(Warning).Show "请注意此操作的影响", 5000 ' 重要通知：持久显示 Toast.State(Danger).Show "服务器将在10分钟后重启", 0 ``` --- --- url: /zh/vbman/redis/transaction.md --- # 事务操作 Redis 事务可以一次执行多个命令，保证原子性。事务中的命令要么全部执行，要么全部不执行。 ## Multi - 开始事务 ```vb ' 开始事务 oRedis.Multi ``` ## Exec - 提交事务 ```vb ' 提交事务并获取执行结果 Dim vResults As Variant vResults = oRedis.Exec() If IsArray(vResults) Then Dim i As Long For i = 0 To UBound(vResults) Debug.Print vResults(i) Next End If ``` ## Discard - 取消事务 ```vb ' 取消事务 oRedis.Discard ``` ## 基本使用 ### 简单事务示例 ```vb Sub SimpleTransaction() Dim oRedis As New cRedisClient If Not oRedis.Connect() Then Debug.Print "连接失败: " & oRedis.LastError Exit Sub End If ' 开始事务 oRedis.Multi ' 执行多个命令（不会被立即执行） oRedis.Set_ "key1", "value1" oRedis.Set_ "key2", "value2" oRedis.Incr "counter" ' 提交事务 Dim vResults As Variant vResults = oRedis.Exec() Debug.Print "事务执行结果:" If IsArray(vResults) Then For i = 0 To UBound(vResults) Debug.Print " 操作 " & (i + 1) & " 结果: " & vResults(i) Next End If oRedis.DisConnect End Sub ``` ## 应用场景 ### 1. 原子性计数 ```vb Sub AtomicCounter() Dim oRedis As New cRedisClient If Not oRedis.Connect() Then Exit Sub ' 初始化计数器 oRedis.Set_ "counter", "0" Debug.Print "初始计数: " & oRedis.Get_("counter") ' 开始事务 oRedis.Multi ' 执行多个自增操作 oRedis.Incr "counter" oRedis.Incr "counter" oRedis.Incr "counter" ' 提交事务 Dim vResults As Variant vResults = oRedis.Exec() Debug.Print vbCrLf & "事务执行结果:" If IsArray(vResults) Then For i = 0 To UBound(vResults) Debug.Print " 操作 " & (i + 1) & " 结果: " & vResults(i) Next End If Debug.Print "最终计数: " & oRedis.Get_("counter") oRedis.DisConnect End Sub ``` ### 2. 银行转账 ```vb Sub BankTransfer() Dim oRedis As New cRedisClient If Not oRedis.Connect() Then Exit Sub ' 初始化账户余额 oRedis.Set_ "account:A", "1000" oRedis.Set_ "account:B", "500" Debug.Print "转账前:" Debug.Print " 账户A: " & oRedis.Get_("account:A") Debug.Print " 账户B: " & oRedis.Get_("account:B") Dim lAmount As Long lAmount = 200 ' 开始事务 oRedis.Multi ' 扣除 A 账户 oRedis.DecrBy "account:A", lAmount ' 增加 B 账户 oRedis.IncrBy "account:B", lAmount ' 提交事务 Dim vResults As Variant vResults = oRedis.Exec() Debug.Print vbCrLf & "转账后:" Debug.Print " 账户A: " & oRedis.Get_("account:A") Debug.Print " 账户B: " & oRedis.Get_("account:B") oRedis.DisConnect End Sub ``` ### 3. 批量更新 ```vb Sub BatchUpdate() Dim oRedis As New cRedisClient If Not oRedis.Connect() Then Exit Sub ' 开始事务 oRedis.Multi ' 批量设置多个键 oRedis.Set_ "user:1", "张三" oRedis.Set_ "user:2", "李四" oRedis.Set_ "user:3", "王五" oRedis.Set_ "user:4", "赵六" oRedis.Set_ "user:5", "钱七" ' 批量设置过期时间 oRedis.Expire "user:1", 3600 oRedis.Expire "user:2", 3600 oRedis.Expire "user:3", 3600 oRedis.Expire "user:4", 3600 oRedis.Expire "user:5", 3600 ' 提交事务 Dim vResults As Variant vResults = oRedis.Exec() Debug.Print "批量更新完成，共执行 " & (UBound(vResults) + 1) & " 个操作" oRedis.DisConnect End Sub ``` ### 4. 条件更新 ```vb Sub ConditionalUpdate() Dim oRedis As New cRedisClient If Not oRedis.Connect() Then Exit Sub ' 初始化库存 oRedis.Set_ "product:1001:stock", "10" Debug.Print "初始库存: " & oRedis.Get_("product:1001:stock") Dim lBuyAmount As Long lBuyAmount = 3 ' 检查库存是否足够 Dim lCurrentStock As Long lCurrentStock = CLng(oRedis.Get_("product:1001:stock")) If lCurrentStock >= lBuyAmount Then ' 库存充足，开始事务 oRedis.Multi ' 减少库存 oRedis.DecrBy "product:1001:stock", lBuyAmount ' 增加销量 oRedis.IncrBy "product:1001:sold", lBuyAmount ' 记录销售日志 oRedis.RPush "sales:log", "售出 " & lBuyAmount & " 件商品" ' 提交事务 Dim vResults As Variant vResults = oRedis.Exec() Debug.Print vbCrLf & "购买成功!" Debug.Print "剩余库存: " & oRedis.Get_("product:1001:stock") Debug.Print "累计销量: " & oRedis.Get_("product:1001:sold") Else Debug.Print "库存不足，无法购买" End If oRedis.DisConnect End Sub ``` ### 5. 数据一致性检查 ```vb Sub DataConsistency() Dim oRedis As New cRedisClient If Not oRedis.Connect() Then Exit Sub ' 初始化数据 oRedis.HSet "order:1001", "amount", "100" oRedis.HSet "order:1001", "status", "pending" oRedis.HSet "order:1001", "user", "user:123" oRedis.HSet "user:123", "balance", "500" ' 开始事务 oRedis.Multi ' 获取订单金额 oRedis.HGet "order:1001", "amount" ' 获取用户余额 oRedis.HGet "user:123", "balance" ' 执行事务获取数据 Dim vResults As Variant vResults = oRedis.Exec() ' 检查余额是否足够 If IsArray(vResults) And UBound(vResults) >= 1 Then Dim lOrderAmount As Long Dim lUserBalance As Long lOrderAmount = CLng(vResults(0)) lUserBalance = CLng(vResults(1)) If lUserBalance >= lOrderAmount Then ' 余额充足，执行支付 oRedis.Multi ' 扣除用户余额 oRedis.HSet "user:123", "balance", CStr(lUserBalance - lOrderAmount) ' 更新订单状态 oRedis.HSet "order:1001", "status", "paid" ' 记录支付日志 oRedis.RPush "payment:log", "订单 1001 支付 " & lOrderAmount ' 提交事务 vResults = oRedis.Exec() Debug.Print "支付成功" Debug.Print "剩余余额: " & oRedis.HGet("user:123", "balance") Debug.Print "订单状态: " & oRedis.HGet("order:1001", "status") Else Debug.Print "余额不足，支付失败" End If End If oRedis.DisConnect End Sub ``` ### 6. 事务取消 ```vb Sub CancelTransaction() Dim oRedis As New cRedisClient If Not oRedis.Connect() Then Exit Sub ' 初始化数据 oRedis.Set_ "counter", "10" Debug.Print "初始值: " & oRedis.Get_("counter") ' 开始事务 oRedis.Multi ' 执行多个操作 oRedis.Incr "counter" oRedis.Incr "counter" oRedis.Incr "counter" ' 取消事务 oRedis.Discard Debug.Print "事务取消后的值: " & oRedis.Get_("counter") oRedis.DisConnect End Sub ``` ## 事务特性 ### 1. 原子性 事务中的命令要么全部执行，要么全部不执行： ```vb Sub AtomicityExample() Dim oRedis As New cRedisClient If Not oRedis.Connect() Then Exit Sub oRedis.Multi ' 这些命令要么全部成功，要么全部失败 oRedis.Set_ "key1", "value1" oRedis.Set_ "key2", "value2" oRedis.Set_ "key3", "value3" oRedis.Exec oRedis.DisConnect End Sub ``` ### 2. 隔离性 事务执行期间，其他客户端看不到中间状态： ```vb Sub IsolationExample() Dim oRedis As New cRedisClient If Not oRedis.Connect() Then Exit Sub ' 设置初始值 oRedis.Set_ "balance", "100" ' 开始事务 oRedis.Multi ' 减少余额（此时其他客户端看到的仍然是 100） oRedis.Decr "balance" ' 在这里可以做一些其他操作... ' 提交事务（此时其他客户端才能看到变化） oRedis.Exec oRedis.DisConnect End Sub ``` ## 注意事项 1. **事务不回滚**：Redis 事务不支持回滚，即使某个命令失败，其他命令仍会执行 2. **错误处理**：需要在执行事务前验证参数 3. **性能考虑**：事务会阻塞其他操作，避免长时间运行的事务 4. **嵌套事务**：Redis 不支持嵌套事务 5. **乐观锁**：可以使用 `WATCH` 命令实现乐观锁（需要扩展实现） ## 完整示例 ```vb Sub Example_Transaction() Dim oRedis As New cRedisClient If Not oRedis.Connect() Then Debug.Print "连接失败: " & oRedis.LastError Exit Sub End If ' 初始化计数器 oRedis.Set_ "counter", "0" Debug.Print "初始计数: " & oRedis.Get_("counter") ' 开始事务 oRedis.Multi ' 执行多个自增操作 oRedis.Incr "counter" oRedis.Incr "counter" oRedis.Incr "counter" ' 提交事务 Dim vResults As Variant vResults = oRedis.Exec() Debug.Print "事务执行结果:" If IsArray(vResults) Then For i = 0 To UBound(vResults) Debug.Print " 操作 " & (i + 1) & " 结果: " & vResults(i) Next End If Debug.Print "最终计数: " & oRedis.Get_("counter") oRedis.DisConnect End Sub ``` ## 事务 vs 单条命令 | 场景 | 推荐方式 | 原因 | |------|---------|------| | 单个操作 | 单条命令 | 简单直接 | | 多个相关操作 | 事务 | 保证原子性 | | 不相关的操作 | 单条命令 | 减少阻塞 | | 需要中间结果 | 分步执行 | 更灵活 | | 批量更新 | 事务或批量命令 | 提高性能 | --- --- url: /zh/vbman/database/transaction.md --- # 事务处理 本文档详细介绍 cDataBase 类的事务处理功能，包括事务的开始、提交、回滚等。 *** ## ? 目录 * [事务概述](#事务概述) * [事务方法](#事务方法) * [基本使用](#基本使用) * [错误处理](#错误处理) * [嵌套事务](#嵌套事务) * [最佳实践](#最佳实践) *** ## 事务概述 ### 什么是事务 事务是一组数据库操作，要么全部成功，要么全部失败。事务具有以下特性（ACID）： * **原子性 (Atomicity)** - 事务中的所有操作要么全部执行，要么全部不执行 * **一致性 (Consistency)** - 事务执行前后数据库保持一致状态 * **隔离性 (Isolation)** - 并发事务之间相互隔离 * **持久性 (Durability)** - 事务提交后，数据永久保存 ### 事务状态 ``` 开始事务 ↓ 执行操作 1 ↓ 执行操作 2 ↓ 执行操作 3 ↓ 提交事务 ──→ 成功：所有操作生效 │ └──→ 失败：自动回滚，所有操作撤销 ``` *** ## 事务方法 ### TransBegin 方法 `TransBegin` 方法开始一个新事务。 #### 语法 ```vb Function TransBegin() As Boolean ``` #### 返回值 * `True` - 事务开始成功 * `False` - 事务开始失败（可通过 `LastErr` 查看错误信息） #### 示例 ```vb ' 开始事务 If db.TransBegin Then Debug.Print "事务已开始" Else Debug.Print "事务开始失败: " & db.LastErr End If ``` ### TransCommit 方法 `TransCommit` 方法提交事务。 #### 语法 ```vb Function TransCommit() As Boolean ``` #### 功能 * 提交所有事务中的操作 * 如果提交失败，自动回滚 * 清除事务标记 #### 返回值 * `True` - 提交成功 * `False` - 提交失败（已自动回滚） #### 示例 ```vb ' 提交事务 If db.TransCommit Then Debug.Print "事务提交成功" Else Debug.Print "事务提交失败，已自动回滚: " & db.LastErr End If ``` ### TransRollback 方法 `TransRollback` 方法回滚事务。 #### 语法 ```vb Function TransRollback() As Boolean ``` #### 功能 * 撤销所有事务中的操作 * 清除事务标记 #### 返回值 * `True` - 回滚成功 * `False` - 回滚失败（可通过 `LastErr` 查看错误信息） #### 示例 ```vb ' 回滚事务 If db.TransRollback Then Debug.Print "事务已回滚" Else Debug.Print "回滚失败: " & db.LastErr End If ``` *** ## 基本使用 ### 示例 1：简单事务 ```vb ' 开始事务 If db.TransBegin Then ' 执行操作 1 If db.Sql("INSERT INTO users (name) VALUES ('张三')").Exec Then ' 执行操作 2 If db.Sql("INSERT INTO posts (user_id, title) VALUES (1, '标题')").Exec Then ' 提交事务 If db.TransCommit Then Debug.Print "事务提交成功" Else Debug.Print "提交失败，已自动回滚" End If Else ' 操作 2 失败，回滚 db.TransRollback End If Else ' 操作 1 失败，回滚 db.TransRollback End If End If ``` ### 示例 2：使用错误处理 ```vb On Error GoTo ErrHandler ' 开始事务 If Not db.TransBegin Then Debug.Print "事务开始失败: " & db.LastErr Exit Sub End If ' 执行多个操作 db.Sql("INSERT INTO users (name) VALUES ('张三')").Exec db.Sql("INSERT INTO users (name) VALUES ('李四')").Exec db.Sql("UPDATE users SET status = 'active' WHERE name = '张三'").Exec ' 提交事务 If db.TransCommit Then Debug.Print "所有操作成功" Else Debug.Print "提交失败: " & db.LastErr End If Exit Sub ErrHandler: ' 发生错误，回滚事务 db.TransRollback Debug.Print "发生错误，事务已回滚: " & Err.Description ``` ### 示例 3：转账操作 ```vb ' 转账操作：从账户 A 转 100 元到账户 B Function TransferMoney(lFromAccount As Long, lToAccount As Long, dAmount As Double) As Boolean On Error GoTo ErrHandler ' 开始事务 If Not db.TransBegin Then TransferMoney = False Exit Function End If ' 从账户 A 扣除金额 Dim sSql As String sSql = "UPDATE accounts SET balance = balance - " & dAmount & _ " WHERE id = " & lFromAccount & " AND balance >= " & dAmount If Not db.Sql(sSql).Exec Then db.TransRollback TransferMoney = False Exit Function End If ' 检查是否有记录被更新 Dim lAffected As Long If db.Sql("SELECT @@ROWCOUNT").Query Then If db.Rs.EOF Or db.Rs(0) = 0 Then db.TransRollback TransferMoney = False Exit Function End If End If ' 向账户 B 增加金额 sSql = "UPDATE accounts SET balance = balance + " & dAmount & _ " WHERE id = " & lToAccount If Not db.Sql(sSql).Exec Then db.TransRollback TransferMoney = False Exit Function End If ' 记录转账日志 sSql = "INSERT INTO transfers (from_account, to_account, amount) VALUES (" & _ lFromAccount & ", " & lToAccount & ", " & dAmount & ")" If Not db.Sql(sSql).Exec Then db.TransRollback TransferMoney = False Exit Function End If ' 提交事务 If db.TransCommit Then TransferMoney = True Else TransferMoney = False End If Exit Function ErrHandler: db.TransRollback TransferMoney = False End Function ``` *** ## 错误处理 ### 自动回滚机制 类库提供了自动回滚机制： 1. **提交失败自动回滚** - `TransCommit` 失败时自动调用 `TransRollback` 2. **断开连接自动回滚** - `DisConnect` 时自动回滚未完成的事务 ```vb ' 提交失败时自动回滚 If db.TransBegin Then db.Sql("INSERT INTO users (name) VALUES ('张三')").Exec ' 如果提交失败，会自动回滚 If Not db.TransCommit Then Debug.Print "提交失败，已自动回滚: " & db.LastErr End If End If ``` ### 错误处理示例 ```vb Function ExecuteTransaction() As Boolean On Error GoTo ErrHandler ' 开始事务 If Not db.TransBegin Then Debug.Print "事务开始失败: " & db.LastErr ExecuteTransaction = False Exit Function End If ' 执行操作 If Not db.Sql("INSERT INTO users (name) VALUES ('张三')").Exec Then db.TransRollback Debug.Print "操作失败: " & db.LastErr ExecuteTransaction = False Exit Function End If ' 提交事务 If db.TransCommit Then ExecuteTransaction = True Else Debug.Print "提交失败: " & db.LastErr ExecuteTransaction = False End If Exit Function ErrHandler: ' 发生异常，回滚事务 db.TransRollback Debug.Print "异常发生，已回滚: " & Err.Description ExecuteTransaction = False End Function ``` *** ## 嵌套事务 ### 注意事项 ADO 支持嵌套事务，但需要注意： 1. **嵌套级别** - ADO 支持多级嵌套事务 2. **提交顺序** - 必须按相反顺序提交（内层先提交） 3. **回滚影响** - 回滚会影响所有嵌套级别 ### 嵌套事务示例 ```vb ' 外层事务 If db.TransBegin Then db.Sql("INSERT INTO users (name) VALUES ('用户1')").Exec ' 内层事务（嵌套） If db.TransBegin Then db.Sql("INSERT INTO posts (user_id, title) VALUES (1, '标题1')").Exec ' 提交内层事务 If db.TransCommit Then Debug.Print "内层事务提交成功" End If End If ' 提交外层事务 If db.TransCommit Then Debug.Print "外层事务提交成功" End If End If ``` *** ## 最佳实践 ### 1. 始终使用事务处理多个相关操作 ```vb ' ? 推荐：使用事务保证一致性 db.TransBegin db.Sql("INSERT INTO users (name) VALUES ('张三')").Exec db.Sql("INSERT INTO posts (user_id, title) VALUES (1, '标题')").Exec db.TransCommit ' ? 不推荐：不使用事务 db.Sql("INSERT INTO users (name) VALUES ('张三')").Exec db.Sql("INSERT INTO posts (user_id, title) VALUES (1, '标题')").Exec ' 如果第二个操作失败，第一个操作已经提交，数据不一致 ``` ### 2. 检查每个操作的返回值 ```vb ' ? 推荐：检查每个操作 db.TransBegin If Not db.Sql("INSERT INTO users (name) VALUES ('张三')").Exec Then db.TransRollback Exit Sub End If If Not db.Sql("INSERT INTO posts (user_id, title) VALUES (1, '标题')").Exec Then db.TransRollback Exit Sub End If db.TransCommit ``` ### 3. 使用错误处理 ```vb ' ? 推荐：使用错误处理 On Error GoTo ErrHandler db.TransBegin db.Sql("INSERT INTO users (name) VALUES ('张三')").Exec db.Sql("INSERT INTO posts (user_id, title) VALUES (1, '标题')").Exec db.TransCommit Exit Sub ErrHandler: db.TransRollback Debug.Print "错误: " & Err.Description ``` ### 4. 及时提交或回滚 ```vb ' ? 推荐：操作完成后立即提交或回滚 db.TransBegin ' ... 执行操作 ... db.TransCommit ' 或 db.TransRollback ' ? 不推荐：长时间保持事务打开 db.TransBegin ' ... 执行操作 ... ' 等待用户输入（事务保持打开状态） ' ... db.TransCommit ``` ### 5. 使用批量操作的事务 ```vb ' ? 推荐：批量操作使用事务 db.TransBegin Dim i As Long For i = 1 To 1000 If Not db.Sql("INSERT INTO users (name) VALUES ('用户" & i & "')").Exec Then db.TransRollback Exit For End If Next If i > 1000 Then db.TransCommit End If ``` *** ## 常见问题 ### Q1: 事务提交后数据没有保存？ **原因**: 可能是数据库不支持事务，或者连接字符串配置问题。 **解决**: * 检查数据库类型是否支持事务 * 验证连接字符串配置 ### Q2: 如何检查事务状态？ ```vb ' 注意：类库内部使用 IsTrans 标记，但不对外暴露 ' 可以通过尝试提交来检查 If db.TransCommit Then Debug.Print "有事务且提交成功" Else Debug.Print "没有事务或提交失败" End If ``` ### Q3: 事务会影响性能吗？ **回答**: 是的，事务会锁定资源，影响并发性能。 **建议**: * 尽量缩短事务时间 * 只包含必要的操作 * 避免在事务中进行长时间操作 *** **最后更新**: 2026-01-21 --- --- url: /zh/packages/vbccr/views/treeview.md description: 树视图控件（TreeView） - VBCCR 开发手册，基于源码的完整 API 参考 --- # 树视图控件（TreeView） 提供层次化数据的树形展示，支持节点展开/折叠、复选框、多选、图像列表、标签编辑、排序和OLE拖放。 ## 枚举 ### TvwStyleConstants 树视图样式常量。 | 常量 | 值 | 说明 | |------|-----|------| | TvwStyleTextOnly | 0 | 仅文本 | | TvwStylePictureText | 1 | 图像和文本 | | TvwStylePlusMinusText | 2 | 加减号和文本 | | TvwStylePlusMinusPictureText | 3 | 加减号、图像和文本 | | TvwStyleTreeLinesText | 4 | 树线和文本 | | TvwStyleTreeLinesPictureText | 5 | 树线、图像和文本 | | TvwStyleTreeLinesPlusMinusText | 6 | 树线、加减号和文本 | | TvwStyleTreeLinesPlusMinusPictureText | 7 | 树线、加减号、图像和文本 | ### TvwLineStyleConstants 线条样式常量。 | 常量 | 值 | 说明 | |------|-----|------| | TvwLineStyleTreeLines | 0 | 显示树线 | | TvwLineStyleRootLines | 1 | 显示根线（根节点之间也显示连线） | ### TvwLabelEditConstants 标签编辑模式常量。 | 常量 | 值 | 说明 | |------|-----|------| | TvwLabelEditAutomatic | 0 | 自动标签编辑（单击选中，再次单击编辑） | | TvwLabelEditManual | 1 | 手动标签编辑（需代码调用StartLabelEdit） | | TvwLabelEditDisabled | 2 | 禁用标签编辑 | ### TvwNodeRelationshipConstants 节点关系常量，用于Add方法和Move方法。 | 常量 | 值 | 说明 | |------|-----|------| | TvwNodeFirst | 0 | 第一个节点 | | TvwNodeLast | 1 | 最后一个节点 | | TvwNodeNext | 2 | 下一个节点（同级） | | TvwNodePrevious | 3 | 上一个节点（同级） | | TvwNodeChild | 4 | 子节点 | ### TvwSortOrderConstants 排序顺序常量。 | 常量 | 值 | 说明 | |------|-----|------| | TvwSortAscending | 0 | 升序排列 | | TvwSortDescending | 1 | 降序排列 | ### TvwSortTypeConstants 排序类型常量。 | 常量 | 值 | 说明 | |------|-----|------| | TvwSortBinary | 0 | 二进制排序（区分大小写） | | TvwSortText | 1 | 文本排序（不区分大小写） | ### TvwMultiSelectConstants 多选模式常量。 | 常量 | 值 | 说明 | |------|-----|------| | TvwMultiSelectNone | 0 | 不允许多选 | | TvwMultiSelectAll | 1 | 允许选择所有节点 | | TvwMultiSelectVisibleOnly | 2 | 仅允许选择可见节点 | | TvwMultiSelectRestrictSiblings | 3 | 仅允许选择同级节点 | ### TvwVisualThemeConstants 视觉主题常量。 | 常量 | 值 | 说明 | |------|-----|------| | TvwVisualThemeStandard | 0 | 标准主题 | | TvwVisualThemeExplorer | 1 | 资源管理器主题 | ## 属性 ### Name ```vb Public Property Get Name() As String ``` 返回在代码中标识对象的名称。 ### Tag ```vb Public Property Get Tag() As String Public Property Let Tag(ByVal Value As String) ``` 存储程序所需的额外数据。 ### Parent ```vb Public Property Get Parent() As Object ``` 返回对象所在的对象。 ### Container ```vb Public Property Get Container() As Object Public Property Set Container(ByVal Value As Object) ``` 返回/设置对象的容器。 ### Left ```vb Public Property Get Left() As Single Public Property Let Left(ByVal Value As Single) ``` 返回/设置对象与其容器左边缘的距离。 ### Top ```vb Public Property Get Top() As Single Public Property Let Top(ByVal Value As Single) ``` 返回/设置对象与其容器顶边缘的距离。 ### Width ```vb Public Property Get Width() As Single Public Property Let Width(ByVal Value As Single) ``` 返回/设置对象的宽度。 ### Height ```vb Public Property Get Height() As Single Public Property Let Height(ByVal Value As Single) ``` 返回/设置对象的高度。 ### Visible ```vb Public Property Get Visible() As Boolean Public Property Let Visible(ByVal Value As Boolean) ``` 返回/设置对象是否可见。 ### ToolTipText ```vb Public Property Get ToolTipText() As String Public Property Let ToolTipText(ByVal Value As String) ``` 返回/设置鼠标悬停时显示的提示文本。 ### HelpContextID ```vb Public Property Get HelpContextID() As Long Public Property Let HelpContextID(ByVal Value As Long) ``` 返回/设置帮助上下文ID。 ### WhatsThisHelpID ```vb Public Property Get WhatsThisHelpID() As Long Public Property Let WhatsThisHelpID(ByVal Value As Long) ``` 返回/设置关联的上下文帮助ID。 ### Align ```vb Public Property Get Align() As Integer Public Property Let Align(ByVal Value As Integer) ``` 返回/设置控件在其窗体上的对齐方式。 ### DragIcon ```vb Public Property Get DragIcon() As IPictureDisp Public Property Let DragIcon(ByVal Value As IPictureDisp) Public Property Set DragIcon(ByVal Value As IPictureDisp) ``` 返回/设置拖放操作中显示的图标。 ### DragMode ```vb Public Property Get DragMode() As Integer Public Property Let DragMode(ByVal Value As Integer) ``` 返回/设置拖动模式。 ### hWnd ```vb Public Property Get hWnd() As LongPtr ``` 返回控件句柄。 ### hWndUserControl ```vb Public Property Get hWndUserControl() As LongPtr ``` 返回UserControl句柄。 ### hWndLabelEdit ```vb Public Property Get hWndLabelEdit() As LongPtr ``` 返回标签编辑框句柄。 ### Font ```vb Public Property Get Font() As StdFont Public Property Let Font(ByVal NewFont As StdFont) Public Property Set Font(ByVal NewFont As StdFont) ``` 返回/设置字体。 ### VisualStyles ```vb Public Property Get VisualStyles() As Boolean Public Property Let VisualStyles(ByVal Value As Boolean) ``` 返回/设置是否启用视觉样式。需要comctl32.dll 6.0或更高版本。 ### VisualTheme ```vb Public Property Get VisualTheme() As TvwVisualThemeConstants Public Property Let VisualTheme(ByVal Value As TvwVisualThemeConstants) ``` 返回/设置视觉主题。 ### Enabled ```vb Public Property Get Enabled() As Boolean Public Property Let Enabled(ByVal Value As Boolean) ``` 返回/设置对象是否能响应用户事件。 ### OLEDragMode ```vb Public Property Get OLEDragMode() As VBRUN.OLEDragConstants Public Property Let OLEDragMode(ByVal Value As VBRUN.OLEDragConstants) ``` 返回/设置OLE拖拽模式。 ### OLEDragDropScroll ```vb Public Property Get OLEDragDropScroll() As Boolean Public Property Let OLEDragDropScroll(ByVal Value As Boolean) ``` 返回/设置OLE拖放时是否自动滚动。 ### OLEDragExpandTime ```vb Public Property Get OLEDragExpandTime() As Long Public Property Let OLEDragExpandTime(ByVal Value As Long) ``` 返回/设置OLE拖放时悬停多久后展开节点（毫秒）。 ### OLEDropMode ```vb Public Property Get OLEDropMode() As OLEDropModeConstants Public Property Let OLEDropMode(ByVal Value As OLEDropModeConstants) ``` 返回/设置对象是否可以作为OLE放置目标。 ### MousePointer ```vb Public Property Get MousePointer() As CCMousePointerConstants Public Property Let MousePointer(ByVal Value As CCMousePointerConstants) ``` 返回/设置鼠标悬停时显示的指针类型。参见通用枚举。 ### MouseIcon ```vb Public Property Get MouseIcon() As IPictureDisp Public Property Let MouseIcon(ByVal Value As IPictureDisp) Public Property Set MouseIcon(ByVal Value As IPictureDisp) ``` 返回/设置自定义鼠标图标。 ### MouseTrack ```vb Public Property Get MouseTrack() As Boolean Public Property Let MouseTrack(ByVal Value As Boolean) ``` 返回/设置是否在鼠标进入或离开控件时触发事件。 ### RightToLeft ```vb Public Property Get RightToLeft() As Boolean Public Property Let RightToLeft(ByVal Value As Boolean) ``` 返回/设置从右到左显示方向。 ### RightToLeftLayout ```vb Public Property Get RightToLeftLayout() As Boolean Public Property Let RightToLeftLayout(ByVal Value As Boolean) ``` 返回/设置从右到左布局。 ### RightToLeftMode ```vb Public Property Get RightToLeftMode() As CCRightToLeftModeConstants Public Property Let RightToLeftMode(ByVal Value As CCRightToLeftModeConstants) ``` 返回/设置从右到左模式。参见通用枚举。 ### ImageList ```vb Public Property Get ImageList() As Variant Public Property Let ImageList(ByVal Value As Variant) Public Property Set ImageList(ByVal Value As Variant) ``` 返回/设置关联的ImageList控件。可以是对象引用、字符串键名或LongPtr句柄。 ### BorderStyle ```vb Public Property Get BorderStyle() As CCBorderStyleConstants Public Property Let BorderStyle(ByVal Value As CCBorderStyleConstants) ``` 返回/设置边框样式。参见通用枚举。 ### BackColor ```vb Public Property Get BackColor() As OLE_COLOR Public Property Let BackColor(ByVal Value As OLE_COLOR) ``` 返回/设置背景色。 ### ForeColor ```vb Public Property Get ForeColor() As OLE_COLOR Public Property Let ForeColor(ByVal Value As OLE_COLOR) ``` 返回/设置前景色。 ### Redraw ```vb Public Property Get Redraw() As Boolean Public Property Let Redraw(ByVal Value As Boolean) ``` 返回/设置是否重绘。禁用后可加速大量操作。 ### Style ```vb Public Property Get Style() As TvwStyleConstants Public Property Let Style(ByVal Value As TvwStyleConstants) ``` 返回/设置树视图样式。 ### LineStyle ```vb Public Property Get LineStyle() As TvwLineStyleConstants Public Property Let LineStyle(ByVal Value As TvwLineStyleConstants) ``` 返回/设置线条样式。 ### LineColor ```vb Public Property Get LineColor() As OLE_COLOR Public Property Let LineColor(ByVal Value As OLE_COLOR) ``` 返回/设置线条颜色。 ### LabelEdit ```vb Public Property Get LabelEdit() As TvwLabelEditConstants Public Property Let LabelEdit(ByVal Value As TvwLabelEditConstants) ``` 返回/设置标签编辑模式。 ### Checkboxes ```vb Public Property Get Checkboxes() As Boolean Public Property Let Checkboxes(ByVal Value As Boolean) ``` 返回/设置是否在节点旁显示复选框。 ### ShowTips ```vb Public Property Get ShowTips() As Boolean Public Property Let ShowTips(ByVal Value As Boolean) ``` 返回/设置是否显示工具提示。 ### HideSelection ```vb Public Property Get HideSelection() As Boolean Public Property Let HideSelection(ByVal Value As Boolean) ``` 返回/设置失去焦点时是否隐藏选中项高亮。 ### FullRowSelect ```vb Public Property Get FullRowSelect() As Boolean Public Property Let FullRowSelect(ByVal Value As Boolean) ``` 返回/设置是否整行选择。 ### HotTracking ```vb Public Property Get HotTracking() As Boolean Public Property Let HotTracking(ByVal Value As Boolean) ``` 返回/设置是否启用热点跟踪。 ### Indentation ```vb Public Property Get Indentation() As Single Public Property Let Indentation(ByVal Value As Single) ``` 返回/设置子节点缩进量。 ### PathSeparator ```vb Public Property Get PathSeparator() As String Public Property Let PathSeparator(ByVal Value As String) ``` 返回/设置FullPath属性使用的路径分隔符。 ### Scroll ```vb Public Property Get Scroll() As Boolean Public Property Let Scroll(ByVal Value As Boolean) ``` 返回/设置是否显示滚动条。 ### SingleSel ```vb Public Property Get SingleSel() As Boolean Public Property Let SingleSel(ByVal Value As Boolean) ``` 返回/设置单击节点是否展开并折叠其他节点。 ### Sorted ```vb Public Property Get Sorted() As Boolean Public Property Let Sorted(ByVal Value As Boolean) ``` 返回/设置是否对根节点排序。 ### SortOrder ```vb Public Property Get SortOrder() As TvwSortOrderConstants Public Property Let SortOrder(ByVal Value As TvwSortOrderConstants) ``` 返回/设置排序顺序。 ### SortType ```vb Public Property Get SortType() As TvwSortTypeConstants Public Property Let SortType(ByVal Value As TvwSortTypeConstants) ``` 返回/设置排序类型。 ### InsertMarkColor ```vb Public Property Get InsertMarkColor() As OLE_COLOR Public Property Let InsertMarkColor(ByVal Value As OLE_COLOR) ``` 返回/设置插入标记颜色。 ### DoubleBuffer ```vb Public Property Get DoubleBuffer() As Boolean Public Property Let DoubleBuffer(ByVal Value As Boolean) ``` 返回/设置是否启用双缓冲绘制。 ### IMEMode ```vb Public Property Get IMEMode() As CCIMEModeConstants Public Property Let IMEMode(ByVal Value As CCIMEModeConstants) ``` 返回/设置输入法模式。参见通用枚举。 ### MultiSelect ```vb Public Property Get MultiSelect() As TvwMultiSelectConstants Public Property Let MultiSelect(ByVal Value As TvwMultiSelectConstants) ``` 返回/设置多选模式。 ### Nodes ```vb Public Property Get Nodes() As TvwNodes ``` 返回节点集合。 ## 方法 ### OLEDrag ```vb Public Sub OLEDrag() ``` 启动OLE拖放操作。 ### Drag ```vb Public Sub Drag(Optional ByRef Action As Variant) ``` 开始、结束或取消拖动操作。 ### SetFocus ```vb Public Sub SetFocus() ``` 将焦点移到指定对象。 ### ZOrder ```vb Public Sub ZOrder(Optional ByRef Position As Variant) ``` 设置Z顺序。 ### Refresh ```vb Public Sub Refresh() ``` 强制完全重绘对象。 ## 事件 ### Click ```vb Public Event Click() ``` 用户单击控件时触发。 ### DblClick ```vb Public Event DblClick() ``` 用户双击控件时触发。 ### NodeClick ```vb Public Event NodeClick(ByVal Node As TvwNode, ByVal Button As Integer) ``` 用户单击节点时触发。Button指示鼠标按钮。 ### NodeDblClick ```vb Public Event NodeDblClick(ByVal Node As TvwNode, ByVal Button As Integer) ``` 用户双击节点时触发。 ### NodeBeforeCheck ```vb Public Event NodeBeforeCheck(ByVal Node As TvwNode, ByRef Cancel As Boolean) ``` 节点复选框即将改变时触发。设置Cancel为True可取消操作。 ### NodeCheck ```vb Public Event NodeCheck(ByVal Node As TvwNode) ``` 节点复选框状态改变后触发。 ### NodeDrag ```vb Public Event NodeDrag(ByVal Node As TvwNode, ByVal Button As Integer) ``` 用户拖动节点时触发。 ### NodeBeforeSelect ```vb Public Event NodeBeforeSelect(ByVal Node As TvwNode, ByRef Cancel As Boolean) ``` 节点即将被选中时触发。设置Cancel为True可取消选择。 ### NodeSelect ```vb Public Event NodeSelect(ByVal Node As TvwNode) ``` 节点被选中后触发。 ### NodeRangeSelect ```vb Public Event NodeRangeSelect(ByVal Node As TvwNode, ByRef Cancel As Boolean) ``` 范围选择时触发。设置Cancel为True可取消。 ### BeforeCollapse ```vb Public Event BeforeCollapse(ByVal Node As TvwNode, ByRef Cancel As Boolean) ``` 节点即将折叠时触发。设置Cancel为True可取消折叠。 ### Collapse ```vb Public Event Collapse(ByVal Node As TvwNode) ``` 节点折叠后触发。 ### BeforeExpand ```vb Public Event BeforeExpand(ByVal Node As TvwNode, ByRef Cancel As Boolean) ``` 节点即将展开时触发。设置Cancel为True可取消展开。 ### Expand ```vb Public Event Expand(ByVal Node As TvwNode) ``` 节点展开后触发。 ### BeforeLabelEdit ```vb Public Event BeforeLabelEdit(ByRef Cancel As Boolean) ``` 标签即将编辑时触发。设置Cancel为True可取消编辑。 ### AfterLabelEdit ```vb Public Event AfterLabelEdit(ByRef Cancel As Boolean, ByRef NewString As String) ``` 标签编辑完成后触发。设置Cancel为True可取消修改，NewString为编辑后的文本。 ### PreviewKeyDown ```vb Public Event PreviewKeyDown(ByVal KeyCode As Integer, ByRef IsInputKey As Boolean) ``` 按键预览事件。设置IsInputKey为True可将按键标记为输入键。 ### PreviewKeyUp ```vb Public Event PreviewKeyUp(ByVal KeyCode As Integer, ByRef IsInputKey As Boolean) ``` 按键释放预览事件。 ### KeyDown ```vb Public Event KeyDown(KeyCode As Integer, Shift As Integer) ``` 按下键盘键时触发。 ### KeyUp ```vb Public Event KeyUp(KeyCode As Integer, Shift As Integer) ``` 释放键盘键时触发。 ### KeyPress ```vb Public Event KeyPress(KeyChar As Integer) ``` 按下并释放ANSI键时触发。 ### MouseDown ```vb Public Event MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` 按下鼠标按钮时触发。 ### MouseMove ```vb Public Event MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` 移动鼠标时触发。 ### MouseUp ```vb Public Event MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` 释放鼠标按钮时触发。 ### MouseEnter ```vb Public Event MouseEnter() ``` 鼠标进入控件区域时触发。 ### MouseLeave ```vb Public Event MouseLeave() ``` 鼠标离开控件区域时触发。 ### OLECompleteDrag ```vb Public Event OLECompleteDrag(Effect As Long) ``` OLE拖放操作完成时触发。 ### OLEDragDrop ```vb Public Event OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single) ``` OLE拖放操作放置时触发。 ### OLEDragOver ```vb Public Event OLEDragOver(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single, State As Integer) ``` OLE拖放操作悬停时触发。 ### OLEGiveFeedback ```vb Public Event OLEGiveFeedback(Effect As Long, DefaultCursors As Boolean) ``` OLE拖放操作给反馈时触发。 ### OLESetData ```vb Public Event OLESetData(Data As DataObject, DataFormat As Integer) ``` OLE拖放操作设置数据时触发。 ### OLEStartDrag ```vb Public Event OLEStartDrag(Data As DataObject, AllowedEffects As Long) ``` OLE拖放操作开始时触发。 ## 子对象 ### TvwNode 类 树视图节点对象。 #### TvwNode 属性 ##### Index ```vb Public Property Get Index() As Long ``` 节点在集合中的索引。 ##### Key ```vb Public Property Get Key() As String Public Property Let Key(ByVal Value As String) ``` 唯一标识键。 ##### Tag ```vb Public Property Get Tag() As Variant Public Property Let Tag(ByVal Value As Variant) ``` 额外数据。 ##### Handle ```vb Public Property Get Handle() As LongPtr ``` 节点句柄。 ##### Text ```vb Public Property Get Text() As String Public Property Let Text(ByVal Value As String) ``` 节点文本。 ##### ToolTipText ```vb Public Property Get ToolTipText() As String Public Property Let ToolTipText(ByVal Value As String) ``` 工具提示文本。 ##### BackColor ```vb Public Property Get BackColor() As OLE_COLOR Public Property Let BackColor(ByVal Value As OLE_COLOR) ``` 背景色。 ##### ForeColor ```vb Public Property Get ForeColor() As OLE_COLOR Public Property Let ForeColor(ByVal Value As OLE_COLOR) ``` 前景色。 ##### Image ```vb Public Property Get Image() As Variant Public Property Let Image(ByVal Value As Variant) ``` 节点图像。 ##### ImageIndex ```vb Public Property Get ImageIndex() As Long ``` 图像索引。 ##### SelectedImage ```vb Public Property Get SelectedImage() As Variant Public Property Let SelectedImage(ByVal Value As Variant) ``` 选中状态的图像。 ##### SelectedImageIndex ```vb Public Property Get SelectedImageIndex() As Long ``` 选中图像索引。 ##### ExpandedImage ```vb Public Property Get ExpandedImage() As Variant Public Property Let ExpandedImage(ByVal Value As Variant) ``` 展开状态的图像。 ##### ExpandedImageIndex ```vb Public Property Get ExpandedImageIndex() As Long ``` 展开图像索引。 ##### NoImages ```vb Public Property Get NoImages() As Boolean Public Property Let NoImages(ByVal Value As Boolean) ``` 是否不显示图像。 ##### Selected ```vb Public Property Get Selected() As Boolean Public Property Let Selected(ByVal Value As Boolean) ``` 是否选中。 ##### CheckBox ```vb Public Property Get CheckBox() As Boolean Public Property Let CheckBox(ByVal Value As Boolean) ``` 是否显示复选框。 ##### Checked ```vb Public Property Get Checked() As Boolean Public Property Let Checked(ByVal Value As Boolean) ``` 是否勾选。 ##### Bold ```vb Public Property Get Bold() As Boolean Public Property Let Bold(ByVal Value As Boolean) ``` 是否粗体。 ##### Ghosted ```vb Public Property Get Ghosted() As Boolean Public Property Let Ghosted(ByVal Value As Boolean) ``` 是否灰显。 ##### Expanded ```vb Public Property Get Expanded() As Boolean Public Property Let Expanded(ByVal Value As Boolean) ``` 是否展开。 ##### Enabled ```vb Public Property Get Enabled() As Boolean Public Property Let Enabled(ByVal Value As Boolean) ``` 是否可用。 ##### Sorted ```vb Public Property Get Sorted() As Boolean Public Property Let Sorted(ByVal Value As Boolean) ``` 是否对子节点排序。 ##### SortOrder ```vb Public Property Get SortOrder() As TvwSortOrderConstants Public Property Let SortOrder(ByVal Value As TvwSortOrderConstants) ``` 排序顺序。 ##### SortType ```vb Public Property Get SortType() As TvwSortTypeConstants Public Property Let SortType(ByVal Value As TvwSortTypeConstants) ``` 排序类型。 ##### Children ```vb Public Property Get Children() As Long ``` 子节点数量。 ##### Child ```vb Public Property Get Child() As TvwNode ``` 第一个子节点。 ##### Level ```vb Public Property Get Level() As Long ``` 节点层级（根节点为0）。 ##### Parent ```vb Public Property Get Parent() As TvwNode Public Property Set Parent(ByVal Value As TvwNode) ``` 父节点。 ##### Root ```vb Public Property Get Root() As TvwNode ``` 根节点。 ##### NextSibling ```vb Public Property Get NextSibling() As TvwNode ``` 下一个兄弟节点。 ##### PreviousSibling ```vb Public Property Get PreviousSibling() As TvwNode ``` 上一个兄弟节点。 ##### FirstSibling ```vb Public Property Get FirstSibling() As TvwNode ``` 第一个兄弟节点。 ##### LastSibling ```vb Public Property Get LastSibling() As TvwNode ``` 最后一个兄弟节点。 ##### FirstVisibleSibling ```vb Public Property Get FirstVisibleSibling() As TvwNode ``` 第一个可见兄弟节点。 ##### LastVisibleSibling ```vb Public Property Get LastVisibleSibling() As TvwNode ``` 最后一个可见兄弟节点。 ##### NextVisibleSibling ```vb Public Property Get NextVisibleSibling() As TvwNode ``` 下一个可见兄弟节点。 ##### PreviousVisibleSibling ```vb Public Property Get PreviousVisibleSibling() As TvwNode ``` 上一个可见兄弟节点。 ##### FullPath ```vb Public Property Get FullPath() As String ``` 从根到当前节点的完整路径。 ##### Visible ```vb Public Property Get Visible() As Boolean ``` 节点是否可见。 #### TvwNode 方法 ##### Move ```vb Public Sub Move(ByVal Relative As Variant, ByVal Relationship As TvwNodeRelationshipConstants) ``` 移动节点到新位置。 ##### EnsureVisible ```vb Public Sub EnsureVisible() ``` 确保节点可见（展开父节点并滚动到视图中）。 ##### CreateDragImage ```vb Public Function CreateDragImage() As LongPtr ``` 创建节点拖动图像，返回图像列表句柄。 ##### SelectedIndex ```vb Public Function SelectedIndex() As Long ``` 返回选中项索引。 ### TvwNodes 类 树视图节点集合。 #### TvwNodes 成员 ##### NewEnum ```vb Public Function NewEnum() As IUnknown ``` 枚举器（隐藏）。 ##### Add ```vb Public Function Add(Optional ByVal Relative As Variant, Optional ByVal Relationship As Variant, Optional ByVal Key As Variant, Optional ByVal Text As Variant, Optional ByVal Image As Variant, Optional ByVal SelectedImage As Variant) As TvwNode ``` 添加节点。 ##### Item ```vb Public Function Item(ByVal Index As Variant) As TvwNode ``` 获取节点（默认成员）。 ##### Exists ```vb Public Function Exists(ByVal Index As Variant) As Boolean ``` 检查节点是否存在。 ##### Count ```vb Public Property Get Count() As Long ``` 节点数量。 ##### Clear ```vb Public Sub Clear() ``` 清除所有节点。 ##### Remove ```vb Public Sub Remove(ByVal Index As Variant) ``` 移除节点。 ### TvwSelectedNodes 类 选中节点集合（多选模式）。 #### TvwSelectedNodes 成员 ##### NewEnum ```vb Public Function NewEnum() As IUnknown ``` 枚举器（隐藏）。 ##### Item ```vb Public Function Item(ByVal Index As Long) As TvwNode ``` 获取选中节点（默认成员）。 ##### Exists ```vb Public Function Exists(ByVal Index As Long) As Boolean ``` 检查选中节点是否存在。 ##### Count ```vb Public Property Get Count() As Long ``` 选中节点数量。 ## 代码示例 ### 基本用法 ```vb ' 添加树节点 Dim root As TvwNode Set root = TreeView1.Nodes.Add(, , "root", "根节点", 1) root.Expanded = True TreeView1.Nodes.Add "root", TvwNodeChild, "child1", "子节点1", 2 TreeView1.Nodes.Add "root", TvwNodeChild, "child2", "子节点2", 2 ' 处理节点点击 Private Sub TreeView1_NodeClick(ByVal Node As TvwNode, ByVal Button As Integer) MsgBox "点击: " & Node.Text End Sub ' 控制节点展开 Private Sub TreeView1_BeforeExpand(ByVal Node As TvwNode, ByRef Cancel As Boolean) If Node.Children = 0 Then Cancel = True End If End Sub ' 节点选中变化 Private Sub TreeView1_NodeSelect(ByVal Node As TvwNode) Debug.Print "选中: " & Node.FullPath End Sub ``` --- --- url: /zh/vbman2/webview2/bindui.md --- # 数据绑定专题 - BindUI / BindData / SetData ## 📖 目录 * [概述](#概述) * [架构原理](#架构原理) * [BindUI - 事件绑定](#bindui---事件绑定) * [BindData - 数据绑定](#binddata---数据绑定) * [SetData - 数据推送](#setdata---数据推送) * [导航后自动重建](#导航后自动重建) * [完整示例](#完整示例) * [常见问题](#常见问题) *** ## 概述 cWebView2Host 的数据绑定系统是一种**声明式**的 VB6-Web 双向通信机制，无需手动编写 JSON 消息解析、DOM 操作或事件监听胶水代码。 ### ✨ 核心特点 * 🔗 **双向绑定** - BindUI (UI->宿主) + BindData (宿主->UI) 覆盖双向通信 * 📝 **声明式** - 用一行绑定声明替代大量胶水代码 * 🔄 **自动重建** - 页面导航后自动重新注入绑定逻辑 * 🎯 **CSS 选择器** - 使用标准 CSS 选择器定位 DOM 元素 * 📦 **批量操作** - SetDataBatch 一次推送多个数据 *** ## 架构原理 ### 系统组成 ``` cWebView2Host.BindUI() / BindData() / SetData() │ ▼ WebView2BindUIProxy (COM 对象，暴露为 JS 全局对象 bindUIProxy) │ ├── BindUI: JS addEventListener → bindUIProxy.onEvent(bindId, eventName, detail) │ └── CallByName(HostInst, MethodName, vbMethod, EventName, Detail) │ ├── BindData: SetData → JS 循环遍历绑定列表 → element[attr] = value │ └── 导航重建: DOMContentLoaded → 注入重新绑定 JS → 恢复所有 BindUI + BindData + DataValue ``` ### 工作流程 ``` 1. VB6 调用 BindUI/BindData → 注册绑定到 WebView2BindUIProxy 内部集合 2. GetJsCode() → 从嵌入资源加载 ProxyBindUI.js / ProxyMouseEvents.js 3. GetBindAddJs() → 生成 addEventListener 的 JS 代码 4. ExecuteScript() → 在 WebView2 中注入并执行绑定代码 5. DOM 事件触发 → JS 调用 bindUIProxy.onEvent() → CallByName → VB6 方法回调 6. SetData 调用 → 生成 JS 代码 → 遍历绑定列表 → 更新 DOM 属性 ``` *** ## BindUI - 事件绑定 ### 基本用法 ```vb ' 将 #submit-btn 的 click 事件绑定到 Me.OnButtonClick wv.BindUI Me, "OnButtonClick", "#submit-btn" ``` 声明后，当用户在 WebView2 中点击 `#submit-btn` 元素时，VB6 自动调用 `OnButtonClick` 方法。 ### 宿主方法签名 所有 BindUI 回调方法必须遵循以下签名： ```vb Public Sub OnButtonClick(ByVal EventName As String, ByVal Detail As String) ' EventName: 触发的 DOM 事件名（如 "click", "input", "change"） ' Detail: JSON 格式的事件详情 End Sub ``` ### Detail 参数解析 Detail 是 JSON 字符串，内容取决于 DOM 事件类型。常见事件的 Detail 结构： | 事件 | Detail 示例 | |------|-------------| | click | `{"type":"click","target":"#btn"}` | | input | `{"type":"input","value":"用户输入的文本"}` | | change | `{"type":"change","value":"新值","checked":true}` | 由于 VB6 没有内置 JSON 解析，通常使用简单的字符串处理： ```vb Public Sub OnNameInput(ByVal EventName As String, ByVal Detail As String) ' 简单提取 value 字段 Dim val As String val = JsonValue(Detail, "value") wv.SetData "name", val End Sub ' 简易 JSON 值提取辅助函数 Private Function JsonValue(ByVal Json As String, ByVal Key As String) As String Dim pos As Long pos = InStr(Json, """" & Key & """:""") If pos > 0 Then pos = pos + Len(Key) + 3 Dim endPos As Long endPos = InStr(pos, Json, """") If endPos > 0 Then JsonValue = Mid(Json, pos, endPos - pos) End If End If End Function ``` ### 自定义事件名 默认绑定 click 事件，可通过 EventName 参数指定其他事件： ```vb ' 绑定 input 事件（实时响应文本输入） wv.BindUI Me, "OnNameInput", "#name-input", EventName:="input" ' 绑定 change 事件（选择框、复选框值变化） wv.BindUI Me, "OnToggle", "#toggle-enabled", EventName:="change" ' 绑定 submit 事件 wv.BindUI Me, "OnFormSubmit", "#my-form", EventName:="submit" ``` ### 多元素绑定 ```vb ' 多个按钮绑定到不同方法 wv.BindUI Me, "OnSave", "#btn-save" wv.BindUI Me, "OnCancel", "#btn-cancel" wv.BindUI Me, "OnReset", "#btn-reset" ' 同一元素的不同事件绑定到不同方法 wv.BindUI Me, "OnFocus", "#input", EventName:="focus" wv.BindUI Me, "OnBlur", "#input", EventName:="blur" ``` ### 移除绑定 ```vb ' 移除指定元素的所有事件绑定 wv.UnbindUI "#submit-btn" ' 仅移除指定元素的特定事件绑定 wv.UnbindUI "#name-input", "input" ``` *** ## BindData - 数据绑定 ### 原理 BindData 将一个**数据键名**绑定到**DOM 元素**的**特定属性**。当 `SetData` 更新该键名时，所有绑定了该键名的 DOM 元素属性会自动更新。 ### 支持的 DOM 属性 | 属性 | 说明 | 示例 | |------|------|------| | `textContent` | 元素文本内容（默认） | 标签、段落 | | `value` | 表单元素值 | input、textarea、select | | `innerHTML` | 元素内部 HTML | 动态渲染 HTML 片段 | | `src` | 资源来源 | img、video、iframe | | `class` | CSS 类名 | 状态样式切换 | | `checked` | 选中状态 | checkbox、radio | | `visible` | 显示/隐藏（自定义） | 任意元素 | | 其他属性 | 直接设置 DOM 属性 | href, disabled, style 等 | ### 基本用法 ```vb ' 绑定数据键到元素属性 wv.BindData "name", "#name-input", "value" wv.BindData "message", "#msg-display", "textContent" ' 同一键绑定到多个元素/属性 wv.BindData "name", "#name-input", "value" wv.BindData "name", "#name-preview", "textContent" ' 同一数据，不同属性 ' 绑定到特殊属性 wv.BindData "enabled", "#toggle", "checked" ' checkbox wv.BindData "enabled", "#panel", "visible" ' 显示/隐藏 wv.BindData "avatar", "#avatar-img", "src" ' 图片地址 wv.BindData "status", "#status-dot", "class" ' CSS 类名 wv.BindData "items", "#list", "innerHTML" ' HTML 片段 ``` ### visible 属性 `visible` 是 cWebView2Host 自定义的虚拟属性，控制 DOM 元素的显示/隐藏： ```vb wv.BindData "showPanel", "#settings-panel", "visible" ' 当 showPanel = True 时，JS 设置 element.style.display = '' ' 当 showPanel = False 时，JS 设置 element.style.display = 'none' ``` ### class 属性 `class` 属性替换元素的全部 CSS 类名： ```vb wv.BindData "statusOnline", "#status-dot", "class" wv.SetData "statusOnline", "dot online" ' 绿色在线状态 wv.SetData "statusOnline", "dot offline" ' 灰色离线状态 ``` *** ## SetData - 数据推送 ### SetData 推送单个数据值。支持 String、Boolean、Number 类型： ```vb wv.SetData "name", "张伟" ' 字符串 wv.SetData "enabled", True ' 布尔值 wv.SetData "count", 42 ' 数值 wv.SetData "avatar", "https://example.com/a.png" ' URL 字符串 ``` **类型转换规则**: * VB6 `String` → JS 字符串（自动加引号） * VB6 `Boolean` → JS boolean（true/false） * VB6 数值类型 → JS number（直接传递） ### SetDataBatch 批量推送多个数据值，参数为 JSON 对象字符串： ```vb wv.SetDataBatch "{""name"":""张伟"",""enabled"":true,""count"":42}" ``` 适用于页面初始化时一次性推送所有数据。 *** ## 导航后自动重建 当 WebView2 导航到新页面时，之前注入的 JavaScript 绑定代码会被销毁。cWebView2Host 自动处理此问题： ### 重建机制 1. 每次导航导致 DOMContentLoaded 后，自动触发重建 2. `GetReattachJs()` 生成重建所有绑定的 JS 代码 3. 重建包括：BindUI 事件监听 + BindData 声明 + DataValue 当前值 ### DataValue 持久化 `SetData` 推送的值会自动存储在 `m_DataValues` 集合中。页面导航后，自动将这些值重新应用到 DOM： ```vb ' 首次导航 wv.SetData "name", "张伟" ' 用户点击链接导航到新页面 ' → DOMContentLoaded 触发自动重建 ' → "name" 键的值 "张伟" 自动重新应用 ``` *** ## 完整示例 以下示例展示 BindUI/BindData/SetData 的完整协作： ### VB6 代码 ```vb Dim WithEvents wv As cWebView2Host Private Sub Form_Load() Set wv = New cWebView2Host wv.Initialize Me.hWnd, App.Path & "\www" End Sub Private Sub wv_Ready() ' === 宿主 -> UI 数据绑定 === wv.BindData "name", "#name-input", "value" wv.BindData "name", "#name-preview", "textContent" wv.BindData "enabled", "#toggle-enabled", "checked" wv.BindData "enabled", "#settings-panel", "visible" wv.BindData "avatar", "#avatar", "src" wv.BindData "count", "#msg-count", "textContent" wv.BindData "statusOnline", "#status-dot", "class" ' === UI -> 宿主 事件绑定 === wv.BindUI Me, "OnNameInput", "#name-input", EventName:="input" wv.BindUI Me, "OnToggle", "#toggle-enabled", EventName:="change" wv.BindUI Me, "OnIncMsg", "#btn-inc" wv.BindUI Me, "OnResetMsg", "#btn-reset" ' === 推送初始数据 === wv.SetData "name", "张伟" wv.SetData "enabled", True wv.SetData "count", 0 Me.Caption = wv.DocumentTitle End Sub ' === UI 回调方法 === Public Sub OnNameInput(ByVal EventName As String, ByVal Detail As String) Dim val As String val = JsonValue(Detail, "value") wv.SetData "name", val ' 回推到 UI End Sub Public Sub OnToggle(ByVal EventName As String, ByVal Detail As String) ' Detail 示例: {"type":"change","checked":true} Dim checked As Boolean checked = (InStr(Detail, """checked"":true") > 0) wv.SetData "enabled", checked End Sub Public Sub OnIncMsg(ByVal EventName As String, ByVal Detail As String) Dim count As Long count = Val(wv.JsProp("document.querySelector('#msg-count').textContent")) wv.SetData "count", count + 1 End Sub Public Sub OnResetMsg(ByVal EventName As String, ByVal Detail As String) wv.SetData "count", 0 End Sub ``` ### HTML 页面 ```html

    Hello, -!

    Settings content here

    0 messages
    ``` *** ## 常见问题 ### ❓ Q1: BindUI 回调没有被触发？ **现象**: 绑定了事件但 VB6 方法没有被调用。 **原因**: 1. 宿主方法必须声明为 `Public`（不能用 Private） 2. 宿主方法签名必须完全匹配 `(ByVal EventName As String, ByVal Detail As String)` 3. 绑定必须在 `wv_Ready` 事件或之后执行，不能在 `Form_Load` 中 **解决方案**: ```vb ' 正确 Public Sub OnClick(ByVal EventName As String, ByVal Detail As String) ' 错误 Private Sub OnClick(ByVal EventName As String, ByVal Detail As String) ' 不能是 Private Public Sub OnClick() ' 参数签名不匹配 ``` *** ### ❓ Q2: BindData 设置 class 属性时原有样式丢失？ **现象**: 使用 `BindData "key", "#element", "class"` 后元素原有的 CSS 类被覆盖。 **原因**: `class` 属性直接替换元素的全部 className，不是追加。 **解决方案**: 将完整的类名组合后 SetData： ```vb wv.SetData "statusClass", "card " & IIf(isActive, "active", "inactive") ``` *** ### ❓ Q3: 页面导航后绑定失效？ **现象**: 点击链接导航到新页面后，绑定不再工作。 **原因**: cWebView2Host 在 DOMContentLoaded 时自动重建绑定，但如果新页面的 DOM 结构不同（选择器匹配不到元素），绑定将静默失败。 **解决方案**: 1. 确保所有页面的 DOM ID/选择器一致 2. 或在导航后重新执行绑定 *** ### ❓ Q4: SetData 如何传递复杂对象？ **现象**: 需要将数组或对象传给 JS。 **原因**: SetData 的 Value 是 Variant，内部转换为 JS 字面量。复杂类型需要序列化为 JSON 字符串并使用 innerHTML 或自定义 JS 处理。 **解决方案**: ```vb ' 方式1：使用 innerHTML 渲染列表 wv.BindData "items", "#item-list", "innerHTML" wv.SetData "items", "
  • Item 1
  • Item 2
    • " ' 方式2：直接调用 JS 函数处理 JSON wv.JsRun "renderItems(" & jsonString & ")" ``` *** **最后更新**: 2026-06-24 --- --- url: /zh/vbman/httpserver/database.md --- # 数据库集成 ## 简介 HttpServer 内置 `cDataBase` 集成，可在控制器中直接访问数据库。 ## 配置数据库 ```vb Private Sub Form_Load() Set Server = New cHttpServer ' 方式1：启动前配置 If Server.Database.Connect(enumDbType.Mysql, "localhost,3306", "root", "password", "mydb") Then Debug.Print "数据库连接成功" End If ' 方式2：使用连接字符串（高级） ' Server.Database.ConnectionString = "..." Call Server.Start(8080, "C:\WebRoot") End Sub ``` ## 在控制器中使用数据库 ### 基础查询 ```vb ' cUserController.cls ' GET /api/users Public Sub List(ctx As cHttpServerContext) Dim sql As String sql = "SELECT id, username, email FROM users LIMIT 100" If ctx.Db.Sql(sql).Fetch Then ctx.Response.Json ctx.Db.Rows, 0, "Success", ctx.Db.Rows.Count Else ctx.Response.State500 "查询失败: " & ctx.Db.LastErr End If End Sub ' GET /api/user?id=123 Public Sub Detail(ctx As cHttpServerContext) Dim id As String id = ctx.Request.QueryString("id") ' 参数化查询防止 SQL 注入 If ctx.Db.Sql("SELECT * FROM users WHERE id=?") _ .Param("id", id, adVarChar) _ .Fetch Then If ctx.Db.Rows.Count > 0 Then ctx.Response.Json ctx.Db.Rows(1) Else ctx.Response.State404 "用户不存在" End If Else ctx.Response.State500 "查询失败" End If End Sub ``` ### 分页查询 ```vb ' GET /api/users?page=1&limit=20 Public Sub ListPaged(ctx As cHttpServerContext) Dim page As Long, limit As Long page = CLng(ctx.Request.QueryString("page")) limit = CLng(ctx.Request.QueryString("limit")) If page < 1 Then page = 1 If limit < 1 Or limit > 100 Then limit = 20 Dim offset As Long offset = (page - 1) * limit ' 查询总数 Dim total As Long total = ctx.Db.Count("users") ' 分页查询 Dim sql As String sql = "SELECT id, username, email FROM users LIMIT " & limit & " OFFSET " & offset If ctx.Db.Sql(sql).Fetch Then Dim result As New Dictionary result("items") = ctx.Db.Rows result("total") = total result("page") = page result("limit") = limit ctx.Response.Json result, 0, "Success", total Else ctx.Response.State500 "查询失败" End If End Sub ``` ### 插入数据 ```vb ' POST /api/users Public Sub Create(ctx As cHttpServerContext) Dim username As String, email As String username = ctx.Request.Form("username") email = ctx.Request.Form("email") ' 参数化插入 Dim sql As String sql = "INSERT INTO users (username, email, created_at) VALUES (?, ?, NOW())" If ctx.Db.Sql(sql) _ .Param("username", username, adVarChar) _ .Param("email", email, adVarChar) _ .ExecParam Then Dim newId As Long newId = ctx.Db.LastInsertId Dim result As New Dictionary result("id") = newId result("username") = username ctx.Response.Json result, 0, "创建成功" Else ctx.Response.State500 "创建失败: " & ctx.Db.LastErr End If End Sub ``` ### 事务处理 ```vb ' POST /api/transfer Public Sub Transfer(ctx As cHttpServerContext) Dim fromUser As String, toUser As String Dim amount As Currency fromUser = ctx.Request.Form("from") toUser = ctx.Request.Form("to") amount = CCur(ctx.Request.Form("amount")) ' 开启事务 If Not ctx.Db.TransBegin Then ctx.Response.State500 "事务开启失败" Exit Sub End If On Error GoTo Rollback ' 扣款 If Not ctx.Db.Sql("UPDATE accounts SET balance = balance - ? WHERE user_id = ?") _ .Param("amount", amount, adCurrency) _ .Param("user_id", fromUser, adVarChar) _ .ExecParam Then GoTo Rollback End If ' 入账 If Not ctx.Db.Sql("UPDATE accounts SET balance = balance + ? WHERE user_id = ?") _ .Param("amount", amount, adCurrency) _ .Param("user_id", toUser, adVarChar) _ .ExecParam Then GoTo Rollback End If ' 记录日志 If Not ctx.Db.Sql("INSERT INTO transactions (from_user, to_user, amount) VALUES (?, ?, ?)") _ .Param("from", fromUser, adVarChar) _ .Param("to", toUser, adVarChar) _ .Param("amount", amount, adCurrency) _ .ExecParam Then GoTo Rollback End If ' 提交事务 If ctx.Db.TransCommit Then ctx.Response.Json Nothing, 0, "转账成功" Else GoTo Rollback End If Exit Sub Rollback: ctx.Db.TransRollback ctx.Response.State500 "转账失败: " & ctx.Db.LastErr End Sub ``` ### 关联查询 ```vb ' GET /api/orders?user_id=123 Public Sub GetOrders(ctx As cHttpServerContext) Dim userId As String userId = ctx.Request.QueryString("user_id") Dim sql As String sql = "SELECT o.id, o.total, u.username, u.email " & _ "FROM orders o " & _ "JOIN users u ON o.user_id = u.id " & _ "WHERE o.user_id = ? " & _ "ORDER BY o.created_at DESC" If ctx.Db.Sql(sql) _ .Param("user_id", userId, adVarChar) _ .Fetch Then ctx.Response.Json ctx.Db.Rows, 0, "Success" Else ctx.Response.State500 "查询失败" End If End Sub ``` ## 数据模型封装 ```vb ' cUserModel.cls Option Explicit Private Db As cDataBase Public Sub Init(database As cDataBase) Set Db = database End Sub ' 根据ID查询 Public Function FindById(id As String) As Dictionary If Db.Sql("SELECT * FROM users WHERE id=?") _ .Param("id", id, adVarChar) _ .Fetch Then If Db.Rows.Count > 0 Then Set FindById = Db.Rows(1) End If End If End Function ' 根据用户名查询 Public Function FindByUsername(username As String) As Dictionary If Db.Sql("SELECT * FROM users WHERE username=?") _ .Param("username", username, adVarChar) _ .Fetch Then If Db.Rows.Count > 0 Then Set FindByUsername = Db.Rows(1) End If End If End Function ' 创建用户 Public Function Create(data As Dictionary) As Long If Db.Sql("INSERT INTO users (username, email, password) VALUES (?, ?, ?)") _ .Param("username", data("username"), adVarChar) _ .Param("email", data("email"), adVarChar) _ .Param("password", data("password"), adVarChar) _ .ExecParam Then Create = Db.LastInsertId End If End Function ' 更新用户 Public Function Update(id As String, data As Dictionary) As Boolean Dim fields As String Dim first As Boolean: first = True Dim key As Variant For Each key In data.Keys If Not first Then fields = fields & ", " fields = fields & key & "=?" first = False Next Dim sql As String sql = "UPDATE users SET " & fields & " WHERE id=?" Dim q As Object Set q = Db.Sql(sql) For Each key In data.Keys q.Param CStr(key), data(key), adVarChar Next q.Param "id", id, adVarChar Update = q.ExecParam End Function ' 删除用户 Public Function Delete(id As String) As Boolean Delete = Db.Sql("DELETE FROM users WHERE id=?") _ .Param("id", id, adVarChar) _ .ExecParam End Function ``` ## 控制器中使用模型 ```vb ' cUserController.cls Dim UserModel As cUserModel Private Sub Class_Initialize() Set UserModel = New cUserModel End Sub Public Sub Detail(ctx As cHttpServerContext) Call UserModel.Init(ctx.Db) Dim id As String id = ctx.Request.QueryString("id") Dim user As Dictionary Set user = UserModel.FindById(id) If Not user Is Nothing Then ctx.Response.Json user Else ctx.Response.State404 "用户不存在" End If End Sub Public Sub Create(ctx As cHttpServerContext) Call UserModel.Init(ctx.Db) Dim data As New Dictionary data("username") = ctx.Request.Form("username") data("email") = ctx.Request.Form("email") data("password") = HashPassword(ctx.Request.Form("password")) Dim newId As Long newId = UserModel.Create(data) If newId > 0 Then ctx.Response.Json newId, 0, "创建成功" Else ctx.Response.State500 "创建失败" End If End Sub ``` *** **最后更新**: 2026-05-17 --- --- url: /zh/vbman/database.md --- # 数据库类库开发文档 > ? **cDataBase 类库** - 基于 ADO 封装的 VB6 数据库操作类，由 215879458@qq.com 开发 ## ? 目录 * [概述](#概述) * [核心亮点](#核心亮点) * [架构设计](#架构设计) * [文档索引](#文档索引) *** ## 概述 cDataBase 类库是一个为 VB6 设计的轻量级数据库操作封装类，完全基于 ADO (ActiveX Data Objects) 实现，提供了简洁易用的 API 和完整的功能支持。 ### ? 主要特性 * ? **多数据库支持** - 支持 Access、MySQL、SQL Server、CSV、Custom（自定义 DSN）等多种数据库 * ? **连接池管理** - 支持多数据库连接实例池，动态管理数据库对象 * ? **链式查询构建器** - 类 ORM 链式 API，支持 Where/OrderBy/GroupBy/Join/Limit/Page 等，零手写 SQL * ? **分页查询** - 内置分页功能，基于 ADO 原生分页属性，支持所有数据库类型 * ? **参数化查询** - 支持参数化查询，有效防止 SQL 注入攻击 * ? **事务处理** - 完整的事务支持，自动回滚机制 * ? **异步执行** - 支持异步 SQL 执行，提升性能 * ? **结果集转换** - 自动将 Recordset 转换为 cCollection 合（Dictionary 嵌套） * ?? **工具方法** - 丰富的工具方法，简化常用操作 *** ## 核心亮点 ### 1?? 简洁的 API 设计 ? 类库采用链式调用设计，代码简洁易读： ```vb ' 在 VB6 项目中引用 VBMAN.dll 后使用 Dim db As New VBMAN.cDataBase ' 连接数据库 db.Connect VBMAN.enumDbType_MsSql, "127.0.0.1,1433", "sa", "password", "mydb" ' 查询数据（链式调用） db.Sql("SELECT * FROM users WHERE id > ?").Param("id", 100).QueryParam ' 获取结果 Dim i As Long For i = 1 To db.Rows.Count Debug.Print db.Rows(i)("name") Next ``` *** ### 2?? 多数据库类型支持 ? ```vb ' SQL Server db.Connect VBMAN.enumDbType_MsSql, "127.0.0.1,1433", "sa", "pwd", "master" ' MySQL db.Connect VBMAN.enumDbType_Mysql, "localhost:3306", "root", "pwd", "testdb" ' Access db.Connect VBMAN.enumDbType_Access, "C:\data\mydb.mdb" ' CSV db.Connect VBMAN.enumDbType_Csv, "C:\data\csvfiles" ' Custom（自定义连接字符串） db.Connect VBMAN.enumDbType_Custom, "DRIVER={MySQL ODBC 8.0 ANSI Driver};SERVER=localhost;DATABASE=testdb;UID=root;PWD=root" ``` *** ### 3?? 分页查询支持 ? ```vb ' 第 2 页，每页 10 条 db.Sql("SELECT * FROM users").Page(2, 10).Query ' 自动转换为对应数据库的分页 SQL ' SQL Server: OFFSET 10 ROWS FETCH NEXT 10 ROWS ONLY ' MySQL: LIMIT 10 OFFSET 10 ``` *** ### 4?? 参数化查询（防 SQL 注入） ? ```vb ' 使用参数化查询，安全可靠 db.Sql("SELECT * FROM users WHERE name = ? AND age > ?") _ .Param("name", "张三", adVarChar) _ .Param("age", 18, adInteger) _ .QueryParam ``` *** ### 5?? 事务处理 ? ```vb ' 开始事务 db.TransBegin ' 执行多个操作 db.Sql("INSERT INTO users (name) VALUES ('user1')").Exec db.Sql("INSERT INTO users (name) VALUES ('user2')").Exec ' 提交事务（失败自动回滚） If db.TransCommit Then Debug.Print "事务提交成功" End If ``` *** ### 6?? 结果集自动转换 ? ```vb ' 查询后自动转换为 Dictionary 集合 db.Sql("SELECT * FROM users").Fetch ' 访问第一行数据 Debug.Print db.Row("name") Debug.Print db.Row("age") ' 遍历所有行 Dim i As Long For i = 1 To db.Rows.Count Debug.Print db.Rows(i)("name") Next ``` *** ### 7?? 连接池管理 ? ```vb ' 创建连接实例 Dim db1 As VBMAN.cDataBase Set db1 = db.ConnInst("db1") ' 使用独立的连接实例 db1.Sql("SELECT * FROM table1").Query ' 移除连接实例 db.ConnInstRemove "db1" ``` *** ## 架构设计 ### 类层次结构 ``` cDataBase (数据库操作类) ├── Connection (ADODB.Connection) - 数据库连接 ├── Recordset (ADODB.Recordset) - 记录集 ├── Command (ADODB.Command) - 参数化查询命令 ├── Rows (cCollection) - 查询结果集（Dictionary 嵌套） ├── Row (Dictionary) - 当前行数据 ├── DatabaseType (enumDbType) - 当前数据库类型 ├── IsCloneInstance (Boolean) - 是否为连接池克隆实例 └── Connections (Dictionary) - 连接池 ``` ### 对象关系图 ``` 数据库对象 (cDataBase) ├── 主连接 (Conn) │ ├── Recordset (Rs) │ └── Command (Cmd) - 参数化查询 └── 连接池 (Connections) ├── 连接实例 1 (cDataBase) │ └── 独立连接 ├── 连接实例 2 (cDataBase) │ └── 独立连接 └── ... ``` ### 数据流程 #### 查询流程 ``` 1. Sql("SELECT ...") - 设置 SQL 语句 2. Page(1, 10) - 可选：设置分页 3. Query() - 执行查询 4. Rs - 获取 Recordset 5. Rows - 自动转换为 Dictionary 集合 ``` #### 链式构建器流程 ``` 1. Table("表名") - 设置操作表（起始方法） 2. Where/WhereIn/OrderBy/GroupBy/Join/Limit/Page - 链式叠加条件 3. RowRead/RowCreate/RowUpdate/RowDelete/RowCount/RowExists - 终结方法 4. Rs - 获取 Recordset（RowRead 后） 5. Rows - 自动转换为 Dictionary 集合（配合 RowRead + Fetch） ``` #### 执行流程 ``` 1. Sql("INSERT/UPDATE/DELETE ...") - 设置 SQL 语句 2. Param("name", value) - 可选：添加参数 3. Exec() / ExecParam() - 执行操作 4. LastInsertId() - 可选：获取最后插入的 ID ``` #### 参数化查询 + Fetch 流程 ``` 1. Sql("SELECT ... WHERE id = ?") - 设置 SQL 语句 2. Param("id", value, type) - 添加参数 3. FetchParam() - 执行参数化查询 + 自动转换为 Rows/Row ``` *** ## 文档索引 | 文档 | 描述 | | ---------------------------------------------------------- | ---------------------------------------------- | | [快速入门](./quickstart.md) | 快速上手指南 | | [连接管理](./connection.md) | 数据库连接和连接池管理 | | [链式 CURD - 概述](./chain-curd.md) | 链式查询构建器概述与速查表 | | [链式 CURD - 条件方法](./chain-curd-where.md) | Where/OrWhere/WhereIn/WhereLike 等 | | [链式 CURD - 排序分组连接选择](./chain-curd-modifiers.md) | OrderBy/GroupBy/Having/Join/Columns/Distinct | | [链式 CURD - 限制与分页](./chain-curd-limit-page.md) | Limit/Offset/Page | | [链式 CURD - 终结方法](./chain-curd-terminal.md) | RowCreate/RowRead/RowUpdate/RowDelete/Field | | [链式 CURD - 聚合终结方法](./chain-curd-aggregate.md) | RowCount/RowExists/RowPluck/RowMax/Min/Sum/Avg | | [链式 CURD - 综合示例与最佳实践](./chain-curd-examples.md) | SQL对比、FAQ、最佳实践 | | [查询操作](./query.md) | SELECT 查询的详细说明 | | [执行操作](./execute.md) | INSERT、UPDATE、DELETE 操作 | | [事务处理](./transaction.md) | 事务的完整使用指南 | | [分页功能](./pagination.md) | 分页查询的详细说明 | | [参数化查询](./parameterized.md) | 参数化查询和 SQL 注入防护 | | [工具方法](./utilities.md) | 常用工具方法说明 | | [高级功能](./advanced.md) | 高级功能和最佳实践 | *** ## 依赖关系 | 组件 | 描述 | | ---------------------------------------------- | ----------------------------- | | **Microsoft ActiveX Data Objects 2.8 Library** | ADO 核心库，必须引用 | | **Microsoft Scripting Runtime** | Dictionary 对象支持 | | **cCollection** | Rows 结果集类型（VBMAN 内部） | | **ToolsList.bas** | Recordset 转 cCollection 工具 | | **ToolsFso.bas** | 文件路径处理工具 | *** ## 兼容性 * **VB6/VBA** - 完全兼容 * **Windows** - Windows XP 及以上版本 * **数据库** - Access、MySQL、SQL Server、CSV、Custom（自定义 DSN） * **ADO 版本** - ADO 2.8 及以上 *** ## 许可 基于 VBMAN 项目开发 *** ## 作者 **数据库类库**: 215879458@qq.com *** **最后更新**: 2026-01-21 --- --- url: /zh/emoji/2200-22FF.md --- # 数学运算符 (Mathematical Operators) 本页面展示了Unicode字符集中，位于U+2200到U+22FF范围的数学运算符号。这些符号用于数学公式和表达式中。 | 字符 | Unicode | VB函数值 | 名称 | |:---:|:---:|:---:|:---| | ∀ | U+2200 | ChrW(\&H2200) | 全称量词 | | ∁ | U+2201 | ChrW(\&H2201) | 补集 | | ∂ | U+2202 | ChrW(\&H2202) | 偏微分 | | ∃ | U+2203 | ChrW(\&H2203) | 存在量词 | | ∄ | U+2204 | ChrW(\&H2204) | 不存在 | | ∅ | U+2205 | ChrW(\&H2205) | 空集 | | ∆ | U+2206 | ChrW(\&H2206) | 增量 | | ∇ | U+2207 | ChrW(\&H2207) | 劈形算符 | | ∈ | U+2208 | ChrW(\&H2208) | 属于 | | ∉ | U+2209 | ChrW(\&H2209) | 不属于 | | ∊ | U+220A | ChrW(\&H220A) | 小属于 | | ∋ | U+220B | ChrW(\&H220B) | 包含 | | ∌ | U+220C | ChrW(\&H220C) | 不包含 | | ∍ | U+220D | ChrW(\&H220D) | 小包含 | | ∎ | U+220E | ChrW(\&H220E) | 证明结束 | | ∏ | U+220F | ChrW(\&H220F) | 求积 | | ∐ | U+2210 | ChrW(\&H2210) | 余积 | | ∑ | U+2211 | ChrW(\&H2211) | 求和 | | − | U+2212 | ChrW(\&H2212) | 减号 | | ∓ | U+2213 | ChrW(\&H2213) | 负正号 | | ∔ | U+2214 | ChrW(\&H2214) | 点加 | | ∕ | U+2215 | ChrW(\&H2215) | 除号 | | ∖ | U+2216 | ChrW(\&H2216) | 集合差 | | ∗ | U+2217 | ChrW(\&H2217) | 星号运算符 | | ∘ | U+2218 | ChrW(\&H2218) | 环运算符 | | ∙ | U+2219 | ChrW(\&H2219) | 点运算符 | | √ | U+221A | ChrW(\&H221A) | 平方根 | | ∛ | U+221B | ChrW(\&H221B) | 立方根 | | ∜ | U+221C | ChrW(\&H221C) | 四次方根 | | ∝ | U+221D | ChrW(\&H221D) | 正比于 | | ∞ | U+221E | ChrW(\&H221E) | 无穷大 | | ∟ | U+221F | ChrW(\&H221F) | 直角 | | ∠ | U+2220 | ChrW(\&H2220) | 角 | | ∡ | U+2221 | ChrW(\&H2221) | 测量角 | | ∢ | U+2222 | ChrW(\&H2222) | 球面角 | | ∣ | U+2223 | ChrW(\&H2223) | 整除 | | ∤ | U+2224 | ChrW(\&H2224) | 不整除 | | ∥ | U+2225 | ChrW(\&H2225) | 平行于 | | ∦ | U+2226 | ChrW(\&H2226) | 不平行于 | | ∧ | U+2227 | ChrW(\&H2227) | 逻辑与 | | ∨ | U+2228 | ChrW(\&H2228) | 逻辑或 | | ∩ | U+2229 | ChrW(\&H2229) | 交集 | | ∪ | U+222A | ChrW(\&H222A) | 并集 | | ∫ | U+222B | ChrW(\&H222B) | 积分 | | ∬ | U+222C | ChrW(\&H222C) | 双重积分 | | ∭ | U+222D | ChrW(\&H222D) | 三重积分 | | ∮ | U+222E | ChrW(\&H222E) | 线积分 | | ∯ | U+222F | ChrW(\&H222F) | 曲面积分 | | ∰ | U+2230 | ChrW(\&H2230) | 体积积分 | | ∱ | U+2231 | ChrW(\&H2231) | 顺时针积分 | | ∲ | U+2232 | ChrW(\&H2232) | 顺时针线积分 | | ∳ | U+2233 | ChrW(\&H2233) | 逆时针线积分 | | ∴ | U+2234 | ChrW(\&H2234) | 所以 | | ∵ | U+2235 | ChrW(\&H2235) | 因为 | | ∶ | U+2236 | ChrW(\&H2236) | 比 | | ∷ | U+2237 | ChrW(\&H2237) | 比例 | | ∸ | U+2238 | ChrW(\&H2238) | 点减 | | ∹ | U+2239 | ChrW(\&H2239) | 取余 | | ∺ | U+223A | ChrW(\&H223A) | 几何比例 | | ∻ | U+223B | ChrW(\&H223B) | 同源 | | ∼ | U+223C | ChrW(\&H223C) | 波浪号运算符 | | ∽ | U+223D | ChrW(\&H223D) | 反波浪号 | | ∾ | U+223E | ChrW(\&H223E) | 倒S形积分 | | ∿ | U+223F | ChrW(\&H223F) | 正弦波 | | ≀ | U+2240 | ChrW(\&H2240) | 纹积 | | ≁ | U+2241 | ChrW(\&H2241) | 不波浪号 | | ≂ | U+2242 | ChrW(\&H2242) | 负号波浪号 | | ≃ | U+2243 | ChrW(\&H2243) | 渐近等于 | | ≄ | U+2244 | ChrW(\&H2244) | 不渐近等于 | | ≅ | U+2245 | ChrW(\&H2245) | 约等于 | | ≆ | U+2246 | ChrW(\&H2246) | 约等于或不等于 | | ≇ | U+2247 | ChrW(\&H2247) | 既不约等于也不等于 | | ≈ | U+2248 | ChrW(\&H2248) | 几乎等于 | | ≉ | U+2249 | ChrW(\&H2249) | 不几乎等于 | | ≊ | U+224A | ChrW(\&H224A) | 几乎等于或等于 | | ≋ | U+224B | ChrW(\&H224B) | 三重波浪号 | | ≌ | U+224C | ChrW(\&H224C) | 全等于 | | ≍ | U+224D | ChrW(\&H224D) | 等价于 | | ≎ | U+224E | ChrW(\&H224E) | 几何等价于 | | ≏ | U+224F | ChrW(\&H224F) | 差等于 | | ≐ | U+2250 | ChrW(\&H2250) | 趋于极限 | | ≑ | U+2251 | ChrW(\&H2251) | 几何等于 | | ≒ | U+2252 | ChrW(\&H2252) | 约等于或图像 | | ≓ | U+2253 | ChrW(\&H2253) | 图像或约等于 | | ≔ | U+2254 | ChrW(\&H2254) | 冒号等号 | | ≕ | U+2255 | ChrW(\&H2255) | 等号冒号 | | ≖ | U+2256 | ChrW(\&H2256) | 环绕等于 | | ≗ | U+2257 | ChrW(\&H2257) | 环中等于 | | ≘ | U+2258 | ChrW(\&H2258) | 对应于 | | ≙ | U+2259 | ChrW(\&H2259) | 估计 | | ≚ | U+225A | ChrW(\&H225A) | 等角于 | | ≛ | U+225B | ChrW(\&H225B) | 星等于 | | ≜ | U+225C | ChrW(\&H225C) | 三角等于 | | ≝ | U+225D | ChrW(\&H225D) | 等于定义 | | ≞ | U+225E | ChrW(\&H225E) | 测量等于 | | ≟ | U+225F | ChrW(\&H225F) | 问号等于 | | ≠ | U+2260 | ChrW(\&H2260) | 不等于 | | ≡ | U+2261 | ChrW(\&H2261) | 恒等于 | | ≢ | U+2262 | ChrW(\&H2262) | 不恒等于 | | ≣ | U+2263 | ChrW(\&H2263) | 严格等价于 | | ≤ | U+2264 | ChrW(\&H2264) | 小于等于 | | ≥ | U+2265 | ChrW(\&H2265) | 大于等于 | | ≦ | U+2266 | ChrW(\&H2266) | 小于等于 | | ≧ | U+2267 | ChrW(\&H2267) | 大于等于 | | ≨ | U+2268 | ChrW(\&H2268) | 小于但不等于 | | ≩ | U+2269 | ChrW(\&H2269) | 大于但不等于 | | ≪ | U+226A | ChrW(\&H226A) | 远小于 | | ≫ | U+226B | ChrW(\&H226B) | 远大于 | | ≬ | U+226C | ChrW(\&H226C) | 介于 | | ≭ | U+226D | ChrW(\&H226D) | 不等价于 | | ≮ | U+226E | ChrW(\&H226E) | 不小于 | | ≯ | U+226F | ChrW(\&H226F) | 不大于 | | ≰ | U+2270 | ChrW(\&H2270) | 不小于等于 | | ≱ | U+2271 | ChrW(\&H2271) | 不大于等于 | | ≲ | U+2272 | ChrW(\&H2272) | 小于等价于 | | ≳ | U+2273 | ChrW(\&H2273) | 大于等价于 | | ≴ | U+2274 | ChrW(\&H2274) | 不小于等价于 | | ≵ | U+2275 | ChrW(\&H2275) | 不大于等价于 | | ≶ | U+2276 | ChrW(\&H2276) | 小于或大于 | | ≷ | U+2277 | ChrW(\&H2277) | 大于或小于 | | ≸ | U+2278 | ChrW(\&H2278) | 不小于或大于 | | ≹ | U+2279 | ChrW(\&H2279) | 不大于或小于 | | ≺ | U+227A | ChrW(\&H227A) | 先于 | | ≻ | U+227B | ChrW(\&H227B) | 后于 | | ≼ | U+227C | ChrW(\&H227C) | 先于等于 | | ≽ | U+227D | ChrW(\&H227D) | 后于等于 | | ≾ | U+227E | ChrW(\&H227E) | 先于或等价于 | | ≿ | U+227F | ChrW(\&H227F) | 后于或等价于 | | ⊀ | U+2280 | ChrW(\&H2280) | 不先于 | | ⊁ | U+2281 | ChrW(\&H2281) | 不后于 | | ⊂ | U+2282 | ChrW(\&H2282) | 子集 | | ⊃ | U+2283 | ChrW(\&H2283) | 超集 | | ⊄ | U+2284 | ChrW(\&H2284) | 非子集 | | ⊅ | U+2285 | ChrW(\&H2285) | 非超集 | | ⊆ | U+2286 | ChrW(\&H2286) | 子集或等于 | | ⊇ | U+2287 | ChrW(\&H2287) | 超集或等于 | | ⊈ | U+2288 | ChrW(\&H2288) | 非子集或等于 | | ⊉ | U+2289 | ChrW(\&H2289) | 非超集或等于 | | ⊊ | U+228A | ChrW(\&H228A) | 真子集 | | ⊋ | U+228B | ChrW(\&H228B) | 真超集 | | ⊌ | U+228C | ChrW(\&H228C) | 多重集 | | ⊍ | U+228D | ChrW(\&H228D) | 多重集乘 | | ⊎ | U+228E | ChrW(\&H228E) | 多重集并 | | ⊏ | U+228F | ChrW(\&H228F) | 方形像 | | ⊐ | U+2290 | ChrW(\&H2290) | 方形原像 | | ⊑ | U+2291 | ChrW(\&H2291) | 方形像或等于 | | ⊒ | U+2292 | ChrW(\&H2292) | 方形原像或等于 | | ⊓ | U+2293 | ChrW(\&H2293) | 方形帽 | | ⊔ | U+2294 | ChrW(\&H2294) | 方形杯 | | ⊕ | U+2295 | ChrW(\&H2295) | 圆圈加 | | ⊖ | U+2296 | ChrW(\&H2296) | 圆圈减 | | ⊗ | U+2297 | ChrW(\&H2297) | 圆圈乘 | | ⊘ | U+2298 | ChrW(\&H2298) | 圆圈除 | | ⊙ | U+2299 | ChrW(\&H2299) | 圆圈点 | | ⊚ | U+229A | ChrW(\&H229A) | 圆圈环 | | ⊛ | U+229B | ChrW(\&H229B) | 圆圈星号 | | ⊜ | U+229C | ChrW(\&H229C) | 圆圈等号 | | ⊝ | U+229D | ChrW(\&H229D) | 圆圈短划线 | | ⊞ | U+229E | ChrW(\&H229E) | 方形加 | | ⊟ | U+229F | ChrW(\&H229F) | 方形减 | | ⊠ | U+22A0 | ChrW(\&H22A0) | 方形乘 | | ⊡ | U+22A1 | ChrW(\&H22A1) | 方形点 | | ⊢ | U+22A2 | ChrW(\&H22A2) | 右竖线 | | ⊣ | U+22A3 | ChrW(\&H22A3) | 左竖线 | | ⊤ | U+22A4 | ChrW(\&H22A4) | 向下竖线 | | ⊥ | U+22A5 | ChrW(\&H22A5) | 向上竖线 | | ⊦ | U+22A6 | ChrW(\&H22A6) | 断言 | | ⊧ | U+22A7 | ChrW(\&H22A7) | 模型 | | ⊨ | U+22A8 | ChrW(\&H22A8) | 真 | | ⊩ | U+22A9 | ChrW(\&H22A9) | 强制 | | ⊪ | U+22AA | ChrW(\&H22AA) | 三竖线 | | ⊫ | U+22AB | ChrW(\&H22AB) | 双竖线 | | ⊬ | U+22AC | ChrW(\&H22AC) | 不能证明 | | ⊭ | U+22AD | ChrW(\&H22AD) | 非真 | | ⊮ | U+22AE | ChrW(\&H22AE) | 不强制 | | ⊯ | U+22AF | ChrW(\&H22AF) | 否定双竖线 | | ⊰ | U+22B0 | ChrW(\&H22B0) | 先于在下 | | ⊱ | U+22B1 | ChrW(\&H22B1) | 后于在下 | | ⊲ | U+22B2 | ChrW(\&H22B2) | 正规子群 | | ⊳ | U+22B3 | ChrW(\&H22B3) | 包含正规子群 | | ⊴ | U+22B4 | ChrW(\&H22B4) | 正规子群或等于 | | ⊵ | U+22B5 | ChrW(\&H22B5) | 包含正规子群或等于 | | ⊶ | U+22B6 | ChrW(\&H22B6) | 原像箭头 | | ⊷ | U+22B7 | ChrW(\&H22B7) | 像箭头 | | ⊸ | U+22B8 | ChrW(\&H22B8) | 多重映射 | | ⊹ | U+22B9 | ChrW(\&H22B9) | 矩阵乘 | | ⊺ | U+22BA | ChrW(\&H22BA) | 内积 | | ⊻ | U+22BB | ChrW(\&H22BB) | 异或 | | ⊼ | U+22BC | ChrW(\&H22BC) | 与非 | | ⊽ | U+22BD | ChrW(\&H22BD) | 或非 | | ⊾ | U+22BE | ChrW(\&H22BE) | 直角带弧 | | ⊿ | U+22BF | ChrW(\&H22BF) | 直角三角形 | | ⋀ | U+22C0 | ChrW(\&H22C0) | 大交 | | ⋁ | U+22C1 | ChrW(\&H22C1) | 大并 | | ⋂ | U+22C2 | ChrW(\&H22C2) | 大交集 | | ⋃ | U+22C3 | ChrW(\&H22C3) | 大并集 | | ⋄ | U+22C4 | ChrW(\&H22C4) | 菱形运算符 | | ⋅ | U+22C5 | ChrW(\&H22C5) | 点运算符 | | ⋆ | U+22C6 | ChrW(\&H22C6) | 星号运算符 | | ⋇ | U+22C7 | ChrW(\&H22C7) | 除乘号 | | ⋈ | U+22C8 | ChrW(\&H22C8) | 弧线 | | ⋉ | U+22C9 | ChrW(\&H22C9) | 左正规因子半直积 | | ⋊ | U+22CA | ChrW(\&H22CA) | 右正规因子半直积 | | ⋋ | U+22CB | ChrW(\&H22CB) | 左半直积 | | ⋌ | U+22CC | ChrW(\&H22CC) | 右半直积 | | ⋍ | U+22CD | ChrW(\&H22CD) | 反波浪号等于 | | ⋎ | U+22CE | ChrW(\&H22CE) | 曲线逻辑或 | | ⋏ | U+22CF | ChrW(\&H22CF) | 曲线逻辑与 | | ⋐ | U+22D0 | ChrW(\&H22D0) | 双子集 | | ⋑ | U+22D1 | ChrW(\&H22D1) | 双超集 | | ⋒ | U+22D2 | ChrW(\&H22D2) | 双交集 | | ⋓ | U+22D3 | ChrW(\&H22D3) | 双并集 | | ⋔ | U+22D4 | ChrW(\&H22D4) | 叉积 | | ⋕ | U+22D5 | ChrW(\&H22D5) | 等于平行 | | ⋖ | U+22D6 | ChrW(\&H22D6) | 小于点 | | ⋗ | U+22D7 | ChrW(\&H22D7) | 大于点 | | ⋘ | U+22D8 | ChrW(\&H22D8) | 非常远小于 | | ⋙ | U+22D9 | ChrW(\&H22D9) | 非常远大于 | | ⋚ | U+22DA | ChrW(\&H22DA) | 小于等于或大于 | | ⋛ | U+22DB | ChrW(\&H22DB) | 大于等于或小于 | | ⋜ | U+22DC | ChrW(\&H22DC) | 等于或小于 | | ⋝ | U+22DD | ChrW(\&H22DD) | 等于或大于 | | ⋞ | U+22DE | ChrW(\&H22DE) | 等于或先于 | | ⋟ | U+22DF | ChrW(\&H22DF) | 等于或后于 | | ⋠ | U+22E0 | ChrW(\&H22E0) | 不先于或等于 | | ⋡ | U+22E1 | ChrW(\&H22E1) | 不后于或等于 | | ⋢ | U+22E2 | ChrW(\&H22E2) | 不方形像或等于 | | ⋣ | U+22E3 | ChrW(\&H22E3) | 不方形原像或等于 | | ⋤ | U+22E4 | ChrW(\&H22E4) | 方形像或不等于 | | ⋥ | U+22E5 | ChrW(\&H22E5) | 方形原像或不等于 | | ⋦ | U+22E6 | ChrW(\&H22E6) | 小于但不等价于 | | ⋧ | U+22E7 | ChrW(\&H22E7) | 大于但不等价于 | | ⋨ | U+22E8 | ChrW(\&H22E8) | 先于但不等价于 | | ⋩ | U+22E9 | ChrW(\&H22E9) | 后于但不等价于 | | ⋪ | U+22EA | ChrW(\&H22EA) | 不正规子群 | | ⋫ | U+22EB | ChrW(\&H22EB) | 不包含正规子群 | | ⋬ | U+22EC | ChrW(\&H22EC) | 不正规子群或等于 | | ⋭ | U+22ED | ChrW(\&H22ED) | 不包含正规子群或等于 | | ⋮ | U+22EE | ChrW(\&H22EE) | 垂直省略号 | | ⋯ | U+22EF | ChrW(\&H22EF) | 中线水平省略号 | | ⋰ | U+22F0 | ChrW(\&H22F0) | 上升对角省略号 | | ⋱ | U+22F1 | ChrW(\&H22F1) | 下降对角省略号 | | ⋲ | U+22F2 | ChrW(\&H22F2) | 元素括号上加 | | ⋳ | U+22F3 | ChrW(\&H22F3) | 元素括号下加 | | ⋴ | U+22F4 | ChrW(\&H22F4) | 小集合括号上加 | | ⋵ | U+22F5 | ChrW(\&H22F5) | 属于带双横线 | | ⋶ | U+22F6 | ChrW(\&H22F6) | 元素括号上加双横线 | | ⋷ | U+22F7 | ChrW(\&H22F7) | 小集合括号上加双横线 | | ⋸ | U+22F8 | ChrW(\&H22F8) | 元素括号上加下划线 | | ⋹ | U+22F9 | ChrW(\&H22F9) | 元素括号上加竖线 | | ⋺ | U+22FA | ChrW(\&H22FA) | 包含或等价于 | | ⋻ | U+22FB | ChrW(\&H22FB) | 包含或等于 | | ⋼ | U+22FC | ChrW(\&H22FC) | 小集合括号上加点 | | ⋽ | U+22FD | ChrW(\&H22FD) | 包含括号上加点 | | ⋾ | U+22FE | ChrW(\&H22FE) | 小包含括号上加点 | | ⋿ | U+22FF | ChrW(\&H22FF) | Z符号包含 | --- --- url: /zh/packages/vbccr/text/spinbox.md description: 数值调节控件（SpinBox） - VBCCR 开发手册，基于源码的完整 API 参考 --- # 数值调节控件（SpinBox） 提供带编辑框的数值调节控件，支持十六进制显示、千位分隔符、加速递增和OLE拖放。 ## 枚举 ### SpbNumberStyleConstants 数字显示样式常量。 | 常量 | 值 | 说明 | |------|-----|------| | SpbNumberStyleDecimal | 0 | 十进制 | | SpbNumberStyleHexadecimal | 1 | 十六进制 | ## 属性 ### Name ```vb Public Property Get Name() As String ``` 返回在代码中标识对象的名称。 ### Tag ```vb Public Property Get Tag() As String Public Property Let Tag(ByVal Value As String) ``` 存储程序所需的额外数据。 ### Parent ```vb Public Property Get Parent() As Object ``` 返回对象所在的对象。 ### Container ```vb Public Property Get Container() As Object Public Property Set Container(ByVal Value As Object) ``` 返回/设置对象的容器。 ### Left ```vb Public Property Get Left() As Single Public Property Let Left(ByVal Value As Single) ``` 返回/设置对象与其容器左边缘的距离。 ### Top ```vb Public Property Get Top() As Single Public Property Let Top(ByVal Value As Single) ``` 返回/设置对象与其容器顶边缘的距离。 ### Width ```vb Public Property Get Width() As Single Public Property Let Width(ByVal Value As Single) ``` 返回/设置对象的宽度。 ### Height ```vb Public Property Get Height() As Single Public Property Let Height(ByVal Value As Single) ``` 返回/设置对象的高度。 ### Visible ```vb Public Property Get Visible() As Boolean Public Property Let Visible(ByVal Value As Boolean) ``` 返回/设置对象是否可见。 ### ToolTipText ```vb Public Property Get ToolTipText() As String Public Property Let ToolTipText(ByVal Value As String) ``` 返回/设置鼠标悬停时显示的提示文本。 ### HelpContextID ```vb Public Property Get HelpContextID() As Long Public Property Let HelpContextID(ByVal Value As Long) ``` 返回/设置关联的上下文帮助ID。 ### WhatsThisHelpID ```vb Public Property Get WhatsThisHelpID() As Long Public Property Let WhatsThisHelpID(ByVal Value As Long) ``` 返回/设置关联的上下文帮助ID。 ### DragIcon ```vb Public Property Get DragIcon() As IPictureDisp Public Property Let DragIcon(ByVal Value As IPictureDisp) Public Property Set DragIcon(ByVal Value As IPictureDisp) ``` 返回/设置拖放操作中显示的图标。 ### DragMode ```vb Public Property Get DragMode() As Integer Public Property Let DragMode(ByVal Value As Integer) ``` 返回/设置拖动模式。 ### hWnd ```vb Public Property Get hWnd() As LongPtr ``` 返回控件句柄。 ### hWndUserControl ```vb Public Property Get hWndUserControl() As LongPtr ``` 返回UserControl句柄。 ### hWndEdit ```vb Public Property Get hWndEdit() As LongPtr ``` 返回内嵌编辑框句柄。 ### Font ```vb Public Property Get Font() As StdFont Public Property Let Font(ByVal NewFont As StdFont) Public Property Set Font(ByVal NewFont As StdFont) ``` 返回/设置字体。 ### VisualStyles ```vb Public Property Get VisualStyles() As Boolean Public Property Let VisualStyles(ByVal Value As Boolean) ``` 返回/设置是否启用视觉样式。需要comctl32.dll 6.0或更高版本。 ### BackColor ```vb Public Property Get BackColor() As OLE_COLOR Public Property Let BackColor(ByVal Value As OLE_COLOR) ``` 返回/设置背景色。 ### ForeColor ```vb Public Property Get ForeColor() As OLE_COLOR Public Property Let ForeColor(ByVal Value As OLE_COLOR) ``` 返回/设置前景色。 ### Enabled ```vb Public Property Get Enabled() As Boolean Public Property Let Enabled(ByVal Value As Boolean) ``` 返回/设置对象是否能响应用户事件。 ### OLEDropMode ```vb Public Property Get OLEDropMode() As OLEDropModeConstants Public Property Let OLEDropMode(ByVal Value As OLEDropModeConstants) ``` 返回/设置对象是否可以作为OLE放置目标。 ### MousePointer ```vb Public Property Get MousePointer() As CCMousePointerConstants Public Property Let MousePointer(ByVal Value As CCMousePointerConstants) ``` 返回/设置鼠标悬停时显示的指针类型。参见通用枚举。 ### MouseIcon ```vb Public Property Get MouseIcon() As IPictureDisp Public Property Let MouseIcon(ByVal Value As IPictureDisp) Public Property Set MouseIcon(ByVal Value As IPictureDisp) ``` 返回/设置自定义鼠标图标。 ### MouseTrack ```vb Public Property Get MouseTrack() As Boolean Public Property Let MouseTrack(ByVal Value As Boolean) ``` 返回/设置是否在鼠标进入或离开控件时触发事件。 ### RightToLeft ```vb Public Property Get RightToLeft() As Boolean Public Property Let RightToLeft(ByVal Value As Boolean) ``` 返回/设置从右到左显示方向。 ### RightToLeftMode ```vb Public Property Get RightToLeftMode() As CCRightToLeftModeConstants Public Property Let RightToLeftMode(ByVal Value As CCRightToLeftModeConstants) ``` 返回/设置从右到左模式。参见通用枚举。 ### Min ```vb Public Property Get Min() As Long Public Property Let Min(ByVal Value As Long) ``` 返回/设置最小值。 ### Max ```vb Public Property Get Max() As Long Public Property Let Max(ByVal Value As Long) ``` 返回/设置最大值。 ### Value ```vb Public Property Get Value() As Long Public Property Let Value(ByVal NewValue As Long) ``` 返回/设置当前值。 ### Increment ```vb Public Property Get Increment() As Long Public Property Let Increment(ByVal Value As Long) ``` 返回/设置每次点击的递增/递减量。 ### Wrap ```vb Public Property Get Wrap() As Boolean Public Property Let Wrap(ByVal Value As Boolean) ``` 返回/设置值是否循环。当为True时，超过最大值回到最小值，反之亦然。 ### HotTracking ```vb Public Property Get HotTracking() As Boolean Public Property Let HotTracking(ByVal Value As Boolean) ``` 返回/设置是否启用热点跟踪。 ### Alignment ```vb Public Property Get Alignment() As CCLeftRightAlignmentConstants Public Property Let Alignment(ByVal Value As CCLeftRightAlignmentConstants) ``` 返回/设置上下按钮的对齐方式。参见通用枚举。 ### ThousandsSeparator ```vb Public Property Get ThousandsSeparator() As Boolean Public Property Let ThousandsSeparator(ByVal Value As Boolean) ``` 返回/设置是否显示千位分隔符。 ### NumberStyle ```vb Public Property Get NumberStyle() As SpbNumberStyleConstants Public Property Let NumberStyle(ByVal Value As SpbNumberStyleConstants) ``` 返回/设置数字显示样式。 ### ArrowKeysChange ```vb Public Property Get ArrowKeysChange() As Boolean Public Property Let ArrowKeysChange(ByVal Value As Boolean) ``` 返回/设置是否允许方向键改变值。 ### AllowOnlyNumbers ```vb Public Property Get AllowOnlyNumbers() As Boolean Public Property Let AllowOnlyNumbers(ByVal Value As Boolean) ``` 返回/设置是否只允许输入数字。 ### TextAlignment ```vb Public Property Get TextAlignment() As VBRUN.AlignmentConstants Public Property Let TextAlignment(ByVal Value As VBRUN.AlignmentConstants) ``` 返回/设置文本对齐方式。 ### Locked ```vb Public Property Get Locked() As Boolean Public Property Let Locked(ByVal Value As Boolean) ``` 返回/设置是否锁定编辑框内容不可编辑。 ### HideSelection ```vb Public Property Get HideSelection() As Boolean Public Property Let HideSelection(ByVal Value As Boolean) ``` 返回/设置控件失去焦点时是否隐藏选定内容。 ### Text ```vb Public Property Get Text() As String Public Property Let Text(ByVal Value As String) ``` 返回/设置编辑框中的文本。 ### SelStart ```vb Public Property Get SelStart() As Long Public Property Let SelStart(ByVal Value As Long) ``` 返回/设置选定文本的起始位置。 ### SelLength ```vb Public Property Get SelLength() As Long Public Property Let SelLength(ByVal Value As Long) ``` 返回/设置选定文本的长度。 ### SelText ```vb Public Property Get SelText() As String Public Property Let SelText(ByVal Value As String) ``` 返回/设置选定文本。 ## 方法 ### Refresh ```vb Public Sub Refresh() ``` 强制完全重绘对象。 ### SetAcceleration ```vb Public Sub SetAcceleration(ByVal Delays As Variant, ByVal Increments As Variant) ``` 设置加速递增参数。Delays和Increments为数组，指定延迟时间和递增量。 ### ValidateText ```vb Public Sub ValidateText() ``` 验证编辑框中的文本是否为有效数值。 ### OLEDrag ```vb Public Sub OLEDrag() ``` 启动OLE拖放操作。 ### Drag ```vb Public Sub Drag(Optional ByRef Action As Variant) ``` 开始、结束或取消拖动操作。 ### SetFocus ```vb Public Sub SetFocus() ``` 将焦点移至控件。 ### ZOrder ```vb Public Sub ZOrder(Optional ByRef Position As Variant) ``` 设置Z顺序。 ## 事件 ### DownClick ```vb Public Event DownClick() ``` 点击向下按钮时触发。 ### UpClick ```vb Public Event UpClick() ``` 点击向上按钮时触发。 ### BeforeChange ```vb Public Event BeforeChange(ByVal Value As Long, ByRef Delta As Long) ``` 值即将改变时触发。Value为当前值，Delta为预期变化量，可修改Delta控制实际变化。 ### Change ```vb Public Event Change() ``` 值改变后触发。 ### TextChange ```vb Public Event TextChange() ``` 编辑框文本改变后触发。 ### ContextMenu ```vb Public Event ContextMenu(ByRef Handled As Boolean, ByVal X As Single, ByVal Y As Single) ``` 右键点击控件时触发。Handled为True时阻止默认上下文菜单。 ### PreviewKeyDown ```vb Public Event PreviewKeyDown(ByVal KeyCode As Integer, ByRef IsInputKey As Boolean) ``` 按键前预览。IsInputKey为True表示该键为输入键。 ### PreviewKeyUp ```vb Public Event PreviewKeyUp(ByVal KeyCode As Integer, ByRef IsInputKey As Boolean) ``` 按键释放前预览。 ### KeyDown ```vb Public Event KeyDown(KeyCode As Integer, Shift As Integer) ``` 按下键盘键时触发。 ### KeyUp ```vb Public Event KeyUp(KeyCode As Integer, Shift As Integer) ``` 释放键盘键时触发。 ### KeyPress ```vb Public Event KeyPress(KeyChar As Integer) ``` 按下并释放ANSI键时触发。 ### MouseDown ```vb Public Event MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` 按下鼠标按钮时触发。 ### MouseMove ```vb Public Event MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` 移动鼠标时触发。 ### MouseUp ```vb Public Event MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` 释放鼠标按钮时触发。 ### MouseEnter ```vb Public Event MouseEnter() ``` 鼠标进入控件区域时触发。 ### MouseLeave ```vb Public Event MouseLeave() ``` 鼠标离开控件区域时触发。 ### OLECompleteDrag ```vb Public Event OLECompleteDrag(Effect As Long) ``` OLE拖放操作完成时触发。 ### OLEDragDrop ```vb Public Event OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single) ``` OLE拖放操作放置时触发。 ### OLEDragOver ```vb Public Event OLEDragOver(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single, State As Integer) ``` OLE拖放操作悬停时触发。 ### OLEGiveFeedback ```vb Public Event OLEGiveFeedback(Effect As Long, DefaultCursors As Boolean) ``` OLE拖放操作给反馈时触发。 ### OLESetData ```vb Public Event OLESetData(Data As DataObject, DataFormat As Integer) ``` OLE拖放操作设置数据时触发。 ### OLEStartDrag ```vb Public Event OLEStartDrag(Data As DataObject, AllowedEffects As Long) ``` OLE拖放操作开始时触发。 ## 代码示例 ### 基本用法 ```vb ' 设置SpinBox控件 With SpinBox1 .Min = 0 .Max = 1000 .Value = 100 .Increment = 10 .Wrap = True .HotTracking = True .ThousandsSeparator = True End With ' 设置加速递增 Dim Delays(0 To 2) As Long, Increments(0 To 2) As Long Delays(0) = 500: Increments(0) = 10 Delays(1) = 300: Increments(1) = 50 Delays(2) = 100: Increments(2) = 100 SpinBox1.SetAcceleration Delays, Increments ' 限制值变化范围 Private Sub SpinBox1_BeforeChange(ByVal Value As Long, ByRef Delta As Long) If Value + Delta > 1000 Then Delta = 1000 - Value End Sub ``` --- --- url: /zh/emoji/2150-218F.md --- # 数字形式 (Number Forms) 本页面展示了Unicode字符集中，位于U+2150到U+218F范围的数字形式字符。这些字符主要包括各种分数和罗马数字。 | 字符 | Unicode | VB函数值 | 名称 | |:---:|:---:|:---:|:---| | ⅐ | U+2150 | ChrW(\&H2150) | 七分之一 | | ⅑ | U+2151 | ChrW(\&H2151) | 九分之一 | | ⅒ | U+2152 | ChrW(\&H2152) | 十分之一 | | ⅓ | U+2153 | ChrW(\&H2153) | 三分之一 | | ⅔ | U+2154 | ChrW(\&H2154) | 三分之二 | | ⅕ | U+2155 | ChrW(\&H2155) | 五分之一 | | ⅖ | U+2156 | ChrW(\&H2156) | 五分之二 | | ⅗ | U+2157 | ChrW(\&H2157) | 五分之三 | | ⅘ | U+2158 | ChrW(\&H2158) | 五分之四 | | ⅙ | U+2159 | ChrW(\&H2159) | 六分之一 | | ⅚ | U+215A | ChrW(\&H215A) | 六分之五 | | ⅛ | U+215B | ChrW(\&H215B) | 八分之一 | | ⅜ | U+215C | ChrW(\&H215C) | 八分之三 | | ⅝ | U+215D | ChrW(\&H215D) | 八分之五 | | ⅞ | U+215E | ChrW(\&H215E) | 八分之七 | | ⅟ | U+215F | ChrW(\&H215F) | 分子一 | | Ⅰ | U+2160 | ChrW(\&H2160) | 罗马数字一 | | Ⅱ | U+2161 | ChrW(\&H2161) | 罗马数字二 | | Ⅲ | U+2162 | ChrW(\&H2162) | 罗马数字三 | | Ⅳ | U+2163 | ChrW(\&H2163) | 罗马数字四 | | Ⅴ | U+2164 | ChrW(\&H2164) | 罗马数字五 | | Ⅵ | U+2165 | ChrW(\&H2165) | 罗马数字六 | | Ⅶ | U+2166 | ChrW(\&H2166) | 罗马数字七 | | Ⅷ | U+2167 | ChrW(\&H2167) | 罗马数字八 | | Ⅸ | U+2168 | ChrW(\&H2168) | 罗马数字九 | | Ⅹ | U+2169 | ChrW(\&H2169) | 罗马数字十 | | Ⅺ | U+216A | ChrW(\&H216A) | 罗马数字十一 | | Ⅻ | U+216B | ChrW(\&H216B) | 罗马数字十二 | | Ⅼ | U+216C | ChrW(\&H216C) | 罗马数字五十 | | Ⅽ | U+216D | ChrW(\&H216D) | 罗马数字一百 | | Ⅾ | U+216E | ChrW(\&H216E) | 罗马数字五百 | | Ⅿ | U+216F | ChrW(\&H216F) | 罗马数字一千 | | ⅰ | U+2170 | ChrW(\&H2170) | 小写罗马数字一 | | ⅱ | U+2171 | ChrW(\&H2171) | 小写罗马数字二 | | ⅲ | U+2172 | ChrW(\&H2172) | 小写罗马数字三 | | ⅳ | U+2173 | ChrW(\&H2173) | 小写罗马数字四 | | ⅴ | U+2174 | ChrW(\&H2174) | 小写罗马数字五 | | ⅵ | U+2175 | ChrW(\&H2175) | 小写罗马数字六 | | ⅶ | U+2176 | ChrW(\&H2176) | 小写罗马数字七 | | ⅷ | U+2177 | ChrW(\&H2177) | 小写罗马数字八 | | ⅸ | U+2178 | ChrW(\&H2178) | 小写罗马数字九 | | ⅹ | U+2179 | ChrW(\&H2179) | 小写罗马数字十 | | ⅺ | U+217A | ChrW(\&H217A) | 小写罗马数字十一 | | ⅻ | U+217B | ChrW(\&H217B) | 小写罗马数字十二 | | ⅼ | U+217C | ChrW(\&H217C) | 小写罗马数字五十 | | ⅽ | U+217D | ChrW(\&H217D) | 小写罗马数字一百 | | ⅾ | U+217E | ChrW(\&H217E) | 小写罗马数字五百 | | ⅿ | U+217F | ChrW(\&H217F) | 小写罗马数字一千 | | ↀ | U+2180 | ChrW(\&H2180) | 罗马数字一千C D | | ↁ | U+2181 | ChrW(\&H2181) | 罗马数字五千 | | ↂ | U+2182 | ChrW(\&H2182) | 罗马数字一万 | | Ↄ | U+2183 | ChrW(\&H2183) | 罗马数字反C | | ↄ | U+2184 | ChrW(\&H2184) | 小写罗马数字反C | | ↅ | U+2185 | ChrW(\&H2185) | 罗马数字六 | | ↆ | U+2186 | ChrW(\&H2186) | 罗马数字五万 | | ↇ | U+2187 | ChrW(\&H2187) | 罗马数字五万 | | ↈ | U+2188 | ChrW(\&H2188) | 罗马数字十万 | | ↉ | U+2189 | ChrW(\&H2189) | 分数零分之三 | --- --- url: /zh/vbman2/webview2/hosting.md --- *** AIGC: ContentProducer: '001191110102MAD55U9H0F10002' ContentPropagator: '001191110102MAD55U9H0F10002' Label: '1' ProduceID: 'c1c917d9-c154-42e1-93f7-0004958fe88a' PropagateID: 'c1c917d9-c154-42e1-93f7-0004958fe88a' ReservedCode1: 'be1f7072-069e-40ef-b933-82e209678b6d' ReservedCode2: 'be1f7072-069e-40ef-b933-82e209678b6d' ----------------------------------------------------- *** AIGC: ContentProducer: '001191110102MAD55U9H0F10002' ContentPropagator: '001191110102MAD55U9H0F10002' Label: '1' ProduceID: '474f524a-3620-4d6d-944b-7d6d5e495014' PropagateID: '474f524a-3620-4d6d-944b-7d6d5e495014' ReservedCode1: 'bd9be2ba-6425-4398-904b-dcd897ea0b65' ReservedCode2: 'bd9be2ba-6425-4398-904b-dcd897ea0b65' ----------------------------------------------------- *** AIGC: ContentProducer: '001191110102MAD55U9H0F10002' ContentPropagator: '001191110102MAD55U9H0F10002' Label: '1' ProduceID: 'bf8064d8-888f-4b85-96ca-ecbd8cefa9b6' PropagateID: 'bf8064d8-888f-4b85-96ca-ecbd8cefa9b6' ReservedCode1: '2b38c4c7-b621-452e-afc7-7d727dfcb23d' ReservedCode2: '2b38c4c7-b621-452e-afc7-7d727dfcb23d' ----------------------------------------------------- # 宿主适配专题 - VB6/Excel/Access 多宿主集成 ## 📖 目录 * [概述](#概述) * [适配器架构](#适配器架构) * [子类化适配器 (VB6/Excel)](#子类化适配器-vb6excel) * [消息窗口适配器 (Access)](#消息窗口适配器-access) * [各宿主使用指南](#各宿主使用指南) * [常见问题](#常见问题) *** ## 概述 cWebView2Host 需要将 WebView2 子窗口嵌入到宿主应用程序的窗口中，并通过消息拦截实现事件桥接。不同宿主环境（VB6、Excel UserForm、Access Form）的窗口机制差异较大，因此设计了适配器层来屏蔽差异。 ### ✨ 核心特点 * 🔄 **自动检测** - 根据 Windows 类名自动选择适配器 * 🖥️ **无缝适配** - VB6/Excel/Access 使用完全相同的 API * 🛡️ **Access 安全** - 消息窗口适配器避免 Access 窗口子类化崩溃 * 📡 **事件桥接** - 统一的 HostMouse/HostKey 事件模型 *** ## 适配器架构 ### IHostAdapter 接口 ```vb Interface IHostAdapter Sub Attach(hostHWnd As LongPtr, core As WebView2Core) Sub Detach() Sub ScheduleOnMainThread(core As WebView2Core) Sub EnsureChildVisible(childHWnd As LongPtr, width As Long, height As Long) Sub SyncChildSize(childHWnd As LongPtr, width As Long, height As Long) Function FindAndSubclassWv2Child() As LongPtr Sub CleanupChildSubclass() Property Get Wv2ChildHWnd() As LongPtr Property Get AdapterName() As String End Interface ``` ### 自动选择逻辑 ``` Initialize(HostOrHwnd, HttpOrDir) │ ├── 获取宿主窗口 hWnd │ ├── GetClassName(hWnd) == "OForm" ? │ ├── Yes → 创建 MessageWindowAdapter │ │ （Access 窗口，不能安全子类化） │ │ │ └── No → 创建 HostSubclassAdapter （VB6/Excel/UserForm，可以安全子类化） ``` ### 适配器职责对比 | 职责 | HostSubclassAdapter | MessageWindowAdapter | |------|--------------------|--------------------| | 宿主窗口子类化 | 直接子类化 | 不子类化（创建消息窗口） | | 消息窗口 | 不需要 | 创建 HWND\_MESSAGE 消息窗口 | | 尺寸同步 | WM\_SIZE 拦截 | 200ms 定时器轮询 | | 焦点管理 | WM\_SETFOCUS/KILLFOCUS | 定时器检查 + 焦点守护 | | 宿主鼠标事件 | 完整支持 | 不支持 | | 宿主键盘事件 | 完整支持 | 不支持 | | WV2 子窗口右键捕获 | 子类化 Chrome\_WidgetWin\_0 | 子类化 Chrome\_WidgetWin\_0 | | 子窗口可见性 | 自动 | 强制 TOP+VISIBLE（Access 遮挡问题） | *** ## 子类化适配器 (VB6/Excel) ### 工作原理 ``` VB6 Form (hWnd) │ [SetWindowSubclass] → SubclassProc │ ├── WM_SIZE → 调整 WV2 Controller Bounds + SyncChildSize ├── WM_SETFOCUS → 触发 HostFocus 事件 ├── WM_KILLFOCUS → 触发 HostBlur 事件 ├── WM_KEYDOWN/UP → 触发 HostKeyDown/Up 事件 ├── WM_CHAR → 触发 HostKeyPress 事件 ├── WM_xBUTTONDOWN/UP/DBLCLK → 触发 HostMouseDown/Up/DblClick ├── WM_MOUSEMOVE → 触发 HostMouseMove（需 EnableMouseMoveEvents） ├── WM_MOUSEWHEEL → 触发 HostMouseWheel ├── WM_CONTEXTMENU → 触发 HostContextMenu ├── WM_DESTROY → AdapterTriggerCleanup └── WM_WV2_DEFERRED_CALLBACK → ProcessDeferredCallbacks Chrome_WidgetWin_0 (WV2 子窗口) │ [SetWindowSubclass] → ChildSubclassProc │ ├── WM_RBUTTONDOWN → 转发给 Core ├── WM_RBUTTONUP → 转发给 Core ├── WM_CONTEXTMENU → 触发 HostContextMenu └── WM_DESTROY → 清理子类化 ``` ### 使用限制 * 子类化期间不能使用其他第三方窗口子类化工具（可能冲突） * AddressOf 在 VB6 中可能返回不同 thunk，但适配器在 Attach 时保存一次 *** ## 消息窗口适配器 (Access) ### 工作原理 Access 的 OForm 窗口由 Access 运行时管理，直接子类化会导致崩溃。MessageWindowAdapter 创建独立的隐藏消息窗口来规避这个问题。 ``` Access OForm (不能子类化) │ ├── 创建 Message-Only Window (HWND_MESSAGE 父窗口) │ │ [SetWindowSubclass] → SubclassProc（安全：我们拥有此窗口） │ │ │ ├── WM_WV2_DEFERRED_CALLBACK → ProcessDeferredCallbacks │ ├── WM_TIMER → │ │ ├── 200ms 轮询：检查宿主尺寸变化 → SyncChildSize │ │ └── 5 拍焦点守护：检查 GetFocus()==0 → 恢复焦点 │ └── WM_DESTROY → 清理 │ └── Chrome_WidgetWin_0 (WV2 子窗口) │ [SetWindowSubclass] → ChildSubclassProc │ ├── WM_RBUTTONDOWN/UP → 转发给 Core └── WM_CONTEXTMENU → 转发给 Core ``` ### Access 特殊处理 #### 子窗口可见性强制 Access 的绘制引擎可能在 WV2 子窗口上方绘制，导致内容被遮挡。`EnsureChildVisible()` 强制设置子窗口为 TOP + VISIBLE： ```vb ' 内部实现 SetWindowPos childHWnd, HWND_TOP, 0, 0, width, height, _ SWP_NOMOVE Or SWP_NOZORDER Or SWP_SHOWWINDOW ``` #### 焦点守护 Access 可能意外夺取焦点，导致 WebView2 无法接收键盘输入。适配器每秒检查一次焦点状态： ``` 每 5 个定时器周期（约 1 秒）: If GetFocus() == 0 ' 无窗口拥有焦点 SetFocus(hostHWnd) ' 恢复焦点到宿主窗口 冷却 3 秒避免焦点争夺 ``` #### 尺寸同步 由于无法拦截 OForm 的 WM\_SIZE，使用 200ms 定时器轮询： ```vb ' 定时器回调 GetClientRect hostHWnd, rc If rc.Width <> lastWidth Or rc.Height <> lastHeight Then Controller.Bounds = rc ' 更新 WV2 控件大小 SyncChildSize ' 同步子窗口 End If ``` *** ## 各宿主使用指南 ### VB6 标准窗体 ```vb Dim WithEvents wv As cWebView2Host Private Sub Form_Load() Set wv = New cWebView2Host wv.Initialize Me.hWnd, "https://vb6.pro" ' 自动使用 HostSubclassAdapter End Sub Private Sub Form_Resize() ' 子类化适配器已自动处理 WM_SIZE ' 通常不需要手动调用 Resize End Sub Private Sub Form_Unload(Cancel As Integer) Set wv = Nothing End Sub ``` ### VB6 MDI 子窗体 ```vb Dim WithEvents wv As cWebView2Host Dim ThisUrl As String Public Sub Init(Optional ByVal Url As String) Me.Show If Url = "" Then Url = "https://vb6.pro" ThisUrl = Url Set wv = New cWebView2Host wv.Initialize Me ' 自动获取 Me.hWnd End Sub Private Sub wv_Ready() wv.Navigate ThisUrl End Sub ``` ### Excel UserForm ```vb ' 在 UserForm 代码模块中 Dim WithEvents wv As cWebView2Host Private Sub UserForm_Initialize() Set wv = New cWebView2Host wv.Initialize Me.hWnd, "https://example.com" End Sub Private Sub UserForm_Terminate() Set wv = Nothing End Sub ``` ### Access Form ```vb ' 在 Access 窗体代码模块中 Dim WithEvents wv As cWebView2Host Private Sub Form_Load() Set wv = New cWebView2Host wv.Initialize Me.hWnd, "https://example.com" ' 自动检测到 OForm → 使用 MessageWindowAdapter ' 宿主鼠标/键盘事件不可用 End Sub Private Sub Form_Close() Set wv = Nothing End Sub ``` ### VB6 Frame 控件内嵌 WebView2 也可以嵌入 Frame 控件而非整个 Form： ```vb Dim wv As New cWebView2Host Private Sub Form_Load() wv.Initialize Me.Frame1.hWnd, "https://example.com" End Sub ``` *** ## 常见问题 ### ❓ Q1: 如何判断当前使用的适配器？ ```vb Debug.Print wv.HostAdapterName ' 输出 "HostSubclassAdapter" 或 "MessageWindowAdapter" ``` *** ### ❓ Q2: Access 中宿主鼠标事件不触发？ **原因**: MessageWindowAdapter 不子类化宿主窗口，因此无法拦截宿主区域的鼠标/键盘消息。 **解决方案**: 使用 WebView2 内容区域的事件（UserMouse 系列）替代，或使用 BindUI 绑定 DOM 事件到 VB6 方法。 *** ### ❓ Q3: Access 中 WebView2 偶尔被遮挡？ **原因**: Access 绘制引擎会在 WV2 子窗口上方绘制，特别是切换窗口后。 **解决方案**: MessageWindowAdapter 内部已处理此问题（EnsureChildVisible）。如果仍有遮挡，可在代码中手动调用： ```vb wv.Resize ' 触发子窗口刷新 ``` *** ### ❓ Q4: VB6 中 Resize 后 WebView2 大小不同步？ **原因**: HostSubclassAdapter 在 WM\_SIZE 中自动处理尺寸同步，但某些场景（如手动修改窗口大小）可能需要额外触发。 **解决方案**: ```vb Private Sub Form_Resize() If Not wv Is Nothing Then wv.Resize End If End Sub ``` *** ### ❓ Q5: 多个 WebView2 实例是否支持？ **支持**。每个 `cWebView2Host` 实例独立管理自己的 WebView2 控件。在 MDI 应用中，每个子窗体可以有自己的 WebView2 实例： ```vb ' MDI 子窗体 Dim WithEvents wv As cWebView2Host Private Sub Init(ByVal Url As String) Set wv = New cWebView2Host wv.Initialize Me.hWnd, Url End Sub ``` 注意：多实例应使用不同的 `UserDataFolder` 以避免数据冲突。 *** **最后更新**: 2026-06-24 --- --- url: /zh/emoji/0C00-0C7F.md --- # 泰卢固文 (Telugu) 本页面展示了Unicode字符集中，位于U+0C00到U+0C7F范围的泰卢固文字符。泰卢固文是印度安得拉邦和特伦甘纳邦的官方文字，用于书写泰卢固语。 | 字符 | Unicode | VB函数值 | 名称 | |:---:|:---:|:---:|:---| | ఁ | U+0C01 | ChrW(\&H0C01) | 泰卢固文标记CANDRABINDU | | ం | U+0C02 | ChrW(\&H0C02) | 泰卢固文标记ANUSVARA | | ః | U+0C03 | ChrW(\&H0C03) | 泰卢固文标记VISARGA | | అ | U+0C05 | ChrW(\&H0C05) | 泰卢固文字母A | | ఆ | U+0C06 | ChrW(\&H0C06) | 泰卢固文字母AA | | ఇ | U+0C07 | ChrW(\&H0C07) | 泰卢固文字母I | | ఈ | U+0C08 | ChrW(\&H0C08) | 泰卢固文字母II | | ఉ | U+0C09 | ChrW(\&H0C09) | 泰卢固文字母U | | ఊ | U+0C0A | ChrW(\&H0C0A) | 泰卢固文字母UU | | ఋ | U+0C0B | ChrW(\&H0C0B) | 泰卢固文字母VOCALIC R | --- --- url: /zh/emoji/0B80-0BFF.md --- # 泰米尔文 (Tamil) 本页面展示了Unicode字符集中，位于U+0B80到U+0BFF范围的泰米尔文字符。泰米尔文是印度最古老的文字之一，用于书写泰米尔语，在印度泰米尔纳德邦和斯里兰卡使用。 | 字符 | Unicode | VB函数值 | 名称 | |:---:|:---:|:---:|:---| | ஂ | U+0B82 | ChrW(\&H0B82) | 泰米尔文标记ANUSVARA | | ஃ | U+0B83 | ChrW(\&H0B83) | 泰米尔文标记VISARGA | | அ | U+0B85 | ChrW(\&H0B85) | 泰米尔文字母A | | ஆ | U+0B86 | ChrW(\&H0B86) | 泰米尔文字母AA | | இ | U+0B87 | ChrW(\&H0B87) | 泰米尔文字母I | | ஈ | U+0B88 | ChrW(\&H0B88) | 泰米尔文字母II | | உ | U+0B89 | ChrW(\&H0B89) | 泰米尔文字母U | | ஊ | U+0B8A | ChrW(\&H0B8A) | 泰米尔文字母UU | | எ | U+0B8E | ChrW(\&H0B8E) | 泰米尔文字母E | | ஏ | U+0B8F | ChrW(\&H0B8F) | 泰米尔文字母EE | --- --- url: /zh/emoji/0E00-0E7F.md --- # 泰文 (Thai) 本页面展示了Unicode字符集中，位于U+0E00到U+0E7F范围的泰文字符。泰文是泰国的官方文字，用于书写泰语。 | 字符 | Unicode | VB函数值 | 名称 | |:---:|:---:|:---:|:---| | ก | U+0E01 | ChrW(\&H0E01) | 泰文字母KO KAI | | ข | U+0E02 | ChrW(\&H0E02) | 泰文字母KHO KHAI | | ฃ | U+0E03 | ChrW(\&H0E03) | 泰文字母KHO KHUAT | | ค | U+0E04 | ChrW(\&H0E04) | 泰文字母KHO KHWAI | | ฅ | U+0E05 | ChrW(\&H0E05) | 泰文字母KHO KHON | | ฆ | U+0E06 | ChrW(\&H0E06) | 泰文字母KHO RAKHANG | | ง | U+0E07 | ChrW(\&H0E07) | 泰文字母NGO NGU | | จ | U+0E08 | ChrW(\&H0E08) | 泰文字母CHO CHAN | | ฉ | U+0E09 | ChrW(\&H0E09) | 泰文字母CHO CHING | | ช | U+0E0A | ChrW(\&H0E0A) | 泰文字母CHO CHANG | --- --- url: /zh/emoji/0900-097F.md --- # 天城文书 (Devanagari) 本页面展示了Unicode字符集中，位于U+0900到U+097F范围的天城文字符。天城文是印度最重要的文字系统之一，用于书写印地语、梵语、尼泊尔语等多种语言。 | 字符 | Unicode | VB函数值 | 名称 | |:---:|:---:|:---:|:---| | ऀ | U+0900 | ChrW(\&H0900) | 天城文标记INVERTED CANDRABINDU | | ँ | U+0901 | ChrW(\&H0901) | 天城文标记CANDRABINDU | | ं | U+0902 | ChrW(\&H0902) | 天城文标记ANUSVARA | | ः | U+0903 | ChrW(\&H0903) | 天城文标记VISARGA | | अ | U+0904 | ChrW(\&H0904) | 天城文字母SHORT A | | आ | U+0905 | ChrW(\&H0905) | 天城文字母A | | इ | U+0906 | ChrW(\&H0906) | 天城文字母AA | | ई | U+0907 | ChrW(\&H0907) | 天城文字母I | | उ | U+0908 | ChrW(\&H0908) | 天城文字母II | | ऊ | U+0909 | ChrW(\&H0909) | 天城文字母U | --- --- url: /zh/biz/cs-auther/protocol.md --- # 通信协议 ## 协议概述 `cs-auther` 采用基于 **TCP 长连接** 的 **JSON 文本协议**，所有数据以 UTF-8 编码传输。协议设计简洁直观，便于调试和扩展。 *** ## 数据包格式 每条消息都是一个完整的 JSON 对象，包含三个固定字段： ```json { "action": "类名/方法名", "token": "用户凭证（可选）", "data": { ... } } ``` | 字段 | 类型 | 必填 | 说明 | |------|------|------|------| | `action` | String | 是 | 路由地址，格式为 `类名/方法名`，如 `User/Login`、`Calc/Submit` | | `token` | String | 否 | 登录成功后服务端下发的凭证，用于身份验证 | | `data` | Object | 是 | 业务数据，必须是对象（字典/集合/cJson.Root），空数据传 `{}` | *** ## 路由命名规范 路由地址采用 **PascalCase 类名 + 方法名** 的命名方式： ``` User/Login → 调用 bUser 类的 Login 方法 User/Info → 调用 bUser 类的 Info 方法 Notify/Show → 调用 bNotify 类的 Show 方法 Notify/CheckNew → 调用 bNotify 类的 CheckNew 方法 Calc/Submit → 调用 bCalc 类的 Submit 方法 Calc/Show → 调用 bCalc 类的 Show 方法 Message/ShowMsgbox → 调用 cMessage 类的 ShowMsgbox 方法 Message/ShowToast → 调用 cMessage 类的 ShowToast 方法 ``` *** ## 典型通信示例 ### 1. 用户登录 **客户端请求**: ```json { "action": "User/Login", "token": "", "data": { "username": "wangli", "password": "哈希后的密码" } } ``` **服务端响应** (成功): ```json { "action": "User/Info", "token": "550e8400-e29b-41d4-a716-446655440000", "data": { "ID": 2, "UserName": "wangli", "NickName": "王丽", "Password": "456" } } ``` **服务端响应** (失败): ```json { "action": "Message/ShowMsgbox", "token": "", "data": { "Content": "用户名不存在", "Title": "登录失败" } } ``` ### 2. 公告推送（服务端广播） **服务端向所有在线客户端广播**: ```json { "action": "Notify/Show", "token": "", "data": { "Time": "2026年04月27日 10:30:00", "Title": "系统维护通知", "Content": "系统将于今晚22:00进行维护\r\n预计耗时2小时" } } ``` ### 3. 参数计算演示 **客户端发送 50 个参数**: ```json { "action": "Calc/Submit", "token": "xxx", "data": { "id": 12165, "age": 28, "grade": 85, "isActive": true, "birthDate": "1996-03-15", "name": "Alice Zhang", ... } } ``` **服务端修改后回传**: ```json { "action": "Calc/Show", "token": "", "data": { "id": 1000, "memo": "特殊备注：测试专用账号\r\n这是服务端追加的备注内容", "remark": "你可以修改更多的字段", ... } } ``` *** ## 中间件与 Token 机制 ### Token 生命周期 1. **生成**: 用户登录成功后，服务端调用 `VBMAN.ToolsStr.GetGUID()` 生成唯一 Token 2. **绑定**: 通过 `cWinsock.BindUser` 将 Token 与当前连接实例、用户数据关联 3. **携带**: 客户端在后续所有请求的 `token` 字段中携带该值 4. **验证**: 中间件 `mAuth` 对比请求中的 Token 与连接实例绑定的 Token 5. **失效**: 连接断开或账号在别处登录时，Token 自动失效 ### 中间件白名单 以下路由不受中间件拦截，无需 Token 即可访问： * `User/Login` — 登录接口 * `Message/*` — 消息提示类接口（服务端主动推送的消息） > 白名单可在服务端 `Form1.RegRouter` 中通过 `MiddleWaresWhiteList.Add` 动态扩展。 *** ## 服务端主动向客户端推送 除了响应客户端请求外，服务端还可以通过以下方式主动推送消息： ### 单播（SendTo） ```vb Common.SendTo Inst, "Message/ShowToast", data ``` 向指定客户端发送消息。 ### 广播（SendToAll） ```vb Common.SendToAll Insts.TcpServer, "Notify/Show", data ``` 向所有在线客户端广播消息。 ### 踢人下线 ```vb If TcpServer.ExistsUser(UserName) Then Common.SendMsgbox TcpServer.GetClientByUser(UserName), "账号在另外一个地方登录", "下线通知" TcpServer.CloseUser UserName End If ``` *** ## 错误处理 服务端业务代码执行出错时，错误信息会通过 `Message/ShowMsgbox` 自动回传给客户端： ```vb On Error GoTo EH ' ... 业务逻辑 ... Exit Sub EH: Common.SendMsgbox Client, Err.Description, "内部错误" ``` 中间件拦截时也会发送 MsgBox： ```vb Common.SendMsgbox Client, "凭证验证失败", "中间件拦截" ``` --- --- url: /zh/packages/vbccr/system/commondialog.md description: 通用对话框控件（CommonDialog） - VBCCR 开发手册，基于源码的完整 API 参考 --- # 通用对话框控件（CommonDialog） 提供 Windows 标准对话框（打开、保存、颜色、字体、打印、帮助、页面设置、文件夹浏览、查找、替换）的封装类。 ## 枚举 ### CdlErrorConstants | 常量 | 值 | 说明 | |------|-----|------| | CdlCancel | 32755 | 用户选择了"取消" | | CdlBufferTooSmall | 20476 | 文件名缓冲区太小 | | CdlInvalidFileName | 20477 | 文件名无效 | | CdlSubclassFailure | 20478 | 子类化失败 | | CdlMaxLessThanMin | 24573 | 最小值大于最大值 | | CdlNoFonts | 24574 | 没有可用字体 | | CdlPrinterNotFound | 28660 | 未找到打印机 | | CdlCreateICFailure | 28661 | 创建信息上下文失败 | | CdlDndmMismatch | 28662 | DEVMODE 不匹配 | | CdlNoDefaultPrn | 28663 | 没有默认打印机 | | CdlNoDevices | 28664 | 没有打印设备 | | CdlInitFailure | 28665 | 打印对话框初始化失败 | | CdlGetDevModeFail | 28666 | 获取 DEVMODE 失败 | | CdlLoadDrvFailure | 28667 | 加载打印机驱动失败 | | CdlRetDefFailure | 28668 | 返回默认 DEVMODE 失败 | | CdlParseFailure | 28669 | 解析失败 | | CdlHelp | 32751 | 帮助请求 | | CdlBufferLengthZero | 36848 | 缓冲区长度为零 | ### CdlPRORConstants | 常量 | 值 | 说明 | |------|-----|------| | CdlPRORPortrait | vbPRORPortrait | 纵向 | | CdlPRORLandscape | vbPRORLandscape | 横向 | ### CdlPRPSConstants | 常量 | 值 | 说明 | |------|-----|------| | CdlPRPSLetter | vbPRPSLetter | Letter | | CdlPRPSLetterSmall | vbPRPSLetterSmall | Letter Small | | CdlPRPSTabloid | vbPRPSTabloid | Tabloid | | CdlPRPSLedger | vbPRPSLedger | Ledger | | CdlPRPSLegal | vbPRPSLegal | Legal | | CdlPRPSStatement | vbPRPSStatement | Statement | | CdlPRPSExecutive | vbPRPSExecutive | Executive | | CdlPRPSA3 | vbPRPSA3 | A3 | | CdlPRPSA4 | vbPRPSA4 | A4 | | CdlPRPSA4Small | vbPRPSA4Small | A4 Small | | CdlPRPSA5 | vbPRPSA5 | A5 | | CdlPRPSB4 | vbPRPSB4 | B4 | | CdlPRPSB5 | vbPRPSB5 | B5 | | CdlPRPSFolio | vbPRPSFolio | Folio | | CdlPRPSQuarto | vbPRPSQuarto | Quarto | | CdlPRPS10x14 | vbPRPS10x14 | 10x14 | | CdlPRPS11x17 | vbPRPS11x17 | 11x17 | | CdlPRPSNote | vbPRPSNote | Note | | CdlPRPSEnv9 | vbPRPSEnv9 | Envelope #9 | | CdlPRPSEnv10 | vbPRPSEnv10 | Envelope #10 | | CdlPRPSEnv11 | vbPRPSEnv11 | Envelope #11 | | CdlPRPSEnv12 | vbPRPSEnv12 | Envelope #12 | | CdlPRPSEnv14 | vbPRPSEnv14 | Envelope #14 | | CdlPRPSCSheet | vbPRPSCSheet | C Sheet | | CdlPRPSDSheet | vbPRPSDSheet | D Sheet | | CdlPRPSESheet | vbPRPSESheet | E Sheet | | CdlPRPSEnvDL | vbPRPSEnvDL | Envelope DL | | CdlPRPSEnvC5 | vbPRPSEnvC5 | Envelope C5 | | CdlPRPSEnvC3 | vbPRPSEnvC3 | Envelope C3 | | CdlPRPSEnvC4 | vbPRPSEnvC4 | Envelope C4 | | CdlPRPSEnvC6 | vbPRPSEnvC6 | Envelope C6 | | CdlPRPSEnvC65 | vbPRPSEnvC65 | Envelope C65 | | CdlPRPSEnvB4 | vbPRPSEnvB4 | Envelope B4 | | CdlPRPSEnvB5 | vbPRPSEnvB5 | Envelope B5 | | CdlPRPSEnvB6 | vbPRPSEnvB6 | Envelope B6 | | CdlPRPSEnvItaly | vbPRPSEnvItaly | Envelope Italy | | CdlPRPSEnvMonarch | vbPRPSEnvMonarch | Envelope Monarch | | CdlPRPSEnvPersonal | vbPRPSEnvPersonal | Envelope Personal | | CdlPRPSFanfoldUS | vbPRPSFanfoldUS | Fanfold US | | CdlPRPSFanfoldStdGerman | vbPRPSFanfoldStdGerman | Fanfold Std German | | CdlPRPSFanfoldLglGerman | vbPRPSFanfoldLglGerman | Fanfold Lgl German | | CdlPRPSUser | vbPRPSUser | 用户自定义 | ### CdlPRBNConstants | 常量 | 值 | 说明 | |------|-----|------| | CdlPRBNUpper | vbPRBNUpper | 上层纸盒 | | CdlPRBNLower | vbPRBNLower | 下层纸盒 | | CdlPRBNMiddle | vbPRBNMiddle | 中层纸盒 | | CdlPRBNManual | vbPRBNManual | 手动送纸 | | CdlPRBNEnvelope | vbPRBNEnvelope | 信封纸盒 | | CdlPRBNEnvManual | vbPRBNEnvManual | 信封手动送纸 | | CdlPRBNAuto | vbPRBNAuto | 自动送纸 | | CdlPRBNTractor | vbPRBNTractor | 连续送纸 | | CdlPRBNSmallFmt | vbPRBNSmallFmt | 小格式纸盒 | | CdlPRBNLargeFmt | vbPRBNLargeFmt | 大格式纸盒 | | CdlPRBNLargeCapacity | vbPRBNLargeCapacity | 大容量纸盒 | | CdlPRBNCassette | vbPRBNCassette | 盒式纸盒 | ### CdlPRPQConstants | 常量 | 值 | 说明 | |------|-----|------| | CdlPRPQHigh | vbPRPQHigh | 高质量 | | CdlPRPQMedium | vbPRPQMedium | 中等质量 | | CdlPRPQLow | vbPRPQLow | 低质量 | | CdlPRPQDraft | vbPRPQDraft | 草稿质量 | ### CdlPRCMConstants | 常量 | 值 | 说明 | |------|-----|------| | CdlPRCMMonochrome | vbPRCMMonochrome | 单色打印 | | CdlPRCMColor | vbPRCMColor | 彩色打印 | ### CdlPRDPConstants | 常量 | 值 | 说明 | |------|-----|------| | CdlPRDPSimplex | vbPRDPSimplex | 单面打印 | | CdlPRDPHorizontal | vbPRDPHorizontal | 双面水平翻转 | | CdlPRDPVertical | vbPRDPVertical | 双面垂直翻转 | ### CdlOFNConstants | 常量 | 值 | 说明 | |------|-----|------| | CdlOFNReadOnly | \&H1 | 显示只读复选框 | | CdlOFNOverwritePrompt | \&H2 | 覆盖文件前提示 | | CdlOFNHideReadOnly | \&H4 | 隐藏只读复选框 | | CdlOFNNoChangeDir | \&H8 | 不改变当前目录 | | CdlOFNHelpButton | \&H10 | 显示帮助按钮 | | CdlOFNNoValidate | \&H100 | 不验证文件名 | | CdlOFNAllowMultiSelect | \&H200 | 允许多选 | | CdlOFNExtensionDifferent | \&H400 | 扩展名不同 | | CdlOFNPathMustExist | \&H800 | 路径必须存在 | | CdlOFNFileMustExist | \&H1000 | 文件必须存在 | | CdlOFNCreatePrompt | \&H2000 | 创建文件提示 | | CdlOFNShareAware | \&H4000 | 忽略共享错误 | | CdlOFNNoReadOnlyReturn | \&H8000& | 不返回只读文件 | | CdlOFNNoNetworkButton | \&H20000 | 隐藏网络按钮 | | CdlOFNExplorer | \&H80000 | 使用资源管理器风格 | | CdlOFNNoDereferenceLinks | \&H100000 | 不解除快捷方式 | | CdlOFNDontAddToRecent | \&H2000000 | 不添加到最近使用 | | CdlOFNForcesShowHidden | \&H10000000 | 显示隐藏文件 | ### CdlOFNShareViResultConstants | 常量 | 值 | 说明 | |------|-----|------| | CdlOFNShareViResultWarn | \&H0 | 警告共享冲突 | | CdlOFNShareViResultNoWarn | \&H1 | 不警告共享冲突 | | CdlOFNShareViResultFallThrough | \&H2 | 忽略共享冲突 | ### CdlCCConstants | 常量 | 值 | 说明 | |------|-----|------| | CdlCCRGBInit | \&H1 | 使用初始颜色 | | CdlCCFullOpen | \&H2 | 完全打开对话框 | | CdlCCPreventFullOpen | \&H4 | 禁止完全打开 | | CdlCCHelpButton | \&H8 | 显示帮助按钮 | | CdlCCSolidColor | \&H80 | 仅纯色 | | CdlCCAnyColor | \&H100 | 任意颜色 | ### CdlCFConstants | 常量 | 值 | 说明 | |------|-----|------| | CdlCFScreenFonts | \&H1 | 屏幕字体 | | CdlCFPrinterFonts | \&H2 | 打印机字体 | | CdlCFHelpButton | \&H4 | 显示帮助按钮 | | CdlCFEffects | \&H100 | 启用效果选项 | | CdlCFApply | \&H200 | 启用应用按钮 | | CdlCFScriptsOnly | \&H400 | 仅脚本字体 | | CdlCFNoVectorFonts | \&H800 | 排除矢量字体 | | CdlCFLimitSize | \&H2000 | 限制字体大小 | | CdlCFFixedPitchOnly | \&H4000 | 仅等宽字体 | | CdlCFForceFontExist | \&H10000 | 字体必须存在 | | CdlCFScalableOnly | \&H20000 | 仅可缩放字体 | | CdlCFTTOnly | \&H40000 | 仅 TrueType 字体 | | CdlCFNoFaceSel | \&H80000 | 无字体名选择 | | CdlCFNoStyleSel | \&H100000 | 无样式选择 | | CdlCFNoSizeSel | \&H200000 | 无大小选择 | | CdlCFSelectScript | \&H400000 | 选择脚本 | | CdlCFNoScriptSel | \&H800000 | 无脚本选择 | | CdlCFNoVertFonts | \&H1000000 | 排除垂直字体 | ### CdlPDConstants | 常量 | 值 | 说明 | |------|-----|------| | CdlPDAllPages | \&H0 | 全部页面 | | CdlPDSelection | \&H1 | 选定范围 | | CdlPDPageNums | \&H2 | 页码范围 | | CdlPDNoSelection | \&H4 | 禁用选定范围 | | CdlPDNoPageNums | \&H8 | 禁用页码范围 | | CdlPDCollate | \&H10 | 逐份打印 | | CdlPDPrintToFile | \&H20 | 打印到文件 | | CdlPDPrintSetup | \&H40 | 显示打印设置 | | CdlPDNoWarning | \&H80 | 无警告 | | CdlPDReturnDC | \&H100 | 返回设备上下文 | | CdlPDReturnIC | \&H200 | 返回信息上下文 | | CdlPDReturnDefault | \&H400 | 返回默认打印机 | | CdlPDHelpButton | \&H800 | 显示帮助按钮 | | CdlPDUseDevModeCopies | \&H40000 | 使用 DEVMODE 副本数 | | CdlPDUseDevModeCopiesAndCollate | \&H40000 | 使用 DEVMODE 副本和逐份 | | CdlPDDisablePrintToFile | \&H80000 | 禁用打印到文件 | | CdlPDCurrentPage | \&H400000 | 当前页 | | CdlPDHidePrintToFile | \&H100000 | 隐藏打印到文件 | | CdlPDNoNetworkButton | \&H200000 | 隐藏网络按钮 | | CdlPDNoCurrentPage | \&H800000 | 禁用当前页 | ### CdlPDResultConstants | 常量 | 值 | 说明 | |------|-----|------| | CdlPDResultCancel | \&H0 | 用户取消 | | CdlPDResultPrint | \&H1 | 用户打印 | | CdlPDResultApply | \&H2 | 用户应用 | ### CdlHelpConstants | 常量 | 值 | 说明 | |------|-----|------| | CdlHelpContext | \&H1 | 上下文帮助 | | CdlHelpQuit | \&H2 | 退出帮助 | | CdlHelpIndex | \&H3 | 帮助索引 | | CdlHelpContents | \&H3 | 帮助目录 | | CdlHelpHelpOnHelp | \&H4 | 关于帮助的帮助 | | CdlHelpSetIndex | \&H5 | 设置帮助索引 | | CdlHelpSetContents | \&H5 | 设置帮助目录 | | CdlHelpContextPopup | \&H8 | 弹出上下文帮助 | | CdlHelpForceFile | \&H9 | 强制帮助文件 | | CdlHelpKey | \&H101 | 关键字帮助 | | CdlHelpCommandHelp | \&H102 | 命令帮助 | | CdlHelpPartialKey | \&H105 | 部分关键字帮助 | ### CdlPSDConstants | 常量 | 值 | 说明 | |------|-----|------| | CdlPSDDefaultMinMargins | \&H0 | 默认最小边距 | | CdlPSDMinMargins | \&H1 | 允许设置最小边距 | | CdlPSDMargins | \&H2 | 允许设置边距 | | CdlPSDInThousandthsOfInches | \&H4 | 以千分之一英寸为单位 | | CdlPSDInHundredthsOfMillimeters | \&H8 | 以百分之一毫米为单位 | | CdlPSDDisableMargins | \&H10 | 禁用边距 | | CdlPSDDisablePrinter | \&H20 | 禁用打印机按钮 | | CdlPSDNoWarning | \&H80 | 无警告 | | CdlPSDDisableOrientation | \&H100 | 禁用方向 | | CdlPSDDisablePaper | \&H200 | 禁用纸张 | | CdlPSDReturnDefault | \&H400 | 返回默认设置 | | CdlPSDHelpButton | \&H800 | 显示帮助按钮 | | CdlPSDDisablePagePainting | \&H80000 | 禁用页面绘制 | | CdlPSDNoNetworkButton | \&H200000 | 隐藏网络按钮 | ### CdlBIFConstants | 常量 | 值 | 说明 | |------|-----|------| | CdlBIFReturnOnlyFSDirs | \&H1 | 仅返回文件系统目录 | | CdlBIFDontGoBelowDomain | \&H2 | 不浏览域以下 | | CdlBIFStatusText | \&H4 | 包含状态文本 | | CdlBIFReturnFSAncestors | \&H8 | 返回文件系统祖先 | | CdlBIFEditBox | \&H10 | 包含编辑框 | | CdlBIFValidate | \&H20 | 验证输入 | | CdlBIFNewDialogStyle | \&H40 | 新对话框样式 | | CdlBIFBrowseIncludeURLs | \&H80 | 包含 URL | | CdlBIFUseNewUI | \&H50 | 使用新 UI | | CdlBIFUAHint | \&H100 | 用户提示 | | CdlBIFNoNewFolderButton | \&H200 | 隐藏新建文件夹按钮 | | CdlBIFNoTranslateTargets | \&H400 | 不翻译目标 | | CdlBIFBrowseForComputer | \&H1000 | 仅浏览计算机 | | CdlBIFBrowseForPrinter | \&H2000 | 仅浏览打印机 | | CdlBIFBrowseIncludeFiles | \&H4000 | 包含文件 | | CdlBIFShareable | \&H8000& | 可共享 | | CdlBIFBrowseFileJunctions | \&H10000 | 浏览文件联结点 | ### CdlFRConstants | 常量 | 值 | 说明 | |------|-----|------| | CdlFRDown | \&H1 | 向下搜索 | | CdlFRWholeWord | \&H2 | 全字匹配 | | CdlFRMatchCase | \&H4 | 区分大小写 | | CdlFRFindNext | \&H8 | 查找下一个 | | CdlFRReplace | \&H10 | 替换 | | CdlFRReplaceAll | \&H20 | 全部替换 | | CdlFRHelpButton | \&H80 | 显示帮助按钮 | | CdlFRNoUpDown | \&H400 | 禁用方向选择 | | CdlFRNoMatchCase | \&H800 | 禁用大小写选择 | | CdlFRNoWholeWord | \&H1000 | 禁用全字选择 | | CdlFRHideUpDown | \&H4000 | 隐藏方向选择 | | CdlFRHideMatchCase | \&H8000& | 隐藏大小写选择 | | CdlFRHideWholeWord | \&H10000 | 隐藏全字选择 | ## 属性 ### Object ```vb Property Get Object() As Object ``` 返回对象自身的实例。 ### CancelError ```vb Property Get/Let CancelError() As Boolean ``` 指示用户选择"取消"时是否产生错误。 ### HookEvents ```vb Property Get/Let HookEvents() As Boolean ``` 指示对话框是否可以引发需要钩子回调的事件。 ### Tag ```vb Property Get/Let Tag() As String ``` 存储程序所需的附加数据。 ### hDC ```vb Property Get hDC() As LongPtr ``` 返回设备上下文句柄（只读）。 ### Flags ```vb Property Get/Let Flags() As Long ``` 返回/设置对话框选项标志。 ### DialogTitle ```vb Property Get/Let DialogTitle() As String ``` 设置对话框标题栏显示的字符串。 ### MaxFileSize ```vb Property Get/Let MaxFileSize() As Long ``` 返回/设置打开文件名的最大大小。 ### FileName ```vb Property Get/Let FileName() As String ``` 返回/设置所选文件的路径和文件名。 ### FileTitle ```vb Property Get FileTitle() As String ``` 返回所选文件的文件名（不含路径，只读）。 ### FileOffset ```vb Property Get FileOffset() As Integer ``` 返回从路径开头到文件名的零偏移量（只读）。 ### Filter ```vb Property Get/Let Filter() As String ``` 返回/设置对话框类型列表框中显示的过滤器。 ### FilterIndex ```vb Property Get/Let FilterIndex() As Long ``` 返回/设置默认过滤器索引。 ### InitDir ```vb Property Get/Let InitDir() As String ``` 返回/设置初始文件目录。 ### DefaultExt ```vb Property Get/Let DefaultExt() As String ``` 返回/设置默认文件扩展名。 ### Color ```vb Property Get/Let Color() As Long ``` 返回/设置所选颜色。 ### CustomColors ```vb Property Get/Let CustomColors() As Variant ``` 返回/设置用户可选择的自定义颜色。 ### FontName ```vb Property Get/Let FontName() As String ``` 返回/设置字体名称。 ### FontSize ```vb Property Get/Let FontSize() As Single ``` 返回/设置字体大小（磅值）。 ### FontBold ```vb Property Get/Let FontBold() As Boolean ``` 返回/设置粗体字体样式。 ### FontItalic ```vb Property Get/Let FontItalic() As Boolean ``` 返回/设置斜体字体样式。 ### FontStrikethru ```vb Property Get/Let FontStrikethru() As Boolean ``` 返回/设置删除线字体样式。 ### FontUnderline ```vb Property Get/Let FontUnderline() As Boolean ``` 返回/设置下划线字体样式。 ### FontCharset ```vb Property Get/Let FontCharset() As Integer ``` 返回/设置字体字符集。 ### FontWeight ```vb Property Get/Let FontWeight() As Integer ``` 返回/设置字体粗细（0=Don'tCare, 100=Thin, 200=ExtraLight, 300=Light, 400=Normal, 500=Medium, 600=SemiBold, 700=Bold, 800=ExtraBold, 900=Heavy）。 ### Min ```vb Property Get/Let Min() As Long ``` 返回/设置最小字体大小（字体对话框）或最小打印页范围（打印对话框）。 ### Max ```vb Property Get/Let Max() As Long ``` 返回/设置最大字体大小（字体对话框）或最大打印页范围（打印对话框）。 ### FromPage ```vb Property Get/Let FromPage() As Long ``` 返回/设置打印起始页。 ### ToPage ```vb Property Get/Let ToPage() As Long ``` 返回/设置打印终止页。 ### Orientation ```vb Property Get/Let Orientation() As CdlPRORConstants ``` 返回/设置打印方向。 ### PaperSize ```vb Property Get/Let PaperSize() As CdlPRPSConstants ``` 返回/设置打印纸张大小。 ### Copies ```vb Property Get/Let Copies() As Integer ``` 返回/设置打印份数。 ### PaperBin ```vb Property Get/Let PaperBin() As CdlPRBNConstants ``` 返回/设置默认送纸器。 ### PrintQuality ```vb Property Get/Let PrintQuality() As CdlPRPQConstants ``` 返回/设置打印分辨率。 ### ColorMode ```vb Property Get/Let ColorMode() As CdlPRCMConstants ``` 返回/设置打印机颜色模式。 ### Duplex ```vb Property Get/Let Duplex() As CdlPRDPConstants ``` 返回/设置双面打印模式。 ### PrinterDefault ```vb Property Get/Let PrinterDefault() As Boolean ``` 返回/设置用户选择是否更改默认打印机。 ### PrinterDefaultInit ```vb Property Get/Let PrinterDefaultInit() As Boolean ``` 返回/设置是否始终初始化默认打印机。 ### PrinterDriver ```vb Property Get/Let PrinterDriver() As String ``` 返回/设置非默认打印机驱动名称。 ### PrinterName ```vb Property Get/Let PrinterName() As String ``` 返回/设置非默认打印机设备名称。 ### PrinterPort ```vb Property Get/Let PrinterPort() As String ``` 返回/设置非默认打印机端口名称。 ### HelpFile ```vb Property Get/Let HelpFile() As String ``` 返回/设置与项目关联的帮助文件名。 ### HelpCommand ```vb Property Get/Let HelpCommand() As CdlHelpConstants ``` 返回/设置联机帮助类型。 ### HelpContext ```vb Property Get/Let HelpContext() As LongPtr ``` 返回/设置帮助主题的上下文 ID。 ### HelpKey ```vb Property Get/Let HelpKey() As String ``` 返回/设置标识帮助主题的关键字。 ### PageLeftMargin ```vb Property Get/Let PageLeftMargin() As Long ``` 返回/设置纸张左边距（设备单位）。 ### PageTopMargin ```vb Property Get/Let PageTopMargin() As Long ``` 返回/设置纸张上边距（设备单位）。 ### PageRightMargin ```vb Property Get/Let PageRightMargin() As Long ``` 返回/设置纸张右边距（设备单位）。 ### PageBottomMargin ```vb Property Get/Let PageBottomMargin() As Long ``` 返回/设置纸张下边距（设备单位）。 ### PageLeftMinMargin ```vb Property Get/Let PageLeftMinMargin() As Long ``` 返回/设置纸张最小左边距（设备单位）。 ### PageTopMinMargin ```vb Property Get/Let PageTopMinMargin() As Long ``` 返回/设置纸张最小上边距（设备单位）。 ### PageRightMinMargin ```vb Property Get/Let PageRightMinMargin() As Long ``` 返回/设置纸张最小右边距（设备单位）。 ### PageBottomMinMargin ```vb Property Get/Let PageBottomMinMargin() As Long ``` 返回/设置纸张最小下边距（设备单位）。 ### RootFolder ```vb Property Get/Let RootFolder() As Variant ``` 返回/设置文件夹浏览对话框的根文件夹。 ### FindWhat ```vb Property Get/Let FindWhat() As String ``` 返回/设置查找对话框的搜索字符串。 ### ReplaceWith ```vb Property Get/Let ReplaceWith() As String ``` 返回/设置替换对话框的替换字符串。 ### Action ```vb Property Let Action() As Integer ``` 设置要显示的对话框类型（只写，1=打开, 2=保存, 3=颜色, 4=字体, 5=打印, 6=帮助, 7=页面设置, 8=文件夹浏览, 9=查找, 10=替换）。 ## 方法 ### ShowOpen ```vb Public Function ShowOpen() As Boolean ``` 显示"打开"对话框。成功返回 True。 ### ShowSave ```vb Public Function ShowSave() As Boolean ``` 显示"保存"对话框。成功返回 True。 ### ShowColor ```vb Public Function ShowColor() As Boolean ``` 显示"颜色"对话框。成功返回 True。 ### ShowFont ```vb Public Function ShowFont() As Boolean ``` 显示"字体"对话框。成功返回 True。 ### ShowPrinter ```vb Public Function ShowPrinter() As Boolean ``` 显示"打印"对话框。成功返回 True。 ### ShowPrinterEx ```vb Public Function ShowPrinterEx() As Boolean ``` 显示"打印"扩展对话框（PrintDlgEx）。成功返回 True。 ### ShowHelp ```vb Public Sub ShowHelp() ``` 显示帮助。 ### ShowPageSetup ```vb Public Function ShowPageSetup() As Boolean ``` 显示"页面设置"对话框。成功返回 True。 ### ShowFolderBrowser ```vb Public Function ShowFolderBrowser() As Boolean ``` 显示"文件夹浏览"对话框。成功返回 True。 ### ShowFind ```vb Public Function ShowFind() As Boolean ``` 显示"查找"对话框。成功返回 True。 ### ShowReplace ```vb Public Function ShowReplace() As Boolean ``` 显示"替换"对话框。成功返回 True。 ## 事件 ### InitDialog ```vb Public Event InitDialog(ByVal Action As Integer, ByVal hDlg As Long) ``` 对话框完成初始化时发生。 ### Help ```vb Public Event Help(ByRef Handled As Boolean, ByVal Action As Integer, ByVal hDlg As Long) ``` 用户在对话框中点击帮助按钮时发生。 ### FileShareViolation ```vb Public Event FileShareViolation(ByVal FileName As String, ByRef Result As CdlOFNShareViResultConstants, ByVal hDlg As Long) ``` 在打开或保存对话框中用户点击确定且发生网络共享冲突时发生。 ### FileValidate ```vb Public Event FileValidate(ByVal FileName As String, ByVal FileTitle As String, ByVal FileOffset As Integer, ByRef Cancel As Boolean, ByVal hDlg As Long) ``` 在打开或保存对话框中用户点击确定时发生。 ### ColorValidate ```vb Public Event ColorValidate(ByRef RGBColor As Long, ByRef Cancel As Boolean, ByVal hDlg As Long) ``` 在颜色对话框中用户点击确定时发生。 ### FontApply ```vb Public Event FontApply(ByVal Flags As Long, ByVal FontName As String, ByVal FontSize As Single, ByVal FontBold As Boolean, ByVal FontItalic As Boolean, ByVal FontStrikethru As Boolean, ByVal FontUnderline As Boolean, ByVal FontCharset As Integer, ByVal RGBColor As Long, ByVal hDlg As Long) ``` 在字体对话框中用户点击"应用"按钮时发生。 ### FolderBrowserValidateFailed ```vb Public Event FolderBrowserValidateFailed(ByVal Text As String, ByRef Cancel As Boolean, ByVal hDlg As Long) ``` 在文件夹浏览对话框中用户输入无效名称时发生。 ### FindNext ```vb Public Event FindNext() ``` 在查找或替换对话框中用户点击"查找下一个"按钮时发生。 ### Replace ```vb Public Event Replace() ``` 在替换对话框中用户点击"替换"按钮时发生。 ### ReplaceAll ```vb Public Event ReplaceAll() ``` 在替换对话框中用户点击"全部替换"按钮时发生。 ## 代码示例 ### 基本用法 ```vb Private Sub cmdOpen_Click() Dim dlg As CommonDialog Set dlg = New CommonDialog dlg.Filter = "文本文件 (*.txt)|*.txt|所有文件 (*.*)|*.*" dlg.FilterIndex = 1 dlg.CancelError = True On Error GoTo Cancelled If dlg.ShowOpen() Then MsgBox "已选择: " & dlg.FileName End If Exit Sub Cancelled: If Err.Number = CdlCancel Then Exit Sub MsgBox "错误: " & Err.Description End Sub ``` ### 使用事件钩子 ```vb Private WithEvents dlg As CommonDialog Private Sub cmdFont_Click() Set dlg = New CommonDialog dlg.HookEvents = True dlg.Flags = CdlCFScreenFonts Or CdlCFEffects Or CdlCFLimitSize dlg.Min = 8 dlg.Max = 72 dlg.ShowFont End Sub Private Sub dlg_FontApply(ByVal Flags As Long, ByVal FontName As String, _ ByVal FontSize As Single, ByVal FontBold As Boolean, ByVal FontItalic As Boolean, _ ByVal FontStrikethru As Boolean, ByVal FontUnderline As Boolean, _ ByVal FontCharset As Integer, ByVal RGBColor As Long, ByVal hDlg As Long) Me.Font.Name = FontName Me.Font.Size = FontSize Me.Font.Bold = FontBold Me.Font.Italic = FontItalic End Sub ``` --- --- url: /zh/packages/vbccr/author.md description: 通用控件替代包【官方文档】 - VBCCR 开发手册，基于源码的完整 API 参考 --- # 通用控件替代包【官方文档】 本页文档翻译自官方作者写的文档，使用ai把原始的word文档转为md，然后ai翻译为中文。 翻译：（邓伟） ## 工具说明 注意：本文件适用于 StdEXE 工具 3.3 版。工具的更新日志见本文档末尾的表格。3.3 版增加了对 VBCCRxx.OCX（最高至 1.7 版）和 VBFLXGRDxx.OCX（最新为 1.6 版）的支持。 自 2012 年 11 月以来，VBForums 用户 Krool 一直在开发一套用于替换 Windows 通用控件的控件包。虽然很多人讨论过替换这些控件，但直到现在都没有人真正成功实现。Krool 主要凭借个人力量，在论坛中不断调试和收集反馈。2017 年中，Krool 又着手开发 MSFlexGrid 控件的替代品，虽然与其他替代控件类似，但他选择在论坛的独立主题中进行开发。 本包希望为您提供一些设置和使用这些控件的技巧，并指导您减少或消除对除自身代码以外的任何文件的依赖。 Krool 的控件会像下图一样出现在 VB6 的工具箱中。它们的使用方式与 VB6 内置控件完全一致，只需拖放到窗体或其他控件上即可。下方展示了可添加的控件。 这些新控件能为您和您的程序带来什么？ * 支持 Unicode。网上虽然能找到一些支持 Unicode 的控件，但 Krool 的两个包可以让您一次性获得 34 个 Windows 通用控件的 Unicode 支持。 * 功能增强，超越了 VB6 和 VBA 程序员多年来使用的常规控件。 * 支持主题（视觉样式），让您的程序拥有现代化外观，不再像 Windows 95 时代的风格。相关配置在本包中有简化说明。 * 控件可以嵌入到您的代码中，最终生成的 EXE 文件无任何依赖，仅需一个可执行文件，无需注册或安装（例如可直接从 U 盘运行）。也可以使用传统的 .OCX 控件文件，并通过“并排”方式让 .OCX 文件无需在用户电脑上注册，只需与程序放在同一文件夹即可。这两种方式都能让您的程序真正实现便携分发。 * Krool 的代码日益稳定，作者和用户社区也会持续提供问题解答和新功能建议。 * 本包包含了一份用户指南（即本文档），介绍控件包的整体用法，而非每个控件的详细用法。 * 附带了一个名为 OCX2StdEXE 的工具，帮助您及时获取最新控件，并支持在开发阶段使用 OCX 版本，最终编译时自动切换为 StdEXE 版本，实现无依赖的可执行文件。 * 生成的 EXE 文件完全自包含，无任何外部依赖。无需在用户电脑上安装，也无需随程序分发和注册 .OCX 控件文件。 * 在 IDE 中使用 Krool 的 StdEXE 控件（即非传统 .OCX 控件文件）并非完全安全，尽管 Krool 已尽力减少 IDE 崩溃风险。开发时建议使用 .OCX 版本，既安全又高效，最终编译时再用本工具切换为 StdEXE 版本，将所有控件嵌入程序，无需任何依赖。 * 在 IDE 中使用 StdEXE 控件不仅有稳定性风险，还会导致每次编译都要重新编译控件代码（以我电脑为例，使用 .OCX 版本编译典型程序只需 3 秒，而 StdEXE 版本需 25 秒）。开发阶段频繁编译会非常耗时。借助 OCX2StdEXE 工具，您可以在开发时用 .OCX 版本（速度快、稳定），最终编译时用 StdEXE 版本，兼得体积小和无依赖的优点。 ## 用户指南 Krool有一个包含大量功能的程序包,但程序员需要理解很多内容才能充分利用这些包。涉及的内容包括: * 安装 * 两种不同的方法:已编译的.OCX控件和嵌入程序中每次编译的控件。如何选择使用哪个版本以及为什么?您能否或应该同时使用两者? * 设置 * 如何设置频繁更新,以最小化错误修复和功能添加带来的频繁更新的麻烦。 * 必需的类型库。 * 您还需要什么来使用这些控件包? * 什么是视觉主题,我应该使用它们吗?如何使用? * "并排"是什么意思?我应该使用它吗,如何使用它? * 清单文件是什么,我应该使用它们吗,应该如何使用它们? ## 简介 VB6控件有两个版本。最简单的是控件的源代码在您的程序中,当您的代码编译时,控件的代码与之一起编译。控件的已编译代码成为您程序的一部分。您的程序是独立的,除了Windows中包含的文件外,不依赖于任何外部文件来运行,也不需要将任何文件复制到用户的PC上或在用户的PC上注册。这种方法的缺点是,当您在开发程序时,每次编译代码时都必须编译控件的代码。此外,大多数编写控件的公司不希望放弃他们的代码,所以他们不会分发每个控件的源代码。因此,这种制作控件的方法并不常见。 另一种方式是将一个或多个控件编译到扩展名为OCX的文件中(代表OLE控件扩展或ActiveX控件)。使用OCX文件的程序员永远不会看到源代码,而且代码不需要一遍又一遍地编译。这种类型的控件包的一个缺点是,控件不是程序的一部分,必须发送给每个最终用户,而且由于超出本文档范围的原因,OCX文件必须在每个用户的计算机上注册(我们稍后会讲到并排)。 Krool在2012年底发布了通用控件替代品的第一个版本。这些是源代码的未编译版本,您会将其包含在代码中。他称这个版本为StdEXE,这可能意味着这些控件的标准版本被编译到您的EXE文件中。大约5年后(2017年1月),他开始提供相同的控件,但是采用预编译的OCX版本。所以现在我们程序员可以两种形式使用相同的控件。 没有关于如何使用每个控件的用户指南,但由于每个控件都是其他通用控件的增强替代品,可以说这种手把手的指导对于大多数非常资深的VB6程序员来说并不需要。然而,这些控件集的其他几个方面如果没有一些支持,会使它们比必要的更难完全使用。希望本文档能解决其中的一些问题。 在Krool开发了他的通用控件包之后,他决定添加另一个在他的包中遗漏的控件,即MSFlexGrid控件的替代品。他决定,尽管它与第一个包有很多共同点,但它是一个单独的包,可以与原始包一起使用,但可能会令人困惑。 当使用任一组控件的StdEXE版本时,您需要在IDE中使用一个类型库,"OLEGuids和接口定义"。此外,当使用FlexGrid控件的StdEXE版本时,还需要另一个类型库。OCX版本不需要类型库,因为它们实际上包含在OCX文件中。 Krool控件的一个主要优势是它们设计时就考虑到了使用"视觉样式"的能力,这样您的程序就不会看起来像来自Windows 95。但是,为了使用这些样式,您需要知道如何打开这个功能,对我们许多人来说这并不直观。不过,一旦打开,它确实令人印象深刻。 如果您使用控件的OCX版本,您必须将OCX文件与您的程序一起分发给用户。在VB6出现之前,Windows的设计是这样的:这些预编译的控件、动态链接库、设备驱动程序等都会在每个用户的系统上注册,每个版本(据说是最新的)只会在每个用户的系统上存在一个,这样一旦安装和注册,许多程序就可以使用相同的注册代码。这样设计是为了节省硬盘空间、减少内存使用等,但它造成的问题比解决的问题还多。到VB6出来的时候,一个新的系统已经设计出来并正在实施,它使程序能够使用集中注册的文件,或者让程序拥有自己的支持文件,这些文件不会复制到中央存储库(Windows系统文件夹)并注册,而是与程序"并排"放在一起。如果您使用StdEXE版本的控件,则不需要这个(至少对于这些控件来说),因为所有代码都编译到您的代码中,但如果您使用OCX版本,这个并排解决方案可能是可取的,因为它使您能够分发不需要安装且没有必须安装和注册的组件的程序。 如果您使用StdEXE版本的控件,没有"版本"之说,当Krool发布更新时,您只需将新文件复制到旧文件上即可继续。但是,OCX版本确实有版本(就像所有预编译代码一样,请参见上面的长段落),修改每个程序以使用较新版本并不是一件小事。我的工具可以为您处理这个问题。 由于Krool同时提供了控件的OCX和StdEXE版本,因此可以通过使您能够在开发过程中使用OCX版本(更易于使用且编译时间更短)来改善您的编程体验,但随后使用StdEXE版本进行最终编译,以将所有控件代码包含在程序中,这样就不需要将OCX文件包含在程序中,您也不必处理并排的复杂性。我的工具也可以为您处理这个问题。 ## 概述 每组控件都有两个版本;一个是具有OCX扩展名的单个文件,其中包含控件的预编译版本。这需要在您(程序员)的计算机上注册。它可以在VBForums上[这里](https://www.vbforums.com/showthread.php?698563-CommonControls-\(Replacement-of-the-MS-common-controls\))找到。 您在程序中引用它,然后就可以访问所有控件。从程序员的角度来看这很简单,但是当您分发完成的EXE或DLL文件时,您必须包含OCX文件。此外,此文件需要是"并排"解决方案的一部分,或者需要复制到用户的PC上并注册。 另一种方法Krool称之为StdEXE版本。在这个版本中,所有代码都在一个大型文件组中(当前在38个文件夹中有162个),这些都是未编译的,必须作为模块添加到您的程序中。此包的最新版本可以在VBForums上[这里](https://www.vbforums.com/showthread.php?698563-CommonControls-\(Replacement-of-the-MS-common-controls\))找到。 每次编译程序时,所有这些控件也会被编译。即使知道哪些文件要包含在程序中以用于哪些控件也是一个大麻烦,子程序、函数和变量的某些名称可能与您使用的名称冲突,并且每次编译所有这些控件代码都需要很长时间。我的电脑相当快,但仅仅编译Krool提供的ComCtlsDemo程序就需要超过25秒。在VB6中编码时我经常编译,部分原因是只是为了检查语法和逻辑错误,而25+秒的编译时间是非常令人恼火的,特别是当我知道我可以在OCX版本中在3秒内编译相同的代码时。我喜欢最终可执行文件中没有外部依赖项的事实,但我讨厌编译时间。要是有办法可以在开发过程中使用OCX版本及其快速的编译时间,但在最终编译时使用内部控件,这样就不需要有单独的OCX文件与程序一起分发就好了。我的工具就是这样做的。 此外,这些控件有许多更新。未编译文件(StdEXE版本)实际上没有版本号,只要您将最新文件复制到相同位置的早期文件上,就不会有任何问题。然而,OCX版本并非如此。我将我的放在C:\Windows\SysWOW64中,只要我们有相同的版本,我们就可以将新的OCX文件复制到旧的文件上。但随着时间的推移,已经添加了新功能,所以我们有了1.1、1.2、1.3、1.4、1.5、1.6和现在的1.7版本。如果您使用1.6版本的控件开发了一个程序,那么使用1.7版本的控件时会遇到问题,因为需要对使用Krool控件的每个项目文件、每个控件文件以及清单文件(如果您使用的话)进行更改。我的工具可以处理这些问题,允许您从任何OCX版本切换到安装在PC上的CommonControls的任何其他OCX版本(包括独立的FlexGrid控件)。 ## 包含的控件 以下是Krool包中的控件列表。除了VBFlexGrid(在VBFlexGrid Control包中)外,所有控件都在Common Controls替代包中。 | | | | | | ------------------------ | ---------------------- | ----------------------- | --------------------------- | | Animation(动画) | FrameW(框架) | MCIWnd(多媒体) | SysInfo(系统信息) | | CheckBoxW(复选框) | HotKey(热键) | MonthView(月历) | TabStrip(标签条) | | ComboBoxW(组合框) | ImageCombo(图像组合框) | OptionButtonW(选项按钮) | TextBoxW(文本框) | | CommandButtonW(命令按钮) | ImageList(图像列表) | Pager(分页器) | ToolBar(工具栏) | | CommandLink(命令链接) | IPAddress(IP地址) | ProgressBar(进度条) | TreeView(树形视图) | | CommonDialog(通用对话框) | LabelW(标签) | RichTextBox(富文本框) | UpDown(上下调节器) | | CoolBar(冷工具栏) | LinkLabel(链接标签) | Slider(滑块) | VirtualBoxCombo(虚拟组合框) | | DTPicker(日期时间选择器) | ListBoxW(列表框) | SpinBox(数值调节器) | VListBox(虚拟列表框) | | FontCombo(字体组合框) | ListView(列表视图) | StatusBar(状态栏) | VBFlexGrid(灵活网格) | 如果您有任何编程经验,您无疑已经看到并使用过这些控件中的许多。一旦安装好Krool的系统,使用起来相当容易,因为控件的行为与现有控件非常相似。我们主要讨论如何安装和设置每个系统以供使用。 ## 术语 Krool的控件很棒,但在他的包内部和周围使用的许多术语可能会令人非常困惑(至少对我来说是这样)。以下是我对一些术语的解释。 **ActiveX** - 维基百科[文章](https://en.wikipedia.org/wiki/ActiveX)。这是Microsoft在1996年使用早期OLE和COM技术制定的软件框架。对于本文档,我们将把ActiveX视为我们控件的基础。 **Control(控件)** - 在工具箱中由图标表示的组件,可以放置在窗体上。大多数是可见的,但有些(如计时器)是不可见的。VB6中最简单的控件包含在已安装的VB6程序包中。其他的,如Krool的控件和来自Microsoft和其他供应商的许多控件,必须添加。有关制作自己的控件的更多信息,请参见[这个](https://pages.cpsc.ucalgary.ca/~saul/vb_examples/index.html)网页,特别是教程#10。 **OCX** - 通常,我们都使用已预编译到扩展名为.OCX的文件中的控件(代表OLE控件扩展或ActiveX控件)。这些文件必须在开发人员的PC上注册,并且必须分发给开发人员程序的每个用户并在其PC上注册。一个.OCX文件可以包含多个控件。程序员(您)需要在其系统上安装并注册OCX,但用户也需要在其系统上拥有OCX文件,通常是注册的,但有时是与正在运行的已编译程序"并排"使用该OCX控件。 **StdEXE** - Krool使用这个术语来指定在程序中包含ActiveX控件的另一种方法。有许多源代码文件,包括标准模块和类模块、属性页文件等,它们被编译成OCX控件。另外,所有这些都可以由作者分发并作为源代码放入我们每个程序中。通常,控件包的作者出于各种原因不想分发其控件的源代码,但Krool选择对他的包这样做。这样做的好处是您的程序中包含了所有编译在其中的控件代码,因此不需要分发或注册文件就可以使它工作。所有内容都包含在您编译的代码中。从程序员的角度来看,这样做的一个缺点是,在开发程序并一遍又一遍地编译时,所有控件代码都必须重新编译。 **VBCCRxx** - VBCCR代表Visual Basic Common Controls Replacement(Visual Basic通用控件替代品),而"xx"指的是OCX版本,目前可以是1.1(xx=11)、1.2、1.3、1.4、1.5或1.6(xx=16)。随着以编译形式分发的代码随时间的推移被修改和扩展,作者(Krool)必须发布不同的版本,每个版本都必须在用户的PC(和程序员的PC)上存在。例如,假设您编写了一个使用VBCCR16.ocx的程序,并将其发送给一个安装了VBCCR13.ocx但没有VBCCR16.ocx的同事。它将无法运行,因为它在启动时会寻找其他ocx文件。这就是OCX文件的缺点。如果您使用StdEXE版本,代码会直接编译到您的代码中,您不必分发、安装或注册任何外部文件即可使用控件。OCX版本相对于StdExE版本的主要优点是a)程序的编译时间几乎快10倍,因为每次不需要重新编译窗体代码,b)构成每个控件的各种.BAS、.CTL、.PAG文件不会使程序员的文件列表变得混乱。 **ComCtlsDemo** - 这是一个展示Krool每个控件的示例程序。这个文件会定期更新,总是可以在VBForums上[这个](http://www.vbforums.com/showthread.php?698563-CommonControls-\(Replacement-of-the-MS-common-controls\))主题的第一个帖子底部找到。这个包使用StdEXE概念,将所有控件的代码编译到可执行文件中。 这不仅仅是一个示例文件。这个文件中的源代码就是他的包的全部内容,当您制作自己的使用他的控件的程序时,您将使用它(或其中的大部分)。 它不像OCX版本那样需要版本号,因为没有文件需要在开发人员或用户的PC上注册(它是每次编译程序时都要嵌入的源代码)。我下载了大多数更新,为了避免混淆,我将每个.zip文件重命名为我硬盘上带有文件日期的文件名。由于VBForum的大小限制,他发布的文件带有.docx扩展名,但它实际上是一个.zip文件,所以当您下载它时,您要执行另存为并删除文件名中的.docx。在撰写本文时,Krool发布的最新版本是2018年11月11日(看看帖子底部下载链接下方的小斜体行),要下载的文件名为ComCtlsDemo.zip.docx,所以当我下载该文件时,我在我的硬盘上将其重命名为ComCtlsDemo 2018-11-11.zip。 **VBCCR OCX版本** - 在只有StdEXE版本大约4年之后,Krool发布了一个名为VBCCRxx.OCX的预编译版本,其中xx是版本号。最早的版本是1.1,所以第一个文件是VBCCR11.ocx。截至本文撰写时,最新版本是1.6.13,所以文件是VBCCR16.ocx。最新版本总是在VBForums上[这个](http://www.vbforums.com/showthread.php?841929-VB6-ActiveX-CommonControls-%28Replacement-of-the-MS-common-controls%29\&p=5129155#post5129155)主题的第1个帖子底部。在线.zip文件包含.ocx文件以及一些资源文件(下面讨论),这些文件与程序员的EXE文件的"并排"执行以及使您的程序主题化(这样您在屏幕上显示的内容看起来不像来自Windows 95)有关。我保存.zip文件时将其重命名以包含版本号。例如,最新的一个叫做'VBCCR16.OCX.rar.docx'被复制到我的硬盘上,名为'VBCCR.OCX v1.6.13.rar'(请参见上面关于为什么文件带有.docx扩展名的说明)。除了包含.ocx文件外,.zip文件还包含所有代码,以防您想要制作自己的.ocx文件(不推荐)或只是从Krool所做的工作中学习。 将.ocx文件复制到Windows系统文件夹中。如果运行32位Windows,这通常是C:\Windows\System32,但如果运行64位Windows,那么所有64位DLL、类型库和控件都进入system32文件夹(?),因此Microsoft将所有32位文件放入名为'SysWOW64'(**W**indows 32-bit **O**n **W**indows **64**-bit)的文件夹中。(如果您将Windows放在C:\Windows以外的位置,那么请使用该路径)。由于您要复制到系统文件夹,因此需要提升权限。如果xx相同(在我的示例中xx是16,所以我可以覆盖1.6.12或1.6.11版本),那么可以覆盖以前的版本,如果xx是新的(如1.6.0版本),那么没有覆盖,但您应该使用regsvr32向系统注册此控件。 在VB6 IDE中使用Ctrl-T(或Project|Components)并选择适当的控件,将此OCX文件加载到您的项目中。对于1.6版本,您需要通过单击旁边的复选标记来选择'VB Common Controls Replacement 1.6 Library'。 通过引用此OCX,所有控件都将显示在工具箱中,供您像使用可以放在窗体上的任何其他控件一样使用。因为控件的.OCX版本是预编译的,所以控件不会像使用StdEXE版本那样在每次编译程序时编译,在StdEXE版本中,控件会嵌入到您的代码中。另一方面,缺点是.OCX文件必须随EXE或DLL文件一起分发,因为它没有编译到其中。 **Type Library(类型库)** - 要在StdEXE版本(不是OCX版本)中使用Krool的VBCCR和VBFlexGrid控件,您需要使用他提供的名为'OLEGuids.tlb'的类型库,该库在他随每个控件包分发的'OLDGuids'文件夹中。我将oleguids.tlb复制到我的系统目录中,然后可以使用Project|References通过单击'OLE Guid and interface definitions'旁边的复选框来指定它。他目前分发的文件带有2017年6月9日的日期戳,所以它已经有一段时间没有改变了。此文件仅在使用StdEXE版本进行代码开发时才需要。它不需要与最终编译的程序一起分发。(注意-如果您在VBA中使用Krool的控件,则***不***需要此文件,因为您必须使用已经将此类型库编译到其中的OCX版本。) **Visual Styles(视觉样式)(主题)** - 这从XP就开始了,但直到Vista及以后才真正得到广泛使用。使用视觉样式,您可以获得更现代的窗体外观,但由于这些样式是在VB6推出之后才流行起来的,所以在VB6程序中使用它们并没有简单的方法。Krool的代码设置为使用这些视觉样式,但如果没有几个有趣的步骤,您将无法获得它们。无论如何,他的代码与原始控件相比提供了Unicode和一些增强功能,但要获得视觉样式,您必须在清单中指定这一点,然后将清单嵌入到程序引用的资源文件中。这听起来比实际操作要难,我稍后会介绍如何做到这一点。(注意- VBA不支持样式) **Side-by-Side Assemblies(并排程序集)** - 如果您的程序需要DLL或OCX文件才能运行,它可以使用已经存在于用户系统上、已注册且版本正确的文件。从VB6发布时起,就有一个运动要摆脱这个系统,以避免许多人称之为"DLL地狱"的情况(谷歌一下这个词会很有趣)。长话短说,Windows允许程序在不必注册支持文件的情况下运行,只要支持文件位于EXE或DLL文件旁边(或其子文件夹中)即可。许多企业用户通过阻止注册这些支持文件来设置他们的PC不允许安装任何新程序,这是一种解决方法。为了指定支持文件是并排的,您必须在清单中指定这一点(见下文)。以前,将清单放在可执行文件的同一文件夹中或嵌入到文件中是可以的,但后来的Windows版本强烈建议将清单文件包含在资源文件中。这一切听起来很疯狂,但Krool为所有的复杂性提供了一些支持,而我的工具(希望)可以消除其余部分的痛苦。 **Manifest File(清单文件)** - 清单文件基于XML,可以为Windows指定许多要执行的事情来控制程序。一个例子是,您可以在清单中指定程序需要以提升的权限运行。但是,对于我们的情况,清单文件有两个用途:1)我们可以告诉Windows我们想要使用Microsoft的CommonControls dll文件的6.0版本,这是使用Krool代码给我们视觉样式的版本,2)我们可以给出信息,使OCX文件(如果您使用它而不是StdEXE版本)与您将制作的可执行文件并排。这本身就够糟糕的,但Windows现在希望这个清单文件包含在程序的资源文件中。 **Resource File(资源文件)** - 您可以将许多内容放入VB6资源文件(扩展名.RES)中,包括图标、图形图像、国际化字符串等。您还可以放入清单文件,而且您会这样做以获得视觉样式和/或并排功能。Krool在OCX版本中提供了两个资源文件,一个仅用于并排,一个用于并排加视觉样式。在StdEXE包中,Resources文件夹中有一个提供视觉样式的资源文件(如果不使用.OCX版本,则不需要并排)。一个名叫LaVolpe的用户在VBForums上有一个工具([这里](http://www.vbforums.com/showthread.php?845909-VB6-Manifest-Creator-II)),使您能够从资源文件中提取清单信息,编辑它,然后把它放回去。希望您不必使用该工具(我在我的工具中使用了LaVolpe代码的一部分,稍后会讨论)。在这里定义它的要点是确保程序员知道并排和视觉样式需要指定资源文件,而资源文件需要在内部指定这些。 **Windows System Folder(Windows系统文件夹)** - Windows系统文件夹包含许多系统相关文件,包括DLL、类型库、注册控件等。对于32位VB6和32位VBA,此文件夹可以是两个中的一个。如果您使用32位操作系统,此文件夹将是'C:\Windows\System32'。不幸的是,如果您使用64位Windows操作系统,所有64位DLL、类型库和控件都进入system32文件夹(?),因此Microsoft将所有32位文件放入名为'SysWOW64'(**W**indows 32-bit **O**n **W**indows **64**-bit)的文件夹中。所有32位文件都进入'C:\Windows\SysWOW64'。 如果您在64位VBA中使用所有这些,您只会处理64位Windows文件夹,该文件夹始终是'C:\Windows\System32'。 **VBFlexGrid** - Krool的原始控件包括35个控件,但不包括MSFlexGrid控件的替代品(Microsoft提供了一个MSFLXGRD.OCX文件,Krool的包对其进行了升级和替换)。他采取的方法与他对其他控件所做的非常相似。有独立版本,就像VBCCR ComCtlsDemo包一样,这个叫做VBFlexGridDemo,可以在[这里](http://www.vbforums.com/showthread.php?848839-VBFlexGrid-Control-\(Replacement-of-the-MSFlexGrid-control\))找到,以及它对应的OCX版本,VBFLXGRD12.OCX,可以在[这里](http://www.vbforums.com/showthread.php?855931-VB6-ActiveX-VBFlexGrid-%28Replacement-of-the-MSFlexGrid-control%29\&p=5236525#post5236525)找到。这两个版本都独立于VBCCRxx控件。我的工具将这些和VBCCR控件视为同一个包的一部分来处理。 ## 程序员用户指南 下面是每个版本的使用说明。之后是我推荐的使用方法的讨论,这是每个选项的简单混合,它(希望)利用了每个选项的最佳功能,然后还有一些其他功能。 VBCCR - 这组33个控件(除了最后一个之外的表中的所有控件)存在两个版本。到目前为止,程序员必须决定是使用StdEXE还是OCX版本;没有办法同时使用这两个版本。在介绍两个版本的用户指南之后,我将向您展示另一种希望更好的使用这些控件的方法,这样您就可以利用OCX版本更简单和更快的开发优势,同时用StdEXE版本生产最终的可执行文件,使控件成为您控制代码的一部分。 ### VBCCR - StdEXE版本 这是将所有控件代码编译到程序中的版本。您将在程序中包含适当的源代码,当您编译时,控件成为程序的一部分。 获取最新版本 - 您可能会认为有一个可下载的包,其中包含所有控件、用户指南等,但事实并非如此。Krool在VBForums网站上有一个演示项目,从中您可以访问他的所有控件(有趣的方法,但它确实有效)。Krool的演示项目和所有控件从2012年11月10日起就在[这里](http://www.vbforums.com/showthread.php?698563-CommonControls-\(Replacement-of-the-MS-common-controls\))。该主题中有超过78页的评论和讨论。大多数涉及各种错误、用户问题和功能添加请求,因为Krool在过去9年中一直在处理这个包。 重要的是,在第一个帖子的底部有一个名为'**ComCtlsDemo.zip.docx**'的可下载文件,这始终是要下载的最新版本。它具有.DOCX扩展名,因为VBForums对.ZIP文件的大小限制比.DOCX文件低,而此文件超过了.ZIP文件的大小限制。它实际上是一个.ZIP文件,所以当您下载它时(或之后),通过去掉名称的.DOCX部分来重命名它,留下文件ComCtlsDemo.zip。 这个文件在网站上的名称始终相同。我建议您查看第一个帖子的最后一行并注意日期,然后将日期放在文件名中。例如,我正在查看第一个帖子,在底部它说Krool在2018年11月11日最后编辑,所以当我右键单击链接时,我告诉它将其保存到一组我保存所有下载存档文件的文件夹中,我用名称'**ComCtlsDemo 2018-11-11.zip**'保存它,这样我就可以将其与之前下载的副本区分开。 现在有一个重要的观察。ComCtlsDemo包含所有控件文件,这些文件不应该被更改,所以您可以将这些文件放在所有程序都可以访问的中心位置(一个库)。这个位置不需要改变,您总是可以删除现有文件并将最新版本的文件放在相同的文件夹中。此外,您的所有程序都可以在它们所在的位置访问所有这些文件,因此您不需要将所有这些文件复制到您的个人项目文件夹中。这大大简化了使用和更新较新版本的过程。 解压时将下载的文件放在哪里 - 我有一个库文件夹,我将各种可在程序中使用的文件放在其中。我不会在这里放置会更改的文件。这包含我可以在所有程序中使用的文件,而不需要修改。在我的Library文件夹中,我有一个用于Controls & Forms的子文件夹。在其中,我有一个名为VBCCR的文件夹,用于Krool的控件,在其中我创建了一个名为'Current'的子文件夹。每当我从Krool下载最新更新时,我首先删除Current中的所有文件和文件夹,然后将新文件解压到Current中。这很重要,因为已经使用这些控件的程序将继续在相同的位置找到这些控件,甚至不知道它们是新版本。幸运的是,Krool在调试和添加控件功能时保持他的文件和文件夹名称相同。 所以现在我们在PC上的一个位置有了文件,我们可以将它们用于所有程序,我们就可以开始使用它们了。对吗?嗯,差不多。为了使用他的控件,还需要采取一些额外的步骤。请按照以下步骤操作,以创建或修改任何程序。 类型库 - 您需要能够访问一个名为'OLEGuids.tlb'的类型库,该库包含在Krool的示例程序中。这个文件在Current的一个名为'OLEGuids'的子文件夹中。在编辑和编译期间您需要这个文件,但您编译的程序不需要它,您也不用将它与可执行文件一起分发。我将我的放入Windows系统文件夹中,这样我总是知道它在哪里,我在Windows 10中用regsvr32注册它。幸运的是,这个类型库文件不经常更改,所以您不必经常执行此步骤。OLEGuids.tlb的日期是2017年6月9日,所以18个月来它没有改变。 在VB6中,您将使用Project | References命令来选择这个类型库。如果您已经使用regsvr32注册了这个文件,那么您可以在Available References列表中找到名为'OLE Guid and interface definitions'的文件,但如果您还没有注册它,您可以单击'Browse'并找到它。 视觉样式 - 为了在程序中使用视觉样式(主题),使它们看起来不像旧的Windows程序,您必须指定使用Windows Common Controls库版本6.0,因为它支持视觉样式。实现这一点的方法是在清单文件中包含这个规范。过去,您制作一个包含可执行文件名称且扩展名为'.Manifest'的文件,当分发程序时,您将此文件包含在与可执行文件相同的文件夹中。后来的Windows版本不鼓励这样做,而是建议将清单作为嵌入资源文件的一部分包含在EXE文件中。VB6可以使用资源文件来保存许多不同的内容,如国际化字符串、图标等,除了清单之外。 所以我们必须将视觉样式规范放入清单中,然后将清单文件放入VB6资源文件中。在Krool的包中,查看Current\Resources中名为'Resources.res'的文件,这是Krool制作的包含启用视觉样式(或主题)指令的资源文件。如果您没有将资源文件用于其他任何内容,您可以简单地将这个Resources.res文件复制到项目文件(.VBP)所在的位置。稍后我会向您展示如何将其嵌入到您的项目中。但现在让我们考虑一下如果您已经有一个资源文件,我们想要将我们的清单信息添加到该资源文件中(无论它是否已经包含清单信息)该怎么办。 请注意,VB6 IDE并不是为了使用视觉样式而设计的。[这里](http://www.vbforums.com/showthread.php?693111-VB6-IDE-solving-UAC-and-Visual-Style-issues\&highlight=)是Krool在VBForums上的一个帖子,展示了如何获取带有嵌入清单的资源文件,该文件将以提升的UAC运行VB6,同时合并视觉样式。您不需要这个来使用Krool的控件,但如果您想看到"更漂亮的"窗体,那么这对您可能有价值。请注意,它涉及使用另一个名为ResourceHacker的工具将资源文件放入VB6.EXE文件中。 一个更简单的方法是从[这里](http://www.vbaccelerator.com/home/VB/Code/Libraries/XP_Visual_Styles/Using_XP_Visual_Styles_in_VB/article.asp)获取vb6.exe.manifest文件,并将其放入与vb6相同的文件夹中(通常是C:\Program Files (x86)\Microsoft Visual Studio\VB98)。 关于在程序中使用视觉样式,我觉得很奇怪的是使用视觉样式的说明是清单文件的一部分,我们必须将其嵌入到资源文件中,然后将其嵌入到我们的可执行文件中。Krool在Current下的Resources文件夹中提供了一个带有视觉样式的资源文件,您可以将其复制到您的项目中并嵌入。 高级资源/清单/视觉样式注意事项 - 您可能希望在资源文件中添加视觉样式设置之外的其他内容。处理这些文件并不是一件小事。清单部分是XML,它包含在非XML资源文件中。我在VBForums上发现了另一个由名为LaVolpe的用户提供的工具([这里](http://www.vbforums.com/showthread.php?845909-VB6-Manifest-Creator-II)),让我们可以从头开始或从清单文件中创建或编辑清单,或从资源文件中提取,这样我们就可以编辑它,然后我们可以指定将其放入资源文件中。下面是LaVolpe的工具运行时加载Resources.res的屏幕截图。我突出显示了指定使用Windows Common Controls版本6.0.0.0的部分。这就是指定视觉样式的内容。通常对于新程序,您应该能够只将Resources.res复制到您的项目文件夹并使用它,而无需编辑它。顺便说一句,您不*需要*这个文件,但如果没有它,您的程序中将不会获得任何现代外观的控件。 所以现在您有了一个指定使用视觉样式的资源文件。我们如何将它放入我们的项目中?在VB6中,转到AddIns | AddIn Manager,您将看到类似以下内容。 选择'VB6 Resource Editor',并确保'Loaded/Unloaded'和'Load On Startup'都被选中。然后,回到您的主项目,转到Project | Add New Resource File,然后从弹出的对话框中选择您的.res文件。现在您的资源文件应该在导航窗格中的Related Documents下显示出来。 Side-by-Side(并排) - 使用StdEXE版本的一个原因是,除非您使用其他专门的控件或其他文件,否则您的可执行文件没有依赖项,因此无需担心并排。我将在OCX版本的用户指南中详细讨论它。 要包含在您的项目中的文件 - 每个控件都有一些特定于该控件的文件,需要如下所示插入到您的项目中。 | **控件** | **Current文件夹中的文件** | | ---------------------------------------------- | --------------------------------------------------------------------------- | | Animation(动画) | Builds\Animation\Animation.ctl | | | Builds\Animation\PPAnimationGeneral.pag | | CheckBoxW(复选框) | Builds\CheckBoxW\CheckBoxW.ctl | | ComboBoxW(组合框) | Builds\ComboBoxW\ComboBoxW.ctl | | CommandButtonW(命令按钮) | Builds\CommandButtonW\CommandButtonW.ctl | | CommandLink(命令链接) | Builds\CommandLink\CommandLink.ctl | | | Builds\CommandLink\PPCommandLinkGeneral.pag | | CoolBar(冷工具栏) | Builds\CoolBar\CbrBand.cls | | | Builds\CoolBar\CbrBandProperties.cls | | | Builds\CoolBar\CbrBands.cls | | | Builds\CoolBar\CoolBar.ctl | | | Builds\CoolBar\PPCoolBarBands.pag | | | Builds\CoolBar\PPCoolBarGeneral.pag | | DTPicker(日期时间选择器) | Builds\DTPicker\DTPicker.ctl | | | Builds\DTPicker\PPDTPickerGeneral.pag | | FontCombo(字体组合框) | Builds\FontCombo\FontCombo.ctl | | FrameW(框架) | Builds\FrameW\FrameW.ctl | | HotKey(热键) | Builds\HotKey\HotKey.ctl | | ImageCombo(图像组合框) | Builds\ImageCombo\ImageCombo.ctl | | | Builds\ImageCombo\ImcComboItem.cls | | | Builds\ImageCombo\ImcComboItems.cls | | | Builds\ImageCombo\PPImageComboGeneral.pag | | ImageList(图像列表) | Builds\ImageList\ImageList.ctl | | | Builds\ImageList\ImlListImage.cls | | | Builds\ImageList\ImlListImages.cls | | | Builds\ImageList\PPImageListGeneral.pag | | | Builds\ImageList\PPImageListImages.pag | | IPAddress(IP地址) | Builds\IPAddress\IPAddress.ctl | | LabelW(标签) | Builds\LabelW\LabelW.ctl | | LinkLabel(链接标签) | Builds\LinkLabel\LinkLabel.ctl | | | Builds\LinkLabel\LlbLink.cls | | | Builds\LinkLabel\LlbLinks.cls | | | Builds\LinkLabel\PPLinkLabelGeneral.pag | | ListBoxW(列表框) | Builds\ListBoxW\ListBoxW.ctl | | ListView(列表视图) | Builds\ListView\ListView.ctl | | | Builds\ListView\LvwColumnHeader.cls | | | Builds\ListView\LvwColumnHeaders.cls | | | Builds\ListView\LvwGroup.cls | | | Builds\ListView\LvwGroups.cls | | | Builds\ListView\LvwListItem.cls | | | Builds\ListView\LvwListItems.cls | | | Builds\ListView\LvwListSubItem.cls | | | Builds\ListView\LvwListSubItems.cls | | | Builds\ListView\LvwVirtualListItem.cls | | | Builds\ListView\LvwVirtualListItems.cls | | | Builds\ListView\PPListViewGeneral.pag | | | Builds\ListView\PPListViewImageLists.pag | | | Builds\ListView\PPListViewSorting.pag | | MCIWnd(多媒体窗口) | Builds\MCIWnd\MCIWnd.ctl | | MonthView(月历) | Builds\MonthView\MonthView.ctl | | | Builds\MonthView\PPMonthViewGeneral.pag | | OptionButtonW(选项按钮) | Builds\OptionButtonW\OptionButtonW.ctl | | Pager(分页器) | Builds\Pager\Pager.ctl | | | Builds\Pager\PPPagerGeneral.pag | | ProgressBar(进度条) | Builds\ProgressBar\PPProgressBarGeneral.pag | | | Builds\ProgressBar\ProgressBar.ctl | | RichTextBox(富文本框) | Builds\RichTextBox\PPRichTextBoxGeneral.pag | | | Builds\RichTextBox\RichTextBox.ctl | | | Builds\RichTextBox\RichTextBoxBase.bas | | Slider(滑块) | Builds\Slider\PPSliderAppearance.pag | | | Builds\Slider\PPSliderGeneral.pag | | | Builds\Slider\Slider.ctl | | SpinBox(数值调节器) | Builds\SpinBox\PPSpinBoxGeneral.pag | | | Builds\SpinBox\SpinBox.ctl | | StatusBar(状态栏) | Builds\StatusBar\PPStatusBarGeneral.pag | | | Builds\StatusBar\PPStatusBarPanels.pag | | | Builds\StatusBar\SbrPanel.cls | | | Builds\StatusBar\SbrPanelProperties.cls | | | Builds\StatusBar\SbrPanels.cls | | | Builds\StatusBar\StatusBar.ctl | | SysInfo(系统信息) | Builds\SysInfo\SysInfo.ctl | | TabStrip(标签条) | Builds\TabStrip\PPTabStripGeneral.pag | | | Builds\TabStrip\PPTabStripTabs.pag | | | Builds\TabStrip\TabStrip.ctl | | | Builds\TabStrip\TbsTab.cls | | | Builds\TabStrip\TbsTabs.cls | | TextBoxW(文本框) | Builds\TextBoxW\PPTextBoxWText.pag | | | Builds\TextBoxW\TextBoxW.ctl | | ToolBar(工具栏) | Builds\ToolBar\PPToolBarButtons.pag | | | Builds\ToolBar\PPToolBarGeneral.pag | | | Builds\ToolBar\TbrButton.cls | | | Builds\ToolBar\TbrButtonMenu.cls | | | Builds\ToolBar\TbrButtonMenus.cls | | | Builds\ToolBar\TbrButtonProperties.cls | | | Builds\ToolBar\TbrButtons.cls | | | Builds\ToolBar\ToolBar.ctl | | TreeView(树形视图) | Builds\TreeView\PPTreeViewGeneral.pag | | | Builds\TreeView\TreeView.ctl | | | Builds\TreeView\TvwNode.cls | | | Builds\TreeView\TvwNodes.cls | | UpDown(上下调节器) | Builds\UpDown\PPUpDownGeneral.pag | | | Builds\UpDown\UpDown.ctl | | VirtualCombo(虚拟组合框) (2020年8月15日或之后) | Builds\VirtualCombo.ctl Builds\VirtualCombo.ctx Builds\VirtualComboBase.bas | | VListBox(虚拟列表框) (2020年8月15日或之后) | Builds\VListBox\VListBox.ctl Buids\VListBox\VListBox.ctx | 如果您希望任何单个控件在项目中可用,在IDE中按Ctrl-D,然后导航到适当的文件夹并突出显示要导入的文件夹中的所有文件,然后按Enter。 一个挑战是Krool的包包含所有控件,而您不太可能需要所有控件。演示程序利用了所有控件,由此产生的EXE文件大小为4.2 MB,因此如果您在程序中包含所有控件,将增加大约4 MB的文件大小。在这些多千兆字节RAM和硬盘的日子里,这可能不像以前那样重要。 还有一些文件,无论您使用一个控件还是所有控件都必须存在。这些是: | | | ------------------------------------------------ | | Builds\ComCtlsBase.bas | | Builds\VTableHandle.bas | | Builds\VTableSubclass.cls (仅限2020年1月5日之前) | | Builds\ISubclass.cls | | Common\Common.bas | | Common\VisualStyles.bas | 最后,如果您使用MCIWnd.ctl控件或CoolBar、Imagelist、RichTextBox或StatusBar的属性页,您还必须在项目中包含文件'Builds\CommonDialog.cls'。 您可能会倾向于不包含您不使用的控件的代码。您确实可以在最终可执行文件中节省一些大小,但要知道,如果不包含上述控件的代码,这些控件甚至不会出现在工具箱中供可能使用。如果您确定不会使用给定的控件,可以将其排除。每个控件都独立于其他控件。 Krool的ComCtlsDemo包中还有一个文件,Common\Startup.bas,这实际上是用于演示程序的。您不需要这个文件,但该文件中的一些概念需要成为您程序的一部分。 Sub Main - Krool的控件依赖于一些Microsoft代码,这些代码需要在加载或显示任何窗体之前运行。要使用新控件,您必须将启动对象指定为Sub Main而不是任何Form,并且必须在引用任何控件之前在Sub main中有正确的启动代码。这在General选项卡的Project | Properties中设置。如果您没有名为Main的Sub中的启动例程,则需要在程序中放入一个。 您需要调用Krool的一个例程,为他的程序中内置的回调等提供保护,这样您就不会在IDE中崩溃。此外,您的程序需要一些启动代码才能使用通过使用Microsoft的Common Controls 6.0启用的视觉样式。因此,Sub Main中的前两行应该是: ```vb Call ComCtlsInitIDEStopProtection ' 在Builds\ComCtlsBase.bas中 ' 以上仅在使用2020年8月13日之前的Krool包时需要) Call InitVisualStyles ' 在Common\VisualStyles.bas中 ``` 现在您可以放入其余的代码来显示窗体、进行计算等。除非您使用其他.OCX控件文件,否则您的最终可执行文件将包含所有代码,包括控件,因此可执行文件是独立的,除了Microsoft随Windows提供的标准VB6支持文件外,不需要任何其他内容。 您可能会遇到子例程和变量的名称与您使用的名称相同的问题。如果您使用控件的.OCX版本,大多数这些都是隐藏的,不是问题。然而,当您在程序中包含所有各种控件文件以在程序中编译时,您现在有153个新文件,并且可能有一些命名冲突。如果您决定保留您的名称并更改Krool的名称,只需知道每次下载和使用更新时,您都必须编辑他的文件来重命名这些(不仅仅是子例程的名称,还有调用它的每个其他例程)。我不情愿地决定更改我代码中的一些冲突名称,这样我就不必不断更新他的文件。我不喜欢这样,但这是使用这些控件的一个小代价。 注意 - 我不使用上述方法,因为我不喜欢长时间的编译,尽管我确实喜欢完全独立的可执行文件。这就是我编写后面要讨论的工具的部分原因。它允许您使用.OCX版本进行开发(编译速度快得多),然后通过我的工具使用StdEXE版本进行最终编译,这样您就有了独立的可执行文件。 ### VBCCR OCX 版本指南 Krool 提供了 VBCCR 控件的预编译 OCX 版本，等价于 StdEXE 包，但更符合传统 ActiveX 控件的使用方式。你可以在 [这里](http://www.vbforums.com/showthread.php?841929-VB6-ActiveX-CommonControls-%28Replacement-of-the-MS-common-controls%29\&p=5129155#post5129155) 下载。与 StdEXE 版本相比，OCX 版本的优点有：1）只需一个 .OCX 文件而不是 153 个单独文件，使用更简单；2）编译速度更快，因为 OCX 已经预编译好；3）大多数程序员都熟悉 OCX 控件的用法。缺点是：1）OCX 文件需要和可执行文件一起分发给用户；2）OCX 文件必须在用户电脑上注册，或者采用更复杂的并排（side-by-side）方案。 获取最新版——从上述链接进入，下载首帖底部的文件。目前控件的 OCX 版本为 1.6，下载文件名通常为“VBCCR16.OCX.rar.docx”。由于 VBForums 限制，文件扩展名为 .docx，实际上是 RAR 压缩包。建议下载时将文件重命名为如“VBCCR16.OCX v1.6.13.rar”，方便管理不同版本。解压后可获得 .OCX 文件和包含源代码的 zip 文件（不建议自行编译 OCX，否则会与 Krool 官方包分离，内容与 StdEXE 版本类似）。 在程序中使用——在新建程序中，按 Ctrl-T 或通过 Project | Components，选择“VB Common Controls Replacement 1.6 Library”（即 vbccr16.ocx 文件）。在 VBA 项目中，可通过“工具 | 其他控件”添加。 最后，你需要设置包含清单（manifest）的资源文件，以启用视觉样式和可选的并排功能（仅 VB6，VBA 不适用）。VBForums 首帖还提供了两个资源文件：“VBCCR16SideBySide.res”和“VBCCR16SideBySideAndVisualStyles.res”，分别用于并排和并排+视觉样式。这些文件无需解压，直接保存使用即可。后文会介绍如何使用这些资源文件。 项目设置——与 StdEXE 版本一样，程序启动不能直接用窗体，必须先用 Sub Main 作为入口，以便在调用第一个窗体前运行必要的初始化代码。最简单的做法是从 StdEXE 包中包含 VisualStyles.bas 模块，然后在 Project | Properties 的 General 选项卡中设置启动对象为 Sub Main，并在 Sub Main 中，在加载、引用或显示任何窗体前加入如下代码： ```vb InitVisualStyles ``` 这样就可以正常使用所有控件，控件会出现在工具箱中，供窗体使用。 注意：StdEXE 版本中 Krool 提供了 IDE 崩溃保护代码，OCX 版本同样需要这些保护，但已编译进 OCX 文件，无需手动调用。 编译代码——只需确保 Sub Main 中有上述初始化过程即可。Krool 声称其代码 IDE 安全，实际使用中也确实如此。 你可以选择使用清单文件来指定两个常用功能：一是启用主题/视觉样式（Krool 的控件已内置支持，配置简单）；二是指定“并排程序集”。通常，ActiveX 控件和 DLL 需要注册到系统目录，但有些组织不允许注册外部依赖。自 VB6 时代起，Windows 支持通过清单文件让 OCX/DLL 与程序放在同一目录，无需注册即可使用。虽然不如 StdEXE 版本将代码直接嵌入程序那样彻底无依赖，但已是次优选择。 清单文件还可以包含其他内容，但本用户指南只关注对 Krool 控件包有影响的两项。过去，您可以将清单文件与 EXE 文件放在一起分发给用户，但新版 Windows 更推荐将清单嵌入到程序内部。实际上，清单是通过资源文件（resource file）嵌入的，这也是 VB6 等多种编程语言的常用做法。 清单文件是 XML 格式，并且文件大小必须正好是 4 的倍数。幸运的是，Krool 已经提供了两个资源文件（前文已介绍），可以直接包含到您的程序中。一个用于并排（side-by-side），另一个用于启用视觉样式和并排。例如，假设您从 Krool 网站下载了 `VBCCR16SideBySideAndVisualStyles.res` 文件并希望使用它。显然，这个文件同时支持视觉样式和并排。您无需编辑此文件，只需在项目中引用即可。 注意：资源文件可以放在公共位置，作为多个程序共享的库文件。但如果您修改了该文件，所有引用它的程序都会受到影响。如果担心这一点，可以将资源文件复制到项目文件夹（即 .vbp 文件所在的文件夹）并单独引用。 那么，如何将资源文件添加到项目中？在 VB6 中，依次点击菜单 AddIns | AddIn Manager，您会看到如下界面： 选择“VB6 Resource Editor”，确保“Loaded/Unloaded”和“Load On Startup”都已勾选。然后回到主项目，点击 Project | Add New Resource File，从弹出的对话框中选择您的 .res 文件。此时，资源文件会显示在导航窗格的 Related Documents 下方。 现在，您就可以编译并使用您的程序了。 关于 EXE 或 DLL 的分发：由于清单已嵌入资源文件，无需再单独分发清单文件。 您需要将 VBCCRxx.OCX 文件与程序一起分发。如果采用并排方式，只需将 OCX 文件放在 EXE 文件同一目录或其子目录下。请注意，采用并排时，Windows 会优先在可执行文件所在目录查找 OCX 文件，即使您已将其复制到系统目录并注册（实际测试如此）。因此建议不要将 OCX 文件从系统目录移走，而是在 EXE 所在目录再复制一份。建议在采用并排前先参考我的工具。我的方案是：开发阶段使用 OCX 版本控件，最终用工具命令行编译为 StdEXE 版本，这样无需任何并排方案，所有代码都嵌入到可执行文件中（仅限 Krool 控件；如果用到其他人的 OCX 控件，仍可采用并排方式）。 如果不采用并排，开发机上已注册 OCX 文件无需额外操作，但分发时需让安装程序将 OCX 文件复制到用户系统目录并注册。 ### VBFlexGrid 用户指南 Krool 的 MSFlexGrid 替代控件包与前述 33 个 Common Controls 替代控件几乎完全一致。由于该控件发布较晚，Krool 将其单独分离。未来可能会合并，但目前请将 VBFLXGRD 理解为和 VBCCR 类似，只是它只有一个控件。 StdEXE 版本可在 VBForums [这里](http://www.vbforums.com/showthread.php?848839-VBFlexGrid-Control-\(Replacement-of-the-MSFlexGrid-control\)) 下载，OCX 版本在 [这里](http://www.vbforums.com/showthread.php?855931-VB6-ActiveX-VBFlexGrid-%28Replacement-of-the-MSFlexGrid-control%29\&p=5236525#post5236525)。所有与 VBCCR 相关的问题在 FlexGrid 控件上同样适用。 我的工具可以帮助您无缝管理这两类控件。 ### VBA 使用说明 VBCCR 和 VBFLXGRD 控件的 StdEXE 版本无法在 VBA 中使用，因为 VBA 不允许将控件直接嵌入代码。VBA 只能使用 ActiveX 控件（即 OCX 版本）。 OCX 版本可以在 VBA 中正常使用。类型库无需单独引用，因为已编译进 OCX 文件。每位用户都需在其电脑上注册 OCX 文件，并在 VBA 项目中引用。 另外，VBA 不支持视觉样式，因此该功能不可用。如果您的 VBA 窗体外观较旧，这些控件无法改善。 这些控件可为 VBA 用户带来 Unicode 支持（尽管近年来很多 VBA 控件本身已支持 Unicode 显示，但设计时属性仍不支持 Unicode）。注意，这不会让 VBA 的代码编辑器支持 Unicode，编辑器始终是 ANSI。最后，Krool 的控件功能通常比微软自带控件更强大，这对 VBA 用户是个优势。 ## OCX2StdExe 工具 我在实际使用中总结了如何高效管理这些控件，避免混乱并提升开发效率。常见痛点包括： * StdEXE 版本可生成无依赖的独立可执行文件，但编译速度很慢。 * OCX 版本编译速度快，但每个可执行文件都要分发和注册 OCX。 * OCX 包更新频繁，带来大量 bug 修复和新功能，但每次升级都很麻烦。每个项目都要手动查找和替换 .vbp、窗体、资源文件中的 OCX 名称和 GUID，非常繁琐。 * Krool 的 OCX 包没有示例文件，如何让 OCX 版本支持视觉样式并不直观，即使清单/资源文件已引用，仍需初始化代码（OCX 包未包含，可从 StdEXE 版本提取）。 * 我有很多自定义初始化代码，不希望与 Krool 的代码混在一起。 为此，我写了一个 VB6 工具来统一管理这些问题： * 开发阶段使用 OCX 版本，因其简单（1 个文件而非 153 个），编译速度快。 * 可同时支持 VBCCRxx.OCX 和 VBFLXGRDxx.OCX。我的工具将两者视为同一类控件包（预计未来 Krool 也会合并）。 * 每当有新版本发布，只需下载、复制到系统目录并注册。如果覆盖同名旧文件（如 VBCCR17.OCX），无需额外操作；如果是跨版本升级（如 1.6 升级到 1.7），可用本工具自动升级项目引用，自动修改 .vbp、窗体、资源文件中的所有相关内容。所有原始文件会备份，便于回退（不推荐）。工具也支持降级到旧版本（如 1.7 降到 1.1）。 * 项目开发和维护流程与普通 OCX 控件项目一致。需要生成无依赖单文件时，可用工具切换为 StdEXE 版本命令行编译，生成独立可执行文件，且不会修改原始文件。只需一次慢编译即可。 * 使用 StdEXE 命令行编译时，最终 EXE 只包含实际用到的控件，体积更小。原始文件不变，工具会生成临时文件，引用 StdEXE 控件（153 个文件），而不是单一 OCX。可选择保留这些临时文件（文件名与 OCX 版本不同），便于后续重新编译。属性页文件可选不包含，进一步减小 EXE 体积（命令行编译不需要属性页，IDE 才需要）。 * 工具还可自动在项目目录下创建 StdExe 子文件夹，便于管理和编译。 这个工具(希望)易于使用。本文档涵盖了为VB6编写的工具版本;如果您愿意,还有一个几乎相同的Excel版本。Excel版本与VB6版本一起包含在包中。以下是VB6版本的屏幕截图。在窗体顶部是要更新或编译的VB6项目文件。您可以在文本框中输入路径,或单击左侧的按钮搜索它。项目文件需要是使用Krool控件的OCX版本(任一版本或两者)的项目。OCX版本有版本号,从一个版本更改到较新版本并不简单,因为要使用的OCX文件的引用嵌入在使用控件的窗体代码、资源文件(如果有嵌入的清单)和项目文件本身中。如果您指定的项目文件是不使用Krool控件或使用StdEXE版本的项目,那么您将无法执行OCX升级或命令行编译。 **更新OCX引用** 我们的窗体会告诉您在项目中使用的VBCCRxx.OCX和/或VBFLXGRD.OCX的当前版本。上面的示例显示指定的项目正在使用VBCCR15.OCX和VBFLXGRD12.OCX。它还显示您在运行此工具的PC上安装的每个版本,默认为最新版本。在上面的示例中,显示的是VBCCR17.OCX和VBFLXGRD14.OCX,这是本文档编写时的最新可用版本。虽然从图片中看不到,但下拉列表也包含一些早期版本。 升级后您可以选择保留或删除旧版本文件。通常您不需要保留旧文件,但如果选择保留,可以在与新文件相同的文件夹中找到它们,但扩展名添加的是旧OCX版本号而不是文件名。例如,如果您在'myForm.frm'上使用了Krool的控件,当它从版本15转换到16时,可以保留旧文件,如果保留,它将被命名为'myForm.frm.ocxCCR15ocxFlex12',这样您可以清楚地将其识别为升级后留下的旧文件。我建议一旦您对此工具有了信任,确信它不会删除不应该删除的文件,就没有理由保存旧版本,因此您可以选择删除旧文件。 如果较旧的OCX文件已在PC上注册,您实际上可以转到控件的较早版本。通常,较新版本有更多功能,但更重要的是它们也有错误修复,所以我不建议回到较早版本。另外要考虑的是,VBCCR16添加了一个新控件(ComboFont),VBCCR17添加了在较早版本中不存在的VirtualCombo和VListBox,因此如果您指定从1.6或更高版本转到1.5或更早版本,对这些控件的引用必须被删除,这可能不是您想要的(假设您已经使用了它)。 一旦您选择了要转到的版本以及是否保存旧文件,只需单击'Update .OCX References'即可更改您的项目。所有控件的设置将与升级到新版本之前相同。 **注意** - 此工具不使用任何Krool的控件,因此a)它只是ANSI的,b)您在PC上安装的OCX版本无关紧要。 **不带OCX文件编译** 主菜单中的这个选项允许您将程序与StdEXE文件一起编译到程序中,这样编译后就不再需要OCX文件。它不会更改您一直在使用OCX版本控件进行开发的任何文件。 此选项应该在您让程序使用OCX版本编译和运行*之后*使用。使用OCX版本开发程序要容易得多,效率也更高,然后使用StdEXE版本制作可以分发的可执行文件。请注意,所有这些都假设您已下载并注册了VBCCR和VBFlexGrid的OCX版本,并且还下载并解压了StdEXE版本的等效版本。 如果您单击主窗体上的Options按钮,将看到以下内容： 窗体顶部是选项,用于选择要包含的Krool支持文件(不是每个控件的一部分)。其中一些是许多单独控件使用的通用文件,有些只是通用支持文件。例如,Common.bas是一个通用模块,其例程被许多控件使用。我总是选中这个,因为它对所有功能都很核心。另一方面,VisualStyles.bas包含的代码我已经合并到我的核心模块中,所以我不在上面的选项中使用它。 类模块CommonDialog.cls很有趣。只有一个控件使用它(MCIWnd.ctl),IDE中使用的4个.pag文件也使用它(CoolBar、ImageList、RichTextBox和StatusBar)。我有代码来查看是否使用了这些,如果没有,它会自动被排除,所以我的建议是,除非您专门在代码中包含CommonDialog.cls用于其他用途,否则只需在上面选中它即可。 请注意,有一个名为VTableSubClass.bas的模块选项,但如果您使用2020年1月5日或之后的ComCtrlsDemo版本,则不需要此选项,也不会显示。 窗体中间是编译文件位置的选择。工具不会影响您现有的项目文件,但需要修改它们以将引用从.OCX控件更改为StdEXE控件。您有两种选择:1)复制所有受影响的文件,并在新复制文件的名称前面加上XXX,或2)将所有项目文件复制到单独的文件夹,在那里您可以进行适当的更改来编译。我建议复制到单独文件夹的选项,因为您不会在整个编程系统中留下散乱的XXX文件。 **将所有文件复制到StdEXE子文件夹然后编译** - 如果您选择此选项,与您项目相关的所有文件都会被复制到项目文件所在文件夹的名为StdEXE的子文件夹中。项目文件的副本会放入此子文件夹,所有引用都会调整到现在此子文件夹中的文件。编译后,EXE文件将位于此文件夹中。这个项目与父项目的不同之处在于OCX引用不见了,被替换为对StdEXE控件文件的引用。但是,除了将项目提供给命令行VB6编译器外,它也可以像普通项目一样在VB6 IDE中打开。如果您想要删除此项目,只需删除子文件夹的内容即可。注意- Krool的控件文件被视为库,因此在编译时不会以任何方式更改,所以它们不会被复制到StdEXE文件夹中。它们是从您放置它们的位置引用的。 **在编译前用XXX前缀重命名所有支持文件然后'** - 当您选择此选项时,您会在其下方得到3个子选项。为了保护原始项目,我们通过在名称前面加上'XXX\*'来复制所有更改的文件,包括从命令行编译器生成的EXE。您可以告诉程序在编译后删除这些支持文件;您可以保存这些XXX*文件,以便以后可以重新编译新项目文件(其名称也以XXX*为前缀);或者您可以选择保留Krool所有控件的所有支持文件,即使是那些在项目中未使用的。(注意 - 如果您使用此工具的Excel版本,前缀是YYY\*而不是XXX\_。) 注意 - 如果您选择保存支持文件以便可以在VB6 IDE中打开StdEXE版本,我必须进行一些对您来说透明但重要的修改,这样您就不会感到意外。例如,我不包含任何控件属性页文件(.pag扩展名),因为这些只在IDE中使用,而我们在命令行编译时跳过IDE。但是,如果您想保存支持文件以便以后可以在IDE中打开,那么我们需要确保调整您的项目文件以引用适当的.PAG文件,这样您就可以在IDE中打开它。因此,在命令行编译之后,.PAG文件的引用被放入.VBP项目文件中。 直到2020年8月初,Krool在StdEXE文件集中内置了一个机制,试图确保在IDE中使用这些控件的安全性。在2020年8月13日之后,他删除了这些保护措施。如果您仍在使用之前的StdEXE版本(强烈不建议),那么我们有一些代码可以帮助您在编译后将这个尝试的保护措施放入代码中,在.OCX版本中不需要它,但在早期的StdEXE版本中需要。 **包含哪些控件** 当您进行命令行编译时,只有您实际使用的控件才会包含在编译的代码中。这使得生成的.EXE文件尽可能小,因为您不包含对未使用控件的引用。但是,如果您想稍后编辑此StdEXE版本,可能您希望有选项将更多或所有当前未使用的控件添加到项目中。在Options窗体上有一个选项,可以指定将所有控件包含到新项目中,或者您可以单击'Special'并包含特定的控件。一般来说,我不建议这样做,因为继续使用引用.OCX文件的原始项目(您可以使用所有控件)更容易,然后只需在想要生成包含在.EXE中的控件的.EXE文件时重新运行此工具即可。 有一个特殊情况必须使用'Special'按钮。如果您在运行时定义控件,并且控件名称在变量中,我的工具无法看到它,追踪字符串的所有可能赋值会变得非常复杂。由于您编写编程代码,您应该知道在运行时添加哪些控件,因此您可以指定要包含的其他控件(如果有)。如果您的程序中已经使用了特定控件,则甚至不需要这样做,因为该使用已经使该控件包含在编译中。 **基本文件位置** 在Compile Options窗体底部是'Base File Locations'部分。为了进行命令行编译,我们需要知道VB6的位置以及Krool的控件文件的位置。 如果您要通过将OCX版本替换为临时StdEXE版本来编译项目,那么您需要知道VB6.EXE的位置,因为当您在主窗体中单击'Compile w/o .OCX's'时,此工具将稍后执行它。当您单击'VB6.EXE'按钮时,我们将尝试自动为您定位VB6。如果找不到,您可以导航到它或手动输入它。 窗体底部有两个位置,用于指定Krool的StdEXE版本(ComCtlsDemo和VBFlexGridDemo)的位置。您不需要这些来指定OCX版本的更新,但如果您希望使用StdExE控件而不是OCX版本的控件进行命令行编译,则需要指定这些。这些文件永远不会被修改,所以我把它们放在我的库中,我总是把最新版本保存在名为'Current'的文件夹中。您不需要将文件夹命名为那个名字,但您确实需要某个地方来放置为VBCCRxx和/或VBFLXGRDxx下载的新文件。 在您对此编译选项窗体做出任何想要的更改后,如果您单击'Accept changes & return',您的所有输入都将保存在INI文件中,以供下次运行StdEXE工具时重用。INI文件保存在保存StdEXE工具的同一文件夹中。我假设作为程序员,您不会将其安装到'Program Files'中,因此将您的设置与程序一起保存更方便,因为您不必担心尝试保存到'Program Files'需要UAC提升。 **编译** 当您在主窗体上单击'Compile w/o .OCX's'按钮时,工具将查看您的项目文件、所有控件、模块和清单/资源文件中对OCX控件的引用,并将它们更改为StdEXE控件,StdEXE控件的引用被放入.vbp文件中,然后使用VB6.EXE程序从命令行编译(我们切换到提升的命令提示符)。 您的原始项目文件不会被修改。 **注意** - 请知道,在最初几次使用此工具进行命令行编译时,您可能会遇到一些命名冲突。所有控件、页面属性、类文件等的名称(基本上是Builds文件夹中的所有内容)在OCX中都是"隐藏"的,但当您的程序编译时包含所有这些控件时,所有文件名和所有公共变量、类型、过程枚举等都是可见的。在这一点上,您可以决定是重命名您的代码还是Krool的代码。我本想保留我的并重命名Krool的(我有2个冲突),但我没有这样做,因为我不想追踪他每次使用的内容,也不想每次下载和更新时都要经历重命名的麻烦。但无论哪种方式都可以。 下面是两个屏幕截图,一个是成功编译的,一个是失败的。 ### 使用命令行选项运行OCX2StdEXE 现在有一个工具的命令行版本,可以执行OCX版本升级或使用StdEXE版本进行OCX编译,就像上面描述的那样,但没有输入窗体。请注意,在这两种情况下,如果项目的完整路径中有任何空格,那么完整路径必须用引号括起来。 **通过命令行编译** OCX2StdExe ProjectPathAndName \[/s\[1]\[2]\[3]] \[/A\[-]\[+]] 这意味着使用StdEXE版本编译使用OCX版本的项目,将代码嵌入到可执行文件中。如果指定/S,则编译后除了可执行文件外不保存任何文件(假设编译成功)。如果指定/S1,则保存使用的控件的支持文件,如果指定/S2,则保存所有控件的所有支持文件,无论项目中是否使用这些控件。指定/S3表示在StdEXE子文件夹中制作整个项目的副本,然后编译该副本。如果不指定/S开关,则重用上次使用对话框时保存的值。 您还可以指定在命令行编译中是否使用所有StdEXE控件(这与编译后是否保存任何文件不同)。指定/A或/A+表示使用所有控件,/A-表示不使用所有控件。如果不指定/A开关,则使用上次运行时当前保存的/A值。 开关大小写无关。/S与/s相同。 程序的编译版本(如果编译成功)将在2个地方之一找到。如果指定/S3,则StdEXE子文件夹不仅包含所有项目文件的副本,还包含编译的.EXE文件。另一方面,使用任何其他SaveControls选项将使编译的EXE与原始项目文件位于同一文件夹中,并且可执行文件名称前面将附加'XXX\_'。 **更新项目中的.OCX版本** OCX2StdExe ProjectPathAndName /u \[/CCRxx] \[/FLEXxx] \[/d] 这将使指定项目的OCX控件更改为/CCRxx或/FLExxx开关中指定的值。'xx'指定要使用的版本(必须首先在此PC上注册)。如果未指定'xx',则使用运行工具的PC上注册的最新版本。与常规版本的OCX2STDExe一样,旧文件使用新扩展名保存。指定/d或/D将导致删除所有包含旧OCX引用的那些旧文件。 ## 我如何管理Krool的系统 正如您可能已经发现的那样,我在开发期间使用Krool的OCX版本控件,然后使用我的工具切换到使用Krool的StdEXE版本进行编译,这样我就有了一个可以分发的独立可执行文件。我学到了一些技巧,希望能使整个过程变得非常简单。 * OCX版本的控件 * 我总是使用[这里](http://www.vbforums.com/showthread.php?841929-VB6-ActiveX-CommonControls-%28Replacement-of-the-MS-common-controls%29\&p=5129155#post5129155)的VBCCRxx和[这里](http://www.vbforums.com/showthread.php?855931-VB6-ActiveX-VBFlexGrid-%28Replacement-of-the-MSFlexGrid-control%29\&p=5236525#post5236525)的VBFLXGRDxx的最新OCX文件版本。最新版本在第1个帖子的末尾。保存VBCCRxx文件时注意使用"另存为"并删除.docx扩展名,因为这是Krool用来避免VBForums对zip文件大小限制的技巧。我建议将文件保存到硬盘时在文件名中包含当前版本。当前VBCCRxx文件是1.7.0版本,所以我将文件'VBCCR17.OCX.rar.docx'保存为'VBCCR16.OCX v1.7.0.rar'。最新的VBFLXGRDxx版本是1.4.27,目前文件大小足够小,仍然使用.zip扩展名。我会将'VBFLXGRD14.OCX.zip'这个文件保存为'VBFLXGRD12.OCX v1.4.27.zip'。在网页上获取OCX文件时,您还应该获取.RES文件(资源文件),因为稍后会用到这些文件。 * 现在您需要将.RAR和.ZIP文件中的OCX文件放入系统文件夹以使用它们。如果使用32位Windows版本,您需要将OCX文件放入C:\Windows\System32,如果使用64位Windows版本,则放入C:\Windows\SysWOW64。请注意,OCX文件名中没有次要版本。例如,最近的两个VBCCRxx.OCX版本是1.7.12和1.7.13,但每个都是名为VBCCR17.OCX的文件。如果系统文件夹中已经有旧版本,您可以直接覆盖它。请注意,对于XP之后的任何操作系统,您都需要使用提升的CMD提示符或像Directory Opus(我最喜欢的)这样的文件管理器来处理提升。您不必将OCX文件放在系统文件夹中,但我总是这样做,如果不是别的原因,至少我知道它在哪里。 * 如果您从未使用过Krool的OCX控件,或者您有更新的版本(比如1.7而不是1.5),那么您需要使用提升的命令提示符中的regsver32注册OCX文件(如果您只是覆盖了同名的旧文件则不需要)。 * 如果您有更新的OCX版本(例如从1.5到1.7),那么您需要为使用早期版本的每个项目运行我的工具,并更新到最新的OCX版本。 * StdEXE版本的控件 * StdEXE版本控件的一个令人困惑的方面是,它们没有像OCX版本控件那样的版本号。当Krool更新他的StdEXE控件时,我下载该包并在下载文件名中放入发布日期。然后我将文件提取到之前使用的相同文件夹结构中,这样我总是可以使用最新版本的控件。Krool警告不要使用这些控件进行开发,因为它们不是IDE安全的,但通过使用这个编译工具,您可以使用稳定的.OCX版本进行开发,然后使用stdEXE版本进行命令行编译,将您使用的控件包含到EXE文件中,这样您就不需要.OCX文件与.EXE程序一起分发。 * 您需要查看VBCCRxx或VBFLXGRDxx的OLEGuids文件夹,并将类型库OLEGuids.tlb复制到系统文件夹并注册它。幸运的是,这个文件不经常更改(当前版本日期为2020年4月15日),但值得时不时检查一下,以确保您不使用过时的类型库。请注意,OCX版本不需要此类型库,因为它实际上已编译到OCX文件中,但StdEXE版本需要它。 * 在您的程序中,您必须通过Project | References在IDE中引用类型库,并在'OLE Guid and interface definitions'旁边打勾。再次说明,这只是StdEXE版本需要的。当您使用此工具并修改使用OCX版本的项目副本以改用StdEXE版本时,我会为您处理这个问题。 * 通过Project | Components(或Ctrl-T)在IDE中启用控件,然后选择适当的控件文件。对于VBCCR 1.7版本,您需要在'VB Common Controls Replacement 1.7 Library'旁边打勾。对于VBFLXGRD 1.4版本,您需要在'VB FlexGrid Control 1.4'旁边打勾。所有控件现在应该出现在IDE的工具箱中。 * VB6程序的默认启动操作是加载和显示窗体。您不能用这些控件这样做,因为在引用、加载或显示任何窗体之前需要运行一些初始化代码。首先,您需要在项目中的标准模块中有一个Sub Main。然后您需要在Project | Properties的General选项卡中更改设置,使Startup Object成为调用Sub Main而不是任何窗体。然后在Sub Main中,您需要一些初始化代码,这样在调用第一个窗体时就不会崩溃。有两种方法可以做到这一点。 * 第一种是直接使用Krool的代码,尽管方式有点奇怪。OCX控件包不包含任何关于如何使用它的指南或代码(它在后来的版本中确实有一些代码,可以让您从源代码制作自己的OCX文件,但这与使用指南不同)。如果您下载StdEXE版本,您会找到一个名为'Common'的文件夹,其中有文件'Common.bas'和'VisualStyles.bas'。VisualStyles.bas中有一个名为'InitVisualStyles'的子程序,这是您在调用窗体之前需要运行的,但如果您只是将VisualStyles.bas包含在程序中,您会发现它需要Common.bas中的一些例程,所以您也必须加载它。因此,如果您在项目中包含这两个文件,您的Sub Main中的第一行应该是调用InitVisualStyles,然后您就可以调用您的窗体了。 * 我使用的方法(正如您在我的工具源代码中看到的那样),我在库中有一个名为mVB6Core.bas的通用标准模块,其中我放入了足够的来自Common.bas和VisualStyles.bas的代码,这样我就可以运行InitVisualStyles子程序,并且可以做很多我经常做的其他事情(检查我们是否在IDE中还是运行编译代码、当前Windows版本等)。以下是我在名为UCCoreInit的通用初始化例程中的代码(第1971行)： ```vb If OSVer >= Vista Then Dim ICC As InitCC If App.LogMode <> 0 Then Call InitReleaseVisualStyles(AddressOf ReleaseVisualStyles) ICC.dwSize = LenB(ICC) ICC.dwICC = &H4000& InitCommonControlsEx ICC Else InitCommonControls End If ``` * 您可能认为可以开始了。还不行。当加载每个窗体上的每个控件时,我们必须设置视觉样式。在每个窗体的初始化代码中的某个地方,您需要调用SetupVisualStyles并将窗体传递给子程序。这段代码在VisualStyles.bas中,也是我的mVB6Core.bas库的一部分。这个SetupVisualStyles子程序确保窗体上的所有控件都可以使用视觉样式。所以您可以在使用的每个窗体的Form\_Load子程序中放置这个调用。我的方法与此接近。我总是让我的窗体使用我的类库clResizer.cls,即使我关闭窗体的调整大小功能,我仍然在窗体的初始化代码中有对这个类模块的调用,该模块反过来调用SetupVisualStyles子程序。这样我就不必让该调用成为每个新窗体代码的一部分,因为我的类库处理它。但两种方式都可以。 * 关于清单（manifest）和资源文件。Krool 的控件本身与资源文件没有直接关系，资源文件只是用来容纳清单文件。如果你不需要视觉样式、并排（side-by-side）或高 DPI 显示器，则不必使用清单或资源文件。但如果你想让程序支持视觉样式、并排或高 DPI，则必须使用清单，并将其嵌入到资源文件中，再将该资源文件加载到可执行文件中。如果你打算一直使用 OCX 版本而不是最终用 StdEXE 版本编译控件，通常会希望启用并排选项。但我个人***不***这样做。在开发机上指定并排没有任何好处，反而会带来麻烦——因为如果你在开发机上用 OCX 版本生成 EXE，并且指定了并排，那么运行 EXE 时必须把 OCX 文件和 EXE 放在同一目录下，即使该 OCX 已经注册在系统目录中。 我为所有新项目都使用一个名为 OCX2StdEXE.res 的资源文件（随我的工具提供），它只指定了视觉样式和高 DPI 支持，并未指定并排。如果你有其他文件需要并排，可以把它们写进资源文件，但 Krool 的 OCX 控件没必要这样做。 注意：即使你指定了并排，后来又用我的工具进行最终编译，也不会有任何问题。我的工具会自动从资源文件中移除并排相关的内容，因为当所有控件代码都已编译进可执行文件时，并排就没有意义了。和往常一样，你用于开发的原始文件不会被修改。 * 下面要为后续做一些准备。如果你用的是 2020 年 8 月 13 日之后的 Krool ComCtrlDemo 项目 StdEXE 控件版本，可以跳过以下内容，因为 Krool 的新代码已经不再需要这些处理。如果你还在用旧版本，建议尽快升级，因为 Krool 的控件是免费的，没理由继续用旧版。 * 开发阶段我们用 OCX 版本控件，不用担心 IDE 崩溃，因为 Krool 的 OCX 已经处理了相关问题。命令行编译时我也做了处理。唯一需要注意的是：如果你用命令行编译并选择“保留支持文件以便后续在 IDE 打开”，这时就涉及 IDE Stop 保护代码。Krool 通过条件编译常量 `ImplementIDEStopProtection` 控制 IDE 保护。在 StdEXE 演示项目的 ComCtlsBase 文件第 3 行有这个常量，设为 True 时会编译 IDE 保护代码。命令行编译时我们不希望启用它，所以我会用一份注释掉该常量的 ComCtlsBase.bas 副本。命令行编译后，如果你选择保留支持文件，新的项目文件会自动加上 `ImplementIDEStopProtection = -1`（True），并且需要调用 `ComCtlsInitIDEStopProtection` 子程序来启用 IDE 保护。我的工具自带的 mVB6Core.bas 标准模块会自动处理这些。如果你查看第 1980 行，会看到如下代码： ```vb #If ImplementIDEStopProtection = True Then ' 如果你用 Krool 的控件，OCX 版本不需要 IDE 保护， ' 但 StdEXE 版本需要。如果你用 OCX 版本开发， ' 然后用本工具命令行切换为 StdEXE 并选择保留支持文件， ' 需要执行如下子程序。命令行编译结束后， ' 我会在新的 .vbp 项目文件（引用单独控件而非 OCX）中 ' 添加 ImplementIDEStopProtection = True 编译常量。 ' 下面的子程序在 ComCtlsBase.bas 中。 ComCtlsInitIDEStopProtection ' 命令行编译时常量为 False #End If ``` 通常情况下，这个条件编译常量为 0（OCX 版本下不可见），所以不会调用 ComCtlsInitIDEStopProtection。但如果你用工具保留了支持文件，保存的项目文件会加上 ImplementIDEStopProtection = -1（True）。只有在命令行编译后保留支持文件、并用 IDE 打开时才需要这个过程。一般情况下你不会用到这些支持文件，也不需要关心。如果你有自己的初始化代码，想让命令行编译后的支持文件能在 IDE 打开，也需要类似的处理。实际上，这不是必须的——如果你的程序能用 OCX 版本编译通过，那么用 StdEXE 版本命令行编译也极大概率能成功，通常不会用到这些支持文件。 * 现在你可以正常开发程序了，使用 OCX 版本控件（VBCCRxx.OCX 和/或 VBFLXGRDxx.OCX）。 * 如果有新版本 OCX 发布（[VBCCRxx 下载地址](http://www.vbforums.com/showthread.php?841929-VB6-ActiveX-CommonControls-%28Replacement-of-the-MS-common-controls%29\&p=5129155#post5129155)，[VBFLXGRDxx 下载地址](http://www.vbforums.com/showthread.php?855931-VB6-ActiveX-VBFlexGrid-%28Replacement-of-the-MSFlexGrid-control%29\&p=5236525#post5236525)），主版本号不变（如 1.7.10 升级到 1.7.13），直接覆盖 OCX 文件即可。如果主版本号升级（如 1.7 升到 1.8），复制新 OCX 到系统目录并用 regsvr32 注册，然后用本工具批量升级所有项目的引用。 * 同时关注 Krool ComCtlsDemo（StdEXE 版）和 VBFlexGridDemo 的更新（[ComCtlsDemo 下载](http://www.vbforums.com/showthread.php?698563-CommonControls-\(Replacement-of-the-MS-common-controls\))，[VBFlexGridDemo 下载](http://www.vbforums.com/showthread.php?848839-VBFlexGrid-Control-\(Replacement-of-the-MSFlexGrid-control\))）。虽然没有严格的版本号，但网站上的最新版本通常和 OCX 版本保持同步。过去 OCX 版本有时会落后于 StdEXE 版，但最近几年 Krool 已经做到了同步更新。 * 每当你要发布可执行文件时，运行本工具，选择“无 OCX 编译”选项即可。 * 命令行编译时，每个控件都需要相应的文件。工具会自动判断并包含所需文件。Common 和 Builds 文件夹下有一些通用文件是否包含，由你在工具的 Options 窗体中设置。你可以自由选择是否包含这些文件。相关代码在 zVBandVBA 模块的 DoCompile 函数（第 191 行起）。我的默认设置如下所示。 ```vb Public IncludeStartupbas As Boolean Public IncludeCommonbas As Boolean Public IncludeVisualStylesbas As Boolean Public IncludeISubclasscls As Boolean Public IncludeVTableHandlebas As Boolean Public IncludeVTableSubclasscls As Boolean Public IncludeCommonDialogcls As Boolean ``` 我在自己的程序中不包含 Startup.bas，因为它是特定于 Krool 的演示程序的，尽管我在自己的程序中使用了他的部分例程。 我不包含 VisualStyles.bas，因为我已将该代码集成到 OCX 和 StdEXE 版本的初始化例程中。VisualStyles 需要 Common.bas 中的一些函数和子程序，但我只采用了其中的一部分，并将它们与 VisualStyles 一起设为私有，这样在命令行编译时我就可以引入整个 Common.bas。最后，指定可以包含 CommonDialog.bas。请注意，它不会自动包含。只有在使用 MCIWnd.ctl 控件或使用 CoolBar、ImageList、RichtextBox 或 StatusBar 的一个或多个属性页时才会包含它。属性页不用于命令行编译选项，但如果您选择保存支持文件以供以后重新编译，则会包含属性页文件。 ## 版本历史 | **版本** | **日期** | **说明** | | -------- | -------------- | ---------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------- | | 0.9.0 | 2017年7月2日 | \* VB6 和 Excel 初始版本发布用于测试。 | | 0.9.1 | 2017年7月4日 | \_ 可以在没有控件但有一个或多个 CommonDialog 引用的情况下工作 \_ .vbp 文件中的比较使用大写 \* 如果 .vbp 文件已有 stdol2.tlb 引用，则不包含该引用。 | | 0.9.2 | 2017年7月9日 | \* 正确处理没有使用控件但在窗体中调用 CommonDialog 的情况（之前只在类和标准模块中检查）。 | | 0.9.3 | 2017年7月31日 | \* 修复新 .vbp 文件中窗体的路径错误 | | 0.9.4 | 2017年8月23日 | \* 重新处理一些相对路径问题 | | 0.9.6 | 2018年7月11日 | \* 调整以适应 mUCCore 中函数名称从 myQuickOpen 改为 FileCreateOrOpen 的变化。 | | 0.9.7 | 2018年10月1日 | \_ 添加 VBCCR16 支持 \_ 将 VB6 核心代码拆分到独立的 mVB6Core.bas 中，与 VBA 的 mUCCore 并行 | | 0.9.8 | 2018年11月24日 | \* 大量更改 | | 0.9.9 | 2018年12月1日 | \_ 添加对 VBFLXGRD.OCX 和 VBFlexGridDemo.vbp (StdEXE) 的支持 \_ VB6 版本中将所有输入合并到一个窗体 \_ 为编译后支持文件保存数量添加三个选项按钮（无、使用的控件、所有控件） \_ 修改逻辑以在编译中包含或排除 Common 和 Builds 中的各种模块 \_ 修改围绕条件编译常量 ImplementIDEStopProtection 的逻辑，特别是针对编译后重用 \_ 编译和/或编译后支持文件保存中包含或排除 CommonDialog.cls 的新逻辑 \_ 使用枚举来帮助管理特定项目中是否使用 VBCCRxx 和/或 VBFLXGRDxx 的代码 \_ 添加升级或编译的命令行选项。 | | 0.9.10 | 2018年12月11日 | \_ 修复如果未安装/注册 VBCCRxx 或 VBFLXGRDxx 时 DoCompile 中的错误 \_ 修复当资源文件没有嵌入清单时 DoCompile 从资源文件提取清单的错误 | | 0.9.11 | 2018年12月12日 | \_ 在 DoCompile 中查找类和标准模块中对 VBCCRxx 和/或 VBFLXGRDxx 的引用（之前只处理窗体和资源文件，但未处理 .bas 和 .cls 文件） \_ 在 fmInput 上，当对话框中已有当前文件时，cbutProjFile 默认为该文件的文件夹，而不是程序的路径。 | | 0.9.12 | 2018年12月13日 | \* fmInput 上的 DoCompile 新增复选框，强制在编译中使用所有 StdEXE 控件，这通常不需要，但如果有人在基于 OCX 的项目中引用了控件的属性，我们可以看到它是 VBCCRxx 的一部分，但如果不遍历每个控件的每个属性，我们就不知道它与哪个控件相连。我认为这种情况不常见，所以我把它放在那里以防有人在基于 OCX 的代码中这样做。 | | 0.9.13 | 2018年12月19日 | \_ 代码清理 \_ 将所有编译选项移至第二个窗体 | | 2.0.0 | 2020年7月1日 | \_ 支持 VBFlexGrid OCX 版本 1.4。 \_ Krool 的控件已被标准 VB6 控件替代。这听起来似乎适得其反，但更新工具不应该依赖于控件的特定版本。变化的一小部分是清单和并行编译已被移除。 \_ 似乎 Krool 即将发布 VBCCR.OCX 1.7 版和 VBFlexGrid 1.5 版的重大更新，此工具现已设置为可快速添加更新到这些新版本的功能。 \_ 该工具使用新的类模块 clINI.cls，在 INI 文件中保存和恢复工具多次运行之间的设置。上一版本将设置保存到注册表。这仍然是一个选项，但出于各种原因，我已完全不使用注册表，因此需要一些代码修改。目前，该工具会将 INI 文件保存到程序文件复制到的同一文件夹中。 \* 集成了 VBForums 上 The Trick 的工具提示模块。 | | 2.1.0 | 2020年7月2日 | \* 各种错误修复。 | | 2.1.1 | 2020年7月3日 | \* 上传的版本没有工具提示模块的本地版本。 | | 2.2.0 | 2020年8月20日 | \_ clResize.cls 中包含了新的工具提示方法，并从 VB6Core.bas 中移除旧的 \_ 支持 VBCCR17.OCX \* 改进了几处注册表读取。 | | 2.3.0 | 2020年8月28日 | \_ 现在包含一个选项，可以首先将项目文件（及其所有模块等）复制到项目的 StdEXE 子文件夹中，以供以后使用。 \_ 大量小错误修复。 | | 2.3.1 | 2020年8月31日 | \* 错误修复 - 如果您在项目中有自己的 UserControl 和/或 PropertyPage（不是 Krool 的控件，而是您自己的），这些不会被复制到用于独立项目编译的 StdExe 文件夹中。现已修复。 | | 3.0.0 | 2021年3月27日 | \_ 您可以指定在使用 StdExe 编译时要包含的单个控件。添加此功能是因为帖子 #34 中的示例，他想在标准模块中添加一个控件，控件名称在变量中。我不想在您的代码中追踪变量赋值，所以现在有一个功能来处理这个问题（您应该知道您添加了哪些这样的控件，这样您就可以打开这些控件以包含在 EXE 文件中）。以前这是一个全有或全无的选择。 \_ StdExe 编译选项包括在所有项目文件（包括 .BAS 文件）中查找对 Krool 控件的引用。 \_ 修复了 StdExe 编译部分的错误 \_ 实际上忽略了 VirtualCombo 和 VirtualListbox。 \_ 即使指定要包含，CommonDialog.cls 也被遗漏。 \_ 有时会遗漏用户项目文件中的条件编译常量。 \_ 在"复制到子文件夹"选项中，最终的 .VBP 文件中没有引用 .PAG 文件。 \_ 改进了 MS 编译器/链接器的命令行编译输出处理。 \* 在从命令行使用 StdExe 选项编译之前，现在需要基本文件位置。如果您尚未输入这些文件位置值，系统会在您继续之前提示您输入。 | | 3.1.0 | 2021年11月17日 | \_ 处理 VBCCR17.OCX 版本 1.1（之前只处理 1.0） \_ Set\_xx\_CCR 和 Set\_xx\_Flex 现在只调用一次 \* 数组 GUIDxxCCR() 和 GUIDccFlex() 现在是公共的（之前嵌入在 Set\_xx\_CCR 和 Set\_xx\_Flex 中） | | 3.2.0 | 2021年12月20日 | \* 处理 VBCCRxx.OCX 直至 1.7 版。处理所有 VBFLXGRDxx.OCX 版本，包括刚发布的 v1.5。 | | 3.3.0 | 2023年6月24日 | \_ 现在支持 VBFleGrd16 \_ 每个 OCX 版本都是独立的。VBCCR16.OCX 与 VBCCR17.OCX 等完全分开。这些版本很少有多个版本，所以有 1.0、1.2 版，现在是 1.2。这个版本号出现在 VBP 文件和所有 .FRM 文件中。我之前假设每个 .OCX 的版本号都是 1.0，因为它们都只有 1.0，但现在 VBCCR17.OCX 有 1.0、1.1 和 1.2。未能识别大于 1.0 的版本导致了一些问题。现在已修复。\* 琐事 - VBCCR11.OCX 有一个 1.1 版本，但那是在 2015 年，我很确定没有人再使用它了。 | --- --- url: /zh/packages/vbccr/system/imagelist.md description: 图像列表控件（ImageList） - VBCCR 开发手册，基于源码的完整 API 参考 --- # 图像列表控件（ImageList） 封装 ImageList 控件，用于存储和管理图像集合，供其他控件引用。 ## 枚举 ### ImlImageSizeConstants | 常量 | 值 | 说明 | |------|-----|------| | imlSmall | 0 | 小图标（16×16） | | imlLarge | 1 | 大图标（32×32） | | imlCustom | 2 | 自定义大小 | ### CCBackStyleConstants 参见通用枚举。 ## 属性 ### ImageWidth ```vb Property Get ImageWidth() As Long Property Let ImageWidth(ByVal Value As Long) ``` 图像宽度（像素）。 ### ImageHeight ```vb Property Get ImageHeight() As Long Property Let ImageHeight(ByVal Value As Long) ``` 图像高度（像素）。 ### ImageSize ```vb Property Get ImageSize() As ImlImageSizeConstants Property Let ImageSize(ByVal Value As ImlImageSizeConstants) ``` 预设图像尺寸。设置此属性将自动调整 ImageWidth 和 ImageHeight。 ### ColorDepth ```vb Property Get ColorDepth() As Long Property Let ColorDepth(ByVal Value As Long) ``` 色深。支持 4、8、16、24、32 位。需要 comctl32.dll 6.0 或更高版本。 ### MaskColor ```vb Property Get MaskColor() As OLE_COLOR Property Let MaskColor(ByVal Value As OLE_COLOR) ``` 掩码颜色。 ### UseMaskColor ```vb Property Get UseMaskColor() As Boolean Property Let UseMaskColor(ByVal Value As Boolean) ``` 是否使用掩码颜色。 ### BackColor ```vb Property Get BackColor() As OLE_COLOR Property Let BackColor(ByVal Value As OLE_COLOR) ``` 背景颜色。 ### hImageList ```vb Property Get hImageList() As LongPtr ``` 图像列表句柄。只读。 ### ListImages ```vb Property Get ListImages() As ImlListImages ``` 图像集合。 ### Name ```vb Property Get Name() As String ``` 控件名称。只读。 ### Tag ```vb Property Get Tag() As Variant Property Let Tag(ByVal Value As Variant) Property Set Tag(ByVal Value As Variant) ``` 自定义数据。 ### Parent ```vb Property Get Parent() As Object ``` 父对象。只读。 ### Container ```vb Property Get Container() As Object Property Set Container(ByVal Value As Object) ``` 容器对象。 ### Left ```vb Property Get Left() As Single Property Let Left(ByVal Value As Single) ``` 左边距。 ### Top ```vb Property Get Top() As Single Property Let Top(ByVal Value As Single) ``` 顶边距。 ### Width ```vb Property Get Width() As Single Property Let Width(ByVal Value As Single) ``` 宽度（设计时使用）。 ### Height ```vb Property Get Height() As Single Property Let Height(ByVal Value As Single) ``` 高度（设计时使用）。 ### Visible ```vb Property Get Visible() As Boolean Property Let Visible(ByVal Value As Boolean) ``` 可见性（设计时使用）。 ### hWnd ```vb Property Get hWnd() As LongPtr ``` 窗口句柄。只读。 ## 方法 ### Refresh ```vb Sub Refresh() ``` 强制重绘。 ### CreateIcon ```vb Function CreateIcon(ByVal ImageIndex As Long) As IPictureDisp ``` 从指定图像创建图标。 ### CreateBitmap ```vb Function CreateBitmap(ByVal ImageIndex As Long) As IPictureDisp ``` 从指定图像创建位图。需要 comctl32.dll 6.0 或更高版本。 ### Overlay ```vb Function Overlay(ByVal ImageIndex1 As Long, ByVal ImageIndex2 As Long) As IPictureDisp ``` 将两个图像叠加，返回叠加后的图像。 ### AboutBox ```vb Sub AboutBox() ``` 显示关于对话框。 ## 子对象 ### ListImage（ImlListImage） 表示图像列表中的单个图像。 #### 属性 | 属性 | 类型 | 读写 | 说明 | |------|------|------|------| | Index | Long | 只读 | 集合中的索引 | | Key | String | 读写 | 集合中的键 | | Tag | Variant | 读写 | 自定义数据 | | Picture | IPictureDisp | 读写 | 图像 | | MaskPicture | IPictureDisp | 读写 | 掩码图像 | | Overlay | Boolean | 读写 | 是否为叠加图像 | | OverlaySourceIndex | Long | 读写 | 叠加源索引 | | ExtractIcon | IPictureDisp | 只读 | 提取图标 | | ExtractBitmap | IPictureDisp | 只读 | 提取位图 | ### ListImages（ImlListImages） 图像集合对象。 #### 属性 | 属性 | 类型 | 读写 | 说明 | |------|------|------|------| | Item(ByVal Index As Variant) | ImlListImage | 只读 | 按索引或键获取图像 | | Count | Long | 只读 | 图像数量 | #### 方法 | 方法 | 说明 | |------|------| | Add(\[Index], \[Key], \[Picture], \[MaskPicture]) As ImlListImage | 添加图像 | | Exists(ByVal Index As Variant) As Boolean | 判断图像是否存在 | | Clear | 清除所有图像 | | Remove(ByVal Index As Variant) | 移除指定图像 | ## 代码示例 ```vb ' 设置图像大小并添加图像 With ImageList1 .ImageSize = imlSmall .ListImages.Add , "open", LoadPicture("open.ico") .ListImages.Add , "save", LoadPicture("save.ico") .ListImages.Add , "exit", LoadPicture("exit.ico") End With ' 按键引用图像 Set cmdOpen.Picture = ImageList1.ListImages("open").ExtractIcon ' 创建叠加图像 ImageList1.ListImages.Add , "overlay1", LoadPicture("ov1.ico") ImageList1.ListImages("overlay1").Overlay = True ImageList1.ListImages("overlay1").OverlaySourceIndex = 1 ' 使用 Overlay 方法叠加两个图像 Set imgOverlay = ImageList1.Overlay(1, 2) ' 遍历所有图像 Dim img As ImlListImage For Each img In ImageList1.ListImages Debug.Print img.Index; img.Key Next img ``` --- --- url: /zh/packages/vbccr/lists/imagecombo.md description: 图像组合框控件（ImageCombo） - VBCCR 开发手册，基于源码的完整 API 参考 --- # 图像组合框控件（ImageCombo） 提供支持图标显示的增强型组合框控件，每个项目可关联图像列表中的图标。 ## 枚举 ### ImcStyleConstants | 常量 | 值 | 说明 | |------|-----|------| | ImcStyleDropDownCombo | 0 | 下拉组合框（可输入） | | ImcStyleSimpleCombo | 1 | 简单组合框（列表始终可见） | | ImcStyleDropDownList | 2 | 下拉列表（仅选择） | ### ImcEndEditReasonConstants | 常量 | 值 | 说明 | |------|-----|------| | ImcEndEditReasonLostFocus | 1 | 编辑结束原因：失去焦点 | | ImcEndEditReasonReturn | 2 | 编辑结束原因：按回车键 | | ImcEndEditReasonEscape | 3 | 编辑结束原因：按 Escape 键 | | ImcEndEditReasonDropDown | 4 | 编辑结束原因：下拉选择 | ### ImcEllipsisFormatConstants | 常量 | 值 | 说明 | |------|-----|------| | ImcEllipsisFormatNone | 0 | 不使用省略号 | | ImcEllipsisFormatEnd | 1 | 文本末尾使用省略号 | ## ImcComboItem 对象 表示图像组合框中的一个项目。 ### ImcComboItem 属性 #### Index ```vb Property Get Index() As Long ``` 返回项目在集合中的索引。只读。 #### Key ```vb Property Get/Let Key() As String ``` 返回/设置项目的键值。 #### Tag ```vb Property Get/Let/Set Tag() As Variant ``` 返回/设置项目的附加数据。 #### Text ```vb Property Get/Let Text() As String ``` 返回/设置项目的文本。 #### Image ```vb Property Get/Let Image() As Variant ``` 返回/设置项目关联的图像索引或键。 #### ImageIndex ```vb Property Get ImageIndex() As Long ``` 返回项目关联的图像索引。只读。 #### SelImage ```vb Property Get/Let SelImage() As Variant ``` 返回/设置项目选中时关联的图像索引或键。 #### SelImageIndex ```vb Property Get SelImageIndex() As Long ``` 返回项目选中时关联的图像索引。只读。 #### Indentation ```vb Property Get/Let Indentation() As Long ``` 返回/设置项目的缩进级别（以图标宽度为单位）。 #### Selected ```vb Property Get/Let Selected() As Boolean ``` 返回/设置项目是否被选中。 #### Data ```vb Property Get/Let Data() As LongPtr ``` 返回/设置项目的附加数值数据。 ## ImcComboItems 集合 表示图像组合框中所有项目的集合。 ### ImcComboItems 属性和方法 #### NewEnum ```vb Public Function NewEnum() As IEnumVARIANT ``` 返回枚举器，支持 For Each 语法。 #### Add ```vb Public Function Add(Optional ByVal Index As Long, Optional ByVal Key As String, Optional ByVal Text As String, Optional ByVal Image As Variant, Optional ByVal SelImage As Variant, Optional ByVal Indentation As Variant) As ImcComboItem ``` 添加一个项目到集合中，返回新创建的 ImcComboItem 对象。 #### Item ```vb Public Property Get Item(ByVal Index As Variant) As ImcComboItem ``` 按索引或键返回项目。 #### Exists ```vb Public Function Exists(ByVal Index As Variant) As Boolean ``` 检查指定索引或键的项目是否存在。 #### Count ```vb Public Property Get Count() As Long ``` 返回集合中的项目数量。 #### Clear ```vb Public Sub Clear() ``` 移除集合中的所有项目。 #### Remove ```vb Public Sub Remove(ByVal Index As Variant) ``` 按索引或键移除一个项目。 ## 属性 ### ControlsEnum ```vb Property Get ControlsEnum() As VBRUN.ParentControls ``` 返回父控件枚举器。 ### Name ```vb Property Get Name() As String ``` 返回控件的名称。 ### Tag ```vb Property Get/Let Tag() As String ``` 返回/设置控件的标记值。 ### Parent ```vb Property Get Parent() As Object ``` 返回控件的父对象。 ### Container ```vb Property Get/Set Container() As Object ``` 返回/设置控件的容器。 ### Left ```vb Property Get/Let Left() As Single ``` 返回/设置控件左边缘的位置。 ### Top ```vb Property Get/Let Top() As Single ``` 返回/设置控件上边缘的位置。 ### Width ```vb Property Get/Let Width() As Single ``` 返回/设置控件的宽度。 ### Height ```vb Property Get/Let Height() As Single ``` 返回/设置控件的高度。 ### Visible ```vb Property Get/Let Visible() As Boolean ``` 返回/设置控件是否可见。 ### ToolTipText ```vb Property Get/Let ToolTipText() As String ``` 返回/设置控件的工具提示文本。 ### HelpContextID ```vb Property Get/Let HelpContextID() As Long ``` 返回/设置控件的帮助上下文 ID。 ### WhatsThisHelpID ```vb Property Get/Let WhatsThisHelpID() As Long ``` 返回/设置控件的"这是什么"帮助 ID。 ### DragIcon ```vb Property Get/Let/Set DragIcon() As IPictureDisp ``` 返回/设置拖动操作时显示的图标。 ### DragMode ```vb Property Get/Let DragMode() As Integer ``` 返回/设置拖动模式（手动或自动）。 ### hWnd ```vb Property Get hWnd() As LongPtr ``` 返回图像组合框的窗口句柄。 ### hWndUserControl ```vb Property Get hWndUserControl() As LongPtr ``` 返回 UserControl 的窗口句柄。 ### hWndCombo ```vb Property Get hWndCombo() As LongPtr ``` 返回 ComboBoxEx 控件的窗口句柄。 ### hWndEdit ```vb Property Get hWndEdit() As LongPtr ``` 返回编辑框部分的窗口句柄。 ### hWndList ```vb Property Get hWndList() As LongPtr ``` 返回列表部分的窗口句柄。 ### Font ```vb Property Get/Let/Set Font() As StdFont ``` 返回/设置控件使用的字体。 ### VisualStyles ```vb Property Get/Let VisualStyles() As Boolean ``` 返回/设置是否启用视觉样式。 ### Enabled ```vb Property Get/Let Enabled() As Boolean ``` 返回/设置控件是否可用。 ### OLEDragMode ```vb Property Get/Let OLEDragMode() As VBRUN.OLEDragConstants ``` 返回/设置 OLE 拖动模式。 ### OLEDropMode ```vb Property Get/Let OLEDropMode() As OLEDropModeConstants ``` 返回/设置 OLE 放置模式。参见通用枚举。 ### MousePointer ```vb Property Get/Let MousePointer() As CCMousePointerConstants ``` 返回/设置鼠标指针类型。参见通用枚举。 ### MouseIcon ```vb Property Get/Let/Set MouseIcon() As IPictureDisp ``` 返回/设置自定义鼠标图标。 ### MouseTrack ```vb Property Get/Let MouseTrack() As Boolean ``` 返回/设置是否启用鼠标进入/离开跟踪。 ### RightToLeft ```vb Property Get/Let RightToLeft() As Boolean ``` 返回/设置是否启用从右到左布局。 ### RightToLeftLayout ```vb Property Get/Let RightToLeftLayout() As Boolean ``` 返回/设置是否启用从右到左布局镜像。 ### RightToLeftMode ```vb Property Get/Let RightToLeftMode() As CCRightToLeftModeConstants ``` 返回/设置从右到左模式。参见通用枚举。 ### ImageList ```vb Property Get/Set/Let ImageList() As Variant ``` 返回/设置关联的 ImageList 控件，用于提供项目图标。 ### Style ```vb Property Get/Let Style() As ImcStyleConstants ``` 返回/设置组合框的样式。 ### Locked ```vb Property Get/Let Locked() As Boolean ``` 返回/设置控件是否锁定（禁止编辑和选择）。 ### Text ```vb Property Get/Let Text() As String ``` 返回/设置编辑框中的文本。 ### Default ```vb Property Get/Let Default() As String ``` 返回/设置默认值。 ### Indentation ```vb Property Get/Let Indentation() As Long ``` 返回/设置新项目的默认缩进级别。 ### ExtendedUI ```vb Property Get/Let ExtendedUI() As Boolean ``` 返回/设置是否使用扩展用户界面。 ### MaxDropDownItems ```vb Property Get/Let MaxDropDownItems() As Integer ``` 返回/设置下拉列表中可见的最大项目数。 ### ShowImages ```vb Property Get/Let ShowImages() As Boolean ``` 返回/设置是否显示项目图标。 ### MaxLength ```vb Property Get/Let MaxLength() As Long ``` 返回/设置编辑框中可输入的最大字符数。 ### IMEMode ```vb Property Get/Let IMEMode() As CCIMEModeConstants ``` 返回/设置输入法编辑器模式。参见通用枚举。 ### EllipsisFormat ```vb Property Get/Let EllipsisFormat() As ImcEllipsisFormatConstants ``` 返回/设置文本超出宽度时的省略号格式。 ### ScrollTrack ```vb Property Get/Let ScrollTrack() As Boolean ``` 返回/设置滚动条是否实时跟踪。 ### ComboItems ```vb Property Get ComboItems() As ImcComboItems ``` 返回组合框项目集合。只读。 ### SelStart ```vb Property Get/Let SelStart() As Long ``` 返回/设置选中文本的起始位置。 ### SelLength ```vb Property Get/Let SelLength() As Long ``` 返回/设置选中文本的长度。 ### SelText ```vb Property Get/Let SelText() As String ``` 返回/设置当前选中的文本。 ### TopItem ```vb Property Get/Set TopItem() As ImcComboItem ``` 返回/设置列表顶部可见的项目。 ### SelectedItem ```vb Property Get/Set SelectedItem() As ImcComboItem ``` 返回/设置当前选中的项目。 ### DroppedDown ```vb Property Get/Let DroppedDown() As Boolean ``` 返回/设置下拉列表是否展开。 ### DropDownWidth ```vb Property Get/Let DropDownWidth() As Single ``` 返回/设置下拉列表的宽度。简单样式下不支持。 ### OLEDraggedItem ```vb Property Get OLEDraggedItem() As ImcComboItem ``` 返回 OLE 拖放操作中当前被拖动的项目。只读。 ## 方法 ### OLEDrag ```vb Public Sub OLEDrag() ``` 启动 OLE 拖动操作。 ### Drag ```vb Public Sub Drag(Optional ByRef Action As Variant) ``` 开始、结束或取消拖动操作。 ### SetFocus ```vb Public Sub SetFocus() ``` 将焦点移到该控件。 ### ZOrder ```vb Public Sub ZOrder(Optional ByRef Position As Variant) ``` 设置控件在其层级中的 Z 顺序位置。 ### Refresh ```vb Public Sub Refresh() ``` 强制完全重绘控件。 ### GetItemHeight ```vb Public Function GetItemHeight() As Single ``` 返回列表项目的高度（考虑图标高度）。 ### FindItem ```vb Public Function FindItem(ByVal Text As String, Optional ByVal Index As Long, Optional ByVal Partial As Boolean, Optional ByVal Wrap As Boolean) As ImcComboItem ``` 在列表中查找项目并返回该项目的引用。Partial 为 True 时进行部分匹配，Wrap 为 True 时从开头继续搜索。 ## 事件 ### Click ```vb Public Event Click() ``` 单击控件时发生。 ### DblClick ```vb Public Event DblClick() ``` 双击控件时发生。 ### Scroll ```vb Public Event Scroll() ``` 滚动列表时发生。 ### Change ```vb Public Event Change() ``` 控件内容发生变化时发生。 ### DropDown ```vb Public Event DropDown() ``` 下拉列表即将展开时发生。 ### CloseUp ```vb Public Event CloseUp() ``` 下拉列表关闭时发生。 ### ItemDrag ```vb Public Event ItemDrag(ByVal Item As ImcComboItem, ByVal Button As Integer) ``` 项目发起拖放操作时发生。 ### BeginEdit ```vb Public Event BeginEdit() ``` 用户激活下拉列表或点击编辑框时发生。 ### EndEdit ```vb Public Event EndEdit(ByVal Changed As Boolean, ByVal NewIndex As Long, ByVal NewText As String, ByVal Reason As ImcEndEditReasonConstants) ``` 编辑操作结束时发生。Changed 指示文本是否改变，NewIndex 为新选中项索引，NewText 为新文本，Reason 为结束原因。 ### PreviewKeyDown ```vb Public Event PreviewKeyDown(ByVal KeyCode As Integer, ByRef IsInputKey As Boolean) ``` 在 KeyDown 事件之前发生，可设置 IsInputKey 标记按键是否为输入键。 ### PreviewKeyUp ```vb Public Event PreviewKeyUp(ByVal KeyCode As Integer, ByRef IsInputKey As Boolean) ``` 在 KeyUp 事件之前发生。 ### KeyDown ```vb Public Event KeyDown(KeyCode As Integer, Shift As Integer) ``` 按下键盘键时发生。 ### KeyUp ```vb Public Event KeyUp(KeyCode As Integer, Shift As Integer) ``` 释放键盘键时发生。 ### KeyPress ```vb Public Event KeyPress(KeyChar As Integer) ``` 按下并释放字符键时发生。 ### MouseDown ```vb Public Event MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` 按下鼠标按钮时发生。 ### MouseMove ```vb Public Event MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` 移动鼠标时发生。 ### MouseUp ```vb Public Event MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` 释放鼠标按钮时发生。 ### MouseEnter ```vb Public Event MouseEnter() ``` 鼠标进入控件时发生。 ### MouseLeave ```vb Public Event MouseLeave() ``` 鼠标离开控件时发生。 ### OLECompleteDrag ```vb Public Event OLECompleteDrag(Effect As Long) ``` OLE 拖放操作完成或取消后，在源控件上发生。 ### OLEDragDrop ```vb Public Event OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single) ``` 数据通过 OLE 拖放操作放置到控件上时发生。 ### OLEDragOver ```vb Public Event OLEDragOver(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single, State As Integer) ``` OLE 拖放操作期间鼠标移过控件时发生。 ### OLEGiveFeedback ```vb Public Event OLEGiveFeedback(Effect As Long, DefaultCursors As Boolean) ``` OLE 拖放操作期间需要更改鼠标光标时，在源控件上发生。 ### OLESetData ```vb Public Event OLESetData(Data As DataObject, DataFormat As Integer) ``` 放置目标请求数据时，在源控件上发生。 ### OLEStartDrag ```vb Public Event OLEStartDrag(Data As DataObject, AllowedEffects As Long) ``` OLE 拖放操作启动时发生。 ## 代码示例 ### 基本用法 ```vb Private Sub Form_Load() Set ImageCombo1.ImageList = ImageList1 With ImageCombo1 .Style = ImcStyleDropDownCombo .ShowImages = True .MaxDropDownItems = 10 End With Dim Item As ImcComboItem Set Item = ImageCombo1.ComboItems.Add(, "k1", "项目一", 1, 2) Set Item = ImageCombo1.ComboItems.Add(, "k2", "项目二", 1, 2) Set Item = ImageCombo1.ComboItems.Add(, "k3", "子项目", 3, 4) Item.Indentation = 1 End Sub Private Sub ImageCombo1_Click() If Not ImageCombo1.SelectedItem Is Nothing Then Debug.Print "选中: " & ImageCombo1.SelectedItem.Text End If End Sub Private Sub ImageCombo1_EndEdit(ByVal Changed As Boolean, ByVal NewIndex As Long, ByVal NewText As String, ByVal Reason As ImcEndEditReasonConstants) If Changed Then Debug.Print "编辑完成: " & NewText End If End Sub ``` --- --- url: /zh/vbman/redis/examples.md --- # 完整示例 本文档包含 Redis 客户端的综合使用示例。 ## 示例 1：基本的 String 操作 ```vb Sub Example1_BasicString() Dim oRedis As New cRedisClient ' 连接 If Not oRedis.Connect() Then Debug.Print "连接失败: " & oRedis.LastError Exit Sub End If ' 设置值 oRedis.Set_ "name", "张三" oRedis.Set_ "age", "25" ' 获取值 Debug.Print "姓名: " & oRedis.Get_("name") Debug.Print "年龄: " & oRedis.Get_("age") ' 设置过期时间 oRedis.Expire "name", 300 ' 检查剩余时间 Debug.Print "name 的剩余生存时间: " & oRedis.TTL("name") & " 秒" ' 断开连接 oRedis.DisConnect End Sub ``` ## 示例 2：Hash 操作 ```vb Sub Example2_HashOperations() Dim oRedis As New cRedisClient If Not oRedis.Connect() Then Debug.Print "连接失败: " & oRedis.LastError Exit Sub End If ' 设置用户信息 oRedis.HSet "user:1001", "name", "李四" oRedis.HSet "user:1001", "age", "30" oRedis.HSet "user:1001", "city", "上海" oRedis.HSet "user:1001", "email", "lisi@example.com" ' 获取单个字段 Debug.Print "用户姓名: " & oRedis.HGet("user:1001", "name") ' 获取所有字段 Dim oDict As Dictionary Set oDict = oRedis.HGetAll("user:1001") Debug.Print vbCrLf & "用户详细信息:" Dim vKey As Variant For Each vKey In oDict.Keys Debug.Print " " & vKey & ": " & oDict(vKey) Next oRedis.DisConnect End Sub ``` ## 示例 3：List 操作 ```vb Sub Example3_ListOperations() Dim oRedis As New cRedisClient If Not oRedis.Connect() Then Debug.Print "连接失败: " & oRedis.LastError Exit Sub End If ' 清空现有列表 oRedis.Del "tasks" ' 添加任务 oRedis.RPush "tasks", "任务1" oRedis.RPush "tasks", "任务2" oRedis.RPush "tasks", "任务3" oRedis.RPush "tasks", "任务4" oRedis.RPush "tasks", "任务5" ' 获取列表长度 Debug.Print "任务列表长度: " & oRedis.lLen("tasks") ' 获取所有任务 Dim vTasks As Variant vTasks = oRedis.LRange("tasks", 0, -1) Debug.Print vbCrLf & "所有任务:" Dim i As Long For i = 0 To UBound(vTasks) Debug.Print " " & (i + 1) & ". " & vTasks(i) Next ' 处理第一个任务 Debug.Print vbCrLf & "处理任务: " & oRedis.LPop("tasks") Debug.Print "剩余任务数: " & oRedis.lLen("tasks") oRedis.DisConnect End Sub ``` ## 示例 4：事务操作 ```vb Sub Example4_Transaction() Dim oRedis As New cRedisClient If Not oRedis.Connect() Then Debug.Print "连接失败: " & oRedis.LastError Exit Sub End If ' 初始化计数器 oRedis.Set_ "counter", "0" Debug.Print "初始计数: " & oRedis.Get_("counter") ' 开始事务 oRedis.Multi ' 执行多个自增操作 oRedis.Incr "counter" oRedis.Incr "counter" oRedis.Incr "counter" ' 提交事务 Dim vResults As Variant vResults = oRedis.Exec() Debug.Print "事务执行结果:" If IsArray(vResults) Then For i = 0 To UBound(vResults) Debug.Print " 操作 " & (i + 1) & " 结果: " & vResults(i) Next End If Debug.Print "最终计数: " & oRedis.Get_("counter") oRedis.DisConnect End Sub ``` ## 示例 5：Set 和 Sorted Set 操作 ```vb Sub Example5_Sets() Dim oRedis As New cRedisClient If Not oRedis.Connect() Then Debug.Print "连接失败: " & oRedis.LastError Exit Sub End If ' 使用 Set 存储标签 oRedis.SAdd "post:1:tags", "技术", "编程", "Redis", "VB6" Debug.Print "文章标签数: " & oRedis.SCard("post:1:tags") Dim vTags As Variant vTags = oRedis.SMembers("post:1:tags") Debug.Print "所有标签:" Dim i As Long For i = 0 To UBound(vTags) Debug.Print " - " & vTags(i) Next ' 使用 Sorted Set 存储排行榜 oRedis.ZAdd "leaderboard", 1000, "玩家A" oRedis.ZAdd "leaderboard", 1500, "玩家B" oRedis.ZAdd "leaderboard", 800, "玩家C" oRedis.ZAdd "leaderboard", 2000, "玩家D" Debug.Print vbCrLf & "排行榜（按分数升序）:" vTags = oRedis.ZRange("leaderboard", 0, -1) For i = 0 To UBound(vTags) Debug.Print " " & (i + 1) & ". " & vTags(i) Next Debug.Print vbCrLf & "排行榜（带分数）:" vTags = oRedis.ZRange("leaderboard", 0, -1, True) For i = 0 To UBound(vTags) Step 2 If i + 1 <= UBound(vTags) Then Debug.Print " " & vTags(i) & ": " & vTags(i + 1) & " 分" End If Next oRedis.DisConnect End Sub ``` ## 示例 6：数据库切换和批量操作 ```vb Sub Example6_MultipleDb() Dim oRedis As New cRedisClient If Not oRedis.Connect() Then Debug.Print "连接失败: " & oRedis.LastError Exit Sub End If ' 在数据库 0 中存储用户数据 oRedis.SelectDb 0 oRedis.Set_ "user:1", "张三" oRedis.Set_ "user:2", "李四" Debug.Print "数据库0中的用户: " Dim vKeys As Variant vKeys = oRedis.Keys("user:*") Dim i As Long If IsArray(vKeys) Then For i = 0 To UBound(vKeys) Debug.Print " " & vKeys(i) & ": " & oRedis.Get_(vKeys(i)) Next End If ' 在数据库 1 中存储配置数据 oRedis.SelectDb 1 oRedis.Set_ "config:appname", "MyApp" oRedis.Set_ "config:version", "1.0.0" oRedis.Set_ "config:debug", "false" Debug.Print vbCrLf & "数据库1中的配置: " vKeys = oRedis.Keys("config:*") If IsArray(vKeys) Then For i = 0 To UBound(vKeys) Debug.Print " " & vKeys(i) & ": " & oRedis.Get_(vKeys(i)) Next End If ' 批量获取配置 Dim vConfigs As Variant vConfigs = oRedis.MGet("config:appname", "config:version") Debug.Print vbCrLf & "配置信息:" If IsArray(vConfigs) Then For i = 0 To UBound(vConfigs) Debug.Print " " & vConfigs(i) Next End If ' 切换回数据库 0 oRedis.SelectDb 0 Debug.Print vbCrLf & "当前数据库: " & oRedis.DbIndex oRedis.DisConnect End Sub ``` ## 示例 7：综合应用 - 用户会话管理 ```vb Sub Example7_UserSession() Dim oRedis As New cRedisClient If Not oRedis.Connect() Then Debug.Print "连接失败: " & oRedis.LastError Exit Sub End If Dim sUserId As String sUserId = "user:123" ' 使用 Hash 存储用户信息 oRedis.HSet sUserId, "name", "张三" oRedis.HSet sUserId, "email", "zhangsan@example.com" oRedis.HSet sUserId, "login_time", CStr(Now()) ' 使用 Set 存储用户标签 oRedis.SAdd sUserId & ":tags", "VIP", "活跃", "已验证" ' 使用 List 存储最近操作 oRedis.RPush sUserId & ":history", "登录" oRedis.RPush sUserId & ":history", "浏览商品" oRedis.RPush sUserId & ":history", "加入购物车" ' 设置会话过期时间（30分钟） oRedis.Expire sUserId, 1800 oRedis.Expire sUserId & ":tags", 1800 oRedis.Expire sUserId & ":history", 1800 ' 显示用户信息 Debug.Print "=== 用户信息 ===" Dim oDict As Dictionary Set oDict = oRedis.HGetAll(sUserId) Dim vKey As Variant For Each vKey In oDict.Keys Debug.Print vKey & ": " & oDict(vKey) Next ' 显示用户标签 Debug.Print vbCrLf & "=== 用户标签 ===" Dim vTags As Variant vTags = oRedis.SMembers(sUserId & ":tags") For i = 0 To UBound(vTags) Debug.Print "- " & vTags(i) Next ' 显示最近操作 Debug.Print vbCrLf & "=== 最近操作 ===" Dim vHistory As Variant vHistory = oRedis.LRange(sUserId & ":history", -5, -1) For i = 0 To UBound(vHistory) Debug.Print (i + 1) & ". " & vHistory(i) Next oRedis.DisConnect End Sub ``` ## 示例 8：综合应用 - 电商系统 ```vb Sub Example8_ECommerce() Dim oRedis As New cRedisClient If Not oRedis.Connect() Then Debug.Print "连接失败: " & oRedis.LastError Exit Sub End If ' 1. 商品信息（Hash） Debug.Print "=== 商品信息 ===" oRedis.HSet "product:1001", "name", "iPhone 15" oRedis.HSet "product:1001", "price", "5999" oRedis.HSet "product:1001", "stock", "100" Debug.Print "商品: " & oRedis.HGet("product:1001", "name") Debug.Print "价格: ¥" & oRedis.HGet("product:1001", "price") Debug.Print "库存: " & oRedis.HGet("product:1001", "stock") ' 2. 购物车（Hash） Debug.Print vbCrLf & "=== 购物车 ===" oRedis.HSet "cart:user123", "product:1001", "2" oRedis.HSet "cart:user123", "product:1002", "1" Dim oCart As Dictionary Set oCart = oRedis.HGetAll("cart:user123") Dim lTotal As Long lTotal = 0 For Each vKey In oCart.Keys Debug.Print vKey & ": " & oCart(vKey) & " 件" lTotal = lTotal + CLng(oCart(vKey)) Next Debug.Print "总件数: " & lTotal ' 3. 热门商品（Sorted Set） Debug.Print vbCrLf & "=== 热门商品 ===" oRedis.ZAdd "hot:products", 100, "product:1001" oRedis.ZAdd "hot:products", 80, "product:1002" oRedis.ZAdd "hot:products", 150, "product:1003" Dim vHot As Variant vHot = oRedis.ZRange("hot:products", -3, -1) For i = UBound(vHot) To 0 Step -1 Dim sProductId As String sProductId = vHot(i) Debug.Print (UBound(vHot) - i + 1) & ". " & oRedis.HGet(sProductId, "name") Next ' 4. 订单队列（List） Debug.Print vbCrLf & "=== 订单队列 ===" oRedis.RPush "orders:pending", "ORDER001: " & Now() oRedis.RPush "orders:pending", "ORDER002: " & Now() Dim vOrders As Variant vOrders = oRedis.LRange("orders:pending", 0, -1) For i = 0 To UBound(vOrders) Debug.Print vOrders(i) Next ' 5. 用户标签（Set） Debug.Print vbCrLf & "=== 用户标签 ===" oRedis.SAdd "user:123:tags", "VIP", "活跃", "新用户" vTags = oRedis.SMembers("user:123:tags") For i = 0 To UBound(vTags) Debug.Print "- " & vTags(i) Next oRedis.DisConnect End Sub ``` ## 示例 9：错误处理 ```vb Sub Example9_ErrorHandling() Dim oRedis As New cRedisClient ' 连接 If Not oRedis.Connect() Then Debug.Print "连接失败: " & oRedis.LastError Exit Sub End If ' 检查错误 If oRedis.LastError <> "" Then Debug.Print "连接错误: " & oRedis.LastError oRedis.DisConnect Exit Sub End If ' 执行操作 oRedis.Set_ "test", "value" If oRedis.LastError <> "" Then Debug.Print "操作错误: " & oRedis.LastError Else Debug.Print "操作成功" End If ' 获取不存在的键 Dim sValue As String sValue = oRedis.Get_("nonexistent") If sValue = "" Then Debug.Print "键不存在" End If oRedis.DisConnect End Sub ``` ## 示例 10：连接管理最佳实践 ```vb Sub Example10_ConnectionManagement() Dim oRedis As cRedisClient Set oRedis = New cRedisClient ' 连接 If Not oRedis.Connect() Then Debug.Print "连接失败: " & oRedis.LastError GoTo Cleanup End If ' 使用连接 oRedis.Set_ "key", "value" Debug.Print "设置的值: " & oRedis.Get_("key") Cleanup: ' 确保断开连接 If Not oRedis Is Nothing Then If oRedis.Connected Then oRedis.DisConnect End If Set oRedis = Nothing End If End Sub ``` ## 运行示例 您可以直接复制上述代码到 VB6 或 VBA 环境中运行。确保： 1. 已添加对 `cRedisClient` 类的引用 2. 已添加对 `Dictionary` 的引用（Microsoft Scripting Runtime） 3. Redis 服务器正在运行并可访问 ## 示例输出 运行上述示例后，您将在立即窗口（Immediate Window）中看到类似以下的输出： ``` === 用户信息 === name: 张三 email: zhangsan@example.com login_time: 2024-01-01 10:30:00 === 用户标签 === - VIP - 活跃 - 已验证 === 最近操作 === 1. 登录 2. 浏览商品 3. 加入购物车 ``` ## 更多示例 如需更多特定场景的示例，请参考： * [连接管理](./connection.md) - 连接相关的示例 * [String 操作](./string-operations.md) - String 操作示例 * [Hash 操作](./hash-operations.md) - Hash 操作示例 * [List 操作](./list-operations.md) - List 操作示例 * [Set 操作](./set-operations.md) - Set 操作示例 * [Sorted Set 操作](./sorted-set-operations.md) - Sorted Set 操作示例 * [事务操作](./transaction.md) - 事务操作示例 --- --- url: /zh/packages/vbccr/text/textboxw.md description: 文本框控件（TextBoxW） - VBCCR 开发手册，基于源码的完整 API 参考 --- # 文本框控件（TextBoxW） 提供增强的文本框，支持Unicode、密码字符、气球提示、网络地址验证、拖放文件和OLE拖放。 ## 枚举 ### TxtCharacterCasingConstants 字符大小写常量。 | 常量 | 值 | 说明 | |------|-----|------| | TxtCharacterCasingNormal | 0 | 正常（不转换大小写） | | TxtCharacterCasingUpper | 1 | 转换为大写 | | TxtCharacterCasingLower | 2 | 转换为小写 | ### TxtIconConstants 气球提示图标常量。 | 常量 | 值 | 说明 | |------|-----|------| | TxtIconNone | 0 | 无图标 | | TxtIconInfo | 1 | 信息图标 | | TxtIconWarning | 2 | 警告图标 | | TxtIconError | 3 | 错误图标 | ### TxtNetAddressFormatConstants 网络地址格式常量。 | 常量 | 值 | 说明 | |------|-----|------| | TxtNetAddressFormatString | 0 | 字符串格式 | | TxtNetAddressFormatHostName | 1 | 主机名格式 | | TxtNetAddressFormatIPv4 | 2 | IPv4格式 | | TxtNetAddressFormatIPv6 | 3 | IPv6格式 | ### TxtNetAddressTypeConstants 网络地址类型常量。 | 常量 | 值 | 说明 | |------|-----|------| | TxtNetAddressTypeNone | 0 | 无 | | TxtNetAddressTypeIPv4 | 1 | IPv4地址 | | TxtNetAddressTypeIPv6 | 2 | IPv6地址 | | TxtNetAddressTypeIPv6WithScope | 3 | 带作用域的IPv6地址 | | TxtNetAddressTypeDNS | 4 | DNS名称 | | TxtNetAddressTypeNetBIOS | 5 | NetBIOS名称 | | TxtNetAddressTypeUnspecified | 6 | 未指定类型 | | TxtNetAddressTypeNamedPipe | 7 | 命名管道 | | TxtNetAddressTypeEmailAddress | 8 | 电子邮件地址 | | TxtNetAddressTypeURL | 9 | URL地址 | | TxtNetAddressTypeURLKnownSuffix | 10 | 已知后缀的URL | | TxtNetAddressTypeFriendlyDNS | 11 | 友好DNS名称 | | TxtNetAddressTypeDNSSimpleLabel | 12 | 单标签DNS名称 | | TxtNetAddressTypeAddressMask | 13 | 地址掩码 | | TxtNetAddressTypeFileName | 14 | 文件名 | | TxtNetAddressTypeAny | 15 | 任意地址 | | TxtNetAddressTypeAnyLocal | 16 | 任意本地地址 | | TxtNetAddressTypeIPv4MappedIPv6 | 17 | IPv4映射的IPv6地址 | | TxtNetAddressTypeIPv4TranslatedIPv6 | 18 | IPv4转换的IPv6地址 | | TxtNetAddressTypeIPv4TeredoIPv6 | 19 | Teredo IPv6地址 | ## 属性 ### Name ```vb Public Property Get Name() As String ``` 返回在代码中标识对象的名称。 ### Tag ```vb Public Property Get Tag() As String Public Property Let Tag(ByVal Value As String) ``` 存储程序所需的额外数据。 ### Parent ```vb Public Property Get Parent() As Object ``` 返回对象所在的对象。 ### Container ```vb Public Property Get Container() As Object Public Property Set Container(ByVal Value As Object) ``` 返回/设置对象的容器。 ### Left ```vb Public Property Get Left() As Single Public Property Let Left(ByVal Value As Single) ``` 返回/设置对象与其容器左边缘的距离。 ### Top ```vb Public Property Get Top() As Single Public Property Let Top(ByVal Value As Single) ``` 返回/设置对象与其容器顶边缘的距离。 ### Width ```vb Public Property Get Width() As Single Public Property Let Width(ByVal Value As Single) ``` 返回/设置对象的宽度。 ### Height ```vb Public Property Get Height() As Single Public Property Let Height(ByVal Value As Single) ``` 返回/设置对象的高度。 ### Visible ```vb Public Property Get Visible() As Boolean Public Property Let Visible(ByVal Value As Boolean) ``` 返回/设置对象是否可见。 ### ToolTipText ```vb Public Property Get ToolTipText() As String Public Property Let ToolTipText(ByVal Value As String) ``` 返回/设置鼠标悬停时显示的提示文本。 ### WhatsThisHelpID ```vb Public Property Get WhatsThisHelpID() As Long Public Property Let WhatsThisHelpID(ByVal Value As Long) ``` 返回/设置关联的上下文帮助ID。 ### DragIcon ```vb Public Property Get DragIcon() As IPictureDisp Public Property Let DragIcon(ByVal Value As IPictureDisp) Public Property Set DragIcon(ByVal Value As IPictureDisp) ``` 返回/设置拖放操作中显示的图标。 ### DragMode ```vb Public Property Get DragMode() As Integer Public Property Let DragMode(ByVal Value As Integer) ``` 返回/设置拖动模式（手动或自动）。 ### hWnd ```vb Public Property Get hWnd() As LongPtr ``` 返回控件句柄。 ### hWndUserControl ```vb Public Property Get hWndUserControl() As LongPtr ``` 返回UserControl句柄。 ### Font ```vb Public Property Get Font() As StdFont Public Property Let Font(ByVal NewFont As StdFont) Public Property Set Font(ByVal NewFont As StdFont) ``` 返回/设置字体。 ### VisualStyles ```vb Public Property Get VisualStyles() As Boolean Public Property Let VisualStyles(ByVal Value As Boolean) ``` 返回/设置是否启用视觉样式。需要comctl32.dll 6.0或更高版本。 ### BackColor ```vb Public Property Get BackColor() As OLE_COLOR Public Property Let BackColor(ByVal Value As OLE_COLOR) ``` 返回/设置背景色。 ### ForeColor ```vb Public Property Get ForeColor() As OLE_COLOR Public Property Let ForeColor(ByVal Value As OLE_COLOR) ``` 返回/设置前景色。 ### Enabled ```vb Public Property Get Enabled() As Boolean Public Property Let Enabled(ByVal Value As Boolean) ``` 返回/设置对象是否能响应用户事件。 ### AllowDropFiles ```vb Public Property Get AllowDropFiles() As Boolean Public Property Let AllowDropFiles(ByVal Value As Boolean) ``` 返回/设置是否允许拖放文件。 ### OLEDragMode ```vb Public Property Get OLEDragMode() As Integer Public Property Let OLEDragMode(ByVal Value As Integer) ``` 返回/设置OLE拖动模式。 ### OLEDragDropScroll ```vb Public Property Get OLEDragDropScroll() As Boolean Public Property Let OLEDragDropScroll(ByVal Value As Boolean) ``` 返回/设置OLE拖放时是否自动滚动。 ### OLEDropMode ```vb Public Property Get OLEDropMode() As OLEDropModeConstants Public Property Let OLEDropMode(ByVal Value As OLEDropModeConstants) ``` 返回/设置对象是否可以作为OLE放置目标。 ### MousePointer ```vb Public Property Get MousePointer() As CCMousePointerConstants Public Property Let MousePointer(ByVal Value As CCMousePointerConstants) ``` 返回/设置鼠标悬停时显示的指针类型。参见通用枚举。 ### MouseIcon ```vb Public Property Get MouseIcon() As IPictureDisp Public Property Let MouseIcon(ByVal Value As IPictureDisp) Public Property Set MouseIcon(ByVal Value As IPictureDisp) ``` 返回/设置自定义鼠标图标。 ### MouseTrack ```vb Public Property Get MouseTrack() As Boolean Public Property Let MouseTrack(ByVal Value As Boolean) ``` 返回/设置是否在鼠标进入或离开控件时触发事件。 ### RightToLeft ```vb Public Property Get RightToLeft() As Boolean Public Property Let RightToLeft(ByVal Value As Boolean) ``` 返回/设置从右到左显示方向。 ### RightToLeftMode ```vb Public Property Get RightToLeftMode() As CCRightToLeftModeConstants Public Property Let RightToLeftMode(ByVal Value As CCRightToLeftModeConstants) ``` 返回/设置从右到左模式。参见通用枚举。 ### BorderStyle ```vb Public Property Get BorderStyle() As Integer Public Property Let BorderStyle(ByVal Value As Integer) ``` 返回/设置边框样式。 ### Text ```vb Public Property Get Text() As String Public Property Let Text(ByVal Value As String) ``` 返回/设置文本内容。 ### Default ```vb Public Property Get Default() As Boolean Public Property Let Default(ByVal Value As Boolean) ``` 返回/设置是否为默认按钮（按Enter键触发）。 ### Alignment ```vb Public Property Get Alignment() As AlignmentConstants Public Property Let Alignment(ByVal Value As AlignmentConstants) ``` 返回/设置文本对齐方式。 ### AllowOnlyNumbers ```vb Public Property Get AllowOnlyNumbers() As Boolean Public Property Let AllowOnlyNumbers(ByVal Value As Boolean) ``` 返回/设置是否只允许输入数字。 ### Locked ```vb Public Property Get Locked() As Boolean Public Property Let Locked(ByVal Value As Boolean) ``` 返回/设置是否锁定编辑（仍可滚动和选择）。 ### HideSelection ```vb Public Property Get HideSelection() As Boolean Public Property Let HideSelection(ByVal Value As Boolean) ``` 返回/设置控件失去焦点时是否隐藏选中内容的突出显示。 ### PasswordChar ```vb Public Property Get PasswordChar() As String Public Property Let PasswordChar(ByVal Value As String) ``` 返回/设置密码掩码字符。 ### UseSystemPasswordChar ```vb Public Property Get UseSystemPasswordChar() As Boolean Public Property Let UseSystemPasswordChar(ByVal Value As Boolean) ``` 返回/设置是否使用系统默认密码字符。 ### MultiLine ```vb Public Property Get MultiLine() As Boolean Public Property Let MultiLine(ByVal Value As Boolean) ``` 返回/设置是否接受多行文本输入。 ### MaxLength ```vb Public Property Get MaxLength() As Long Public Property Let MaxLength(ByVal Value As Long) ``` 返回/设置最大字符数。0表示不限制。 ### ScrollBars ```vb Public Property Get ScrollBars() As Integer Public Property Let ScrollBars(ByVal Value As Integer) ``` 返回/设置滚动条样式。 ### CueBanner ```vb Public Property Get CueBanner() As String Public Property Let CueBanner(ByVal Value As String) ``` 返回/设置提示横幅文本（控件为空时显示）。 ### CueBannerAlways ```vb Public Property Get CueBannerAlways() As Boolean Public Property Let CueBannerAlways(ByVal Value As Boolean) ``` 返回/设置提示横幅是否始终显示（即使控件有焦点）。 ### CharacterCasing ```vb Public Property Get CharacterCasing() As TxtCharacterCasingConstants Public Property Let CharacterCasing(ByVal Value As TxtCharacterCasingConstants) ``` 返回/设置字符大小写转换方式。 ### WantReturn ```vb Public Property Get WantReturn() As Boolean Public Property Let WantReturn(ByVal Value As Boolean) ``` 返回/设置多行文本框中按Enter键是否插入换行符。 ### IMEMode ```vb Public Property Get IMEMode() As CCIMEModeConstants Public Property Let IMEMode(ByVal Value As CCIMEModeConstants) ``` 返回/设置输入法编辑器模式。参见通用枚举。 ### NetAddressValidator ```vb Public Property Get NetAddressValidator() As Boolean Public Property Let NetAddressValidator(ByVal Value As Boolean) ``` 返回/设置是否启用网络地址验证。 ### NetAddressType ```vb Public Property Get NetAddressType() As TxtNetAddressTypeConstants Public Property Let NetAddressType(ByVal Value As TxtNetAddressTypeConstants) ``` 返回/设置网络地址验证的类型。 ### AllowOverType ```vb Public Property Get AllowOverType() As Boolean Public Property Let AllowOverType(ByVal Value As Boolean) ``` 返回/设置是否允许改写模式。 ### OverTypeMode ```vb Public Property Get OverTypeMode() As Boolean Public Property Let OverTypeMode(ByVal Value As Boolean) ``` 返回/设置是否处于改写模式。 ### Modified ```vb Public Property Get Modified() As Boolean Public Property Let Modified(ByVal Value As Boolean) ``` 返回/设置文本是否已被修改。 ### TextLength ```vb Public Property Get TextLength() As Long ``` 返回文本长度。 ### SelStart ```vb Public Property Get SelStart() As Long Public Property Let SelStart(ByVal Value As Long) ``` 返回/设置选中内容的起始位置。 ### SelLength ```vb Public Property Get SelLength() As Long Public Property Let SelLength(ByVal Value As Long) ``` 返回/设置选中内容的长度。 ### SelText ```vb Public Property Get SelText() As String Public Property Let SelText(ByVal Value As String) ``` 返回/设置选中内容的文本。 ### LeftMargin ```vb Public Property Get LeftMargin() As Long Public Property Let LeftMargin(ByVal Value As Long) ``` 返回/设置左边距。 ### RightMargin ```vb Public Property Get RightMargin() As Long Public Property Let RightMargin(ByVal Value As Long) ``` 返回/设置右边距。 ## 方法 ### Refresh ```vb Public Sub Refresh() ``` 强制完全重绘对象。 ### Copy ```vb Public Sub Copy() ``` 将选中内容复制到剪贴板。 ### Cut ```vb Public Sub Cut() ``` 将选中内容剪切到剪贴板。 ### Paste ```vb Public Sub Paste() ``` 将剪贴板内容粘贴到控件。 ### Clear ```vb Public Sub Clear() ``` 清除所有文本。 ### Undo ```vb Public Sub Undo() ``` 撤销上一次操作。 ### CanUndo ```vb Public Function CanUndo() As Boolean ``` 返回是否可以撤销。 ### ResetUndoQueue ```vb Public Sub ResetUndoQueue() ``` 重置撤销队列。 ### OLEDrag ```vb Public Sub OLEDrag() ``` 启动OLE拖放操作。 ### GetLine ```vb Public Function GetLine(ByVal LineIndex As Long) As String ``` 获取指定行的文本内容。 ### GetLineCount ```vb Public Function GetLineCount() As Long ``` 获取文本行数。 ### ScrollToLine ```vb Public Sub ScrollToLine(ByVal LineIndex As Long) ``` 滚动到指定行。 ### ScrollToCaret ```vb Public Sub ScrollToCaret() ``` 滚动到光标位置。 ### CharFromPos ```vb Public Function CharFromPos(ByVal X As Long, ByVal Y As Long) As Long ``` 根据坐标获取字符索引。 ### GetLineFromChar ```vb Public Function GetLineFromChar(ByVal CharIndex As Long) As Long ``` 根据字符索引获取行号。 ### ShowBalloonTip ```vb Public Sub ShowBalloonTip(ByVal Title As String, ByVal Text As String, ByVal Icon As TxtIconConstants) ``` 显示气球提示。 ### HideBalloonTip ```vb Public Sub HideBalloonTip() ``` 隐藏气球提示。 ### ValidateNetAddress ```vb Public Function ValidateNetAddress() As Long ``` 验证网络地址，返回0表示有效。 ### ShowNetAddressErrorTip ```vb Public Sub ShowNetAddressErrorTip() ``` 根据验证结果显示网络地址错误提示。 ### NetAddressFormat ```vb Public Property Get NetAddressFormat() As TxtNetAddressFormatConstants ``` 返回网络地址格式。 ### NetAddressString ```vb Public Property Get NetAddressString() As String ``` 返回网络地址字符串。 ### NetAddressPortNumber ```vb Public Property Get NetAddressPortNumber() As Long ``` 返回网络地址端口号。 ### NetAddressPrefixLength ```vb Public Property Get NetAddressPrefixLength() As Long ``` 返回网络地址前缀长度。 ### Drag ```vb Public Sub Drag(Optional ByRef Action As Variant) ``` 开始、结束或取消拖动操作。 ### SetFocus ```vb Public Sub SetFocus() ``` 将焦点移至控件。 ### ZOrder ```vb Public Sub ZOrder(Optional ByRef Position As Variant) ``` 设置Z顺序。 ## 事件 ### Click ```vb Public Event Click() ``` 用户单击控件时触发。 ### DblClick ```vb Public Event DblClick() ``` 用户双击控件时触发。 ### Change ```vb Public Event Change() ``` 文本内容改变时触发。 ### MaxText ```vb Public Event MaxText() ``` 输入文本超过MaxLength限制时触发。 ### DropFiles ```vb Public Event DropFiles(ByVal Files As Variant) ``` 拖放文件到控件时触发。Files为文件路径数组。 ### Scroll ```vb Public Event Scroll() ``` 文本滚动时触发。 ### ContextMenu ```vb Public Event ContextMenu(ByVal X As Single, ByVal Y As Single, ByRef Handled As Boolean) ``` 请求上下文菜单时触发。Handled为True时取消默认菜单。 ### PreviewKeyDown ```vb Public Event PreviewKeyDown(KeyCode As Integer, Shift As Integer) ``` 在KeyDown事件之前触发，用于预处理键盘输入。 ### PreviewKeyUp ```vb Public Event PreviewKeyUp(KeyCode As Integer, Shift As Integer) ``` 在KeyUp事件之前触发。 ### KeyDown ```vb Public Event KeyDown(KeyCode As Integer, Shift As Integer) ``` 按下键盘按键时触发。 ### KeyUp ```vb Public Event KeyUp(KeyCode As Integer, Shift As Integer) ``` 释放键盘按键时触发。 ### KeyPress ```vb Public Event KeyPress(KeyAscii As Integer) ``` 按下并释放ANSI键时触发。 ### MouseDown ```vb Public Event MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` 按下鼠标按钮时触发。 ### MouseMove ```vb Public Event MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` 移动鼠标时触发。 ### MouseUp ```vb Public Event MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` 释放鼠标按钮时触发。 ### MouseEnter ```vb Public Event MouseEnter() ``` 鼠标进入控件区域时触发。 ### MouseLeave ```vb Public Event MouseLeave() ``` 鼠标离开控件区域时触发。 ### OLECompleteDrag ```vb Public Event OLECompleteDrag(Effect As Long) ``` OLE拖放操作完成时触发。 ### OLEDragDrop ```vb Public Event OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single) ``` OLE拖放操作放置时触发。 ### OLEDragOver ```vb Public Event OLEDragOver(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single, State As Integer) ``` OLE拖放操作悬停时触发。 ### OLEGiveFeedback ```vb Public Event OLEGiveFeedback(Effect As Long, DefaultCursors As Boolean) ``` OLE拖放操作给反馈时触发。 ### OLESetData ```vb Public Event OLESetData(Data As DataObject, DataFormat As Integer) ``` OLE拖放操作设置数据时触发。 ### OLEStartDrag ```vb Public Event OLEStartDrag(Data As DataObject, AllowedEffects As Long) ``` OLE拖放操作开始时触发。 ## 代码示例 ### 基本用法 ```vb ' 设置多行文本框 With TextBoxW1 .MultiLine = True .ScrollBars = 3 .MaxLength = 5000 .WantReturn = True .CueBanner = "请输入内容..." End With ' 使用密码框 With TextBoxW1 .PasswordChar = "*" .UseSystemPasswordChar = True .MaxLength = 20 End With ' 网络地址验证 TextBoxW1.NetAddressValidator = True TextBoxW1.NetAddressType = TxtNetAddressTypeURL Private Sub Command1_Click() If TextBoxW1.ValidateNetAddress() = 0 Then MsgBox "地址有效: " & TextBoxW1.NetAddressString Else TextBoxW1.ShowNetAddressErrorTip End If End Sub ' 气球提示 TextBoxW1.ShowBalloonTip "输入错误", "请输入有效的邮箱地址", TxtIconError ' 拖放文件 Private Sub TextBoxW1_DropFiles(ByVal Files As Variant) Dim i As Long For i = LBound(Files) To UBound(Files) Debug.Print "文件: " & Files(i) Next i End Sub ``` --- --- url: /zh/biz/cs-auther/filetransfer.md --- # 文件传输系统 ## 概述 `cs-auther` 的文件传输系统基于 **TCP 独立连接** 实现，与主消息通道分离，支持大文件的分片传输、断点续传、进度监控和安全验证。 *** ## 架构设计 ``` ┌─────────────────────────────────────────────────────────────────────────────┐ │ 文件传输架构图 │ ├─────────────────────────────────────────────────────────────────────────────┤ │ │ │ ┌─────────────────────┐ ┌─────────────────────┐ │ │ │ 客户端 │ │ 服务端 │ │ │ │ ┌───────────────┐ │ TCP:801 │ ┌───────────────┐ │ │ │ │ │ cFileClient │◄─┼───────────────────►┼─►│ cFileServer │ │ │ │ │ │ (发送/接收) │ │ 独立文件传输通道 │ │ (接收/发送) │ │ │ │ │ └───────┬───────┘ │ │ └───────┬───────┘ │ │ │ │ │ │ │ │ │ │ │ │ ┌───────▼───────┐ │ │ ┌───────▼───────┐ │ │ │ │ │ 业务事件 │ │ │ │ bFileManage │ │ │ │ │ │ OnSending │ │ │ │ (文件管理) │ │ │ │ │ │ OnRecving │ │ │ │ 自动归档存储 │ │ │ │ │ │ OnSendFinish │ │ │ │ 日志记录 │ │ │ │ │ │ OnRecvFinish │ │ │ └───────────────┘ │ │ │ │ └───────────────┘ │ │ │ │ │ └─────────────────────┘ └─────────────────────┘ │ │ │ │ ┌─────────────────────────────────────────────────────────────────────┐ │ │ │ 主消息通道 (TCP:800) │ │ │ │ 用于控制命令和文件列表查询 │ │ │ └─────────────────────────────────────────────────────────────────────┘ │ │ │ └─────────────────────────────────────────────────────────────────────────────┘ ``` ### 端口分配 | 服务 | 端口 | 说明 | | -------- | ---- | ----------------------- | | 消息服务 | 800 | JSON 协议，处理业务逻辑 | | 文件服务 | 801 | 分片传输，处理文件数据 | *** ## 核心组件 ### 1. cFileClient (客户端) 位于 `share/cFileClient.cls`，封装了客户端文件传输的所有功能。 #### 主要属性 | 属性 | 类型 | 说明 | | ----------- | ------ | ------------------- | | `ChunkSize` | Long | 分片大小，默认 32KB | | `LastError` | String | 最后一次错误信息 | #### 主要方法 ```vb ' 连接到文件服务器 Public Sub StartConnectTo(ByVal Server As String, Optional ByVal Port As Long = 803) ' 断开连接 Public Sub Disconnect() ' 发送文件到服务端 Public Function SendToServer(ByVal FileName As String) As Boolean ' 服务端回调：接收文件分片 Public Sub RecvFromServer(Inst As cWinsock, Data As cJson) ' 服务端回调：请求下一个分片 Public Sub SendMeNextFileChunk(Inst As cWinsock, Data As cJson) ' 服务端回调：发送完成确认 Public Sub OnSendComplete(Inst As cWinsock, Data As cJson) ``` #### 事件 ```vb ' 正在发送文件 Event OnSending(ByVal FileName As String, ByVal CurrentChunk As Long, ByVal TotalChunks As Long, ByVal Percent As Long) ' 正在接收文件 Event OnRecving(ByVal FileName As String, ByVal CurrentChunk As Long, ByVal TotalChunks As Long, ByVal Percent As Long) ' 发送完成 Event OnSendFinish(ByVal FileName As String) ' 接收完成 Event OnRecvFinish(ByVal FileName As String, ByVal FilePath As String) ``` *** ### 2. cFileServer (服务端) 位于 `share/cFileServer.cls`，处理多客户端并发文件传输。 #### 主要属性 | 属性 | 类型 | 说明 | | ----------- | ------ | ------------------- | | `ChunkSize` | Long | 分片大小，默认 32KB | | `LastError` | String | 最后一次错误信息 | #### 主要方法 ```vb ' 启动文件服务 Public Sub StartMe(Optional Port As Long = 801, Optional IP As String = "0.0.0.0") ' 停止服务 Public Sub StopServer() ' 发送文件给指定用户 Public Function SendToClient(ByVal User As String, ByVal FileName As String) As Boolean ' 客户端回调：绑定Token Public Sub BindClientToken(Inst As cWinsock, Data As cJson) ' 客户端回调：接收文件分片 Public Sub RecvFromClient(Inst As cWinsock, Data As cJson) ' 客户端回调：请求下一个分片 Public Sub SendMeNextFileChunk(Inst As cWinsock, Data As cJson) ``` #### 事件 ```vb ' 客户端正在上传 Event OnClientSending(ByVal User As String, ByVal FileName As String, ByVal CurrentChunk As Long, ByVal TotalChunks As Long, ByVal Percent As Long) ' 客户端上传完成 Event OnClientSendFinish(ByVal User As String, ByVal FileName As String, ByVal FilePath As String) ' 正在发送给客户端 Event OnClientRecving(ByVal User As String, ByVal FileName As String, ByVal CurrentChunk As Long, ByVal TotalChunks As Long, ByVal Percent As Long) ' 发送给客户端完成 Event OnClientRecvFinish(ByVal User As String, ByVal FileName As String) ``` *** ### 3. bFileManage (业务管理层) 位于 `src-server/bFileManage.cls`，在 `cFileServer` 之上封装业务逻辑。 #### 主要功能 * **自动归档**：接收的文件自动按用户/年月分类存储 * **独立日志**：文件传输日志与系统日志分离 * **文件管理**：提供文件列表查询、删除等接口 #### 存储结构 ``` Server.exe 同目录 └── files/ └── {用户名}/ └── {年}/ └── {月}/ └── 文件名_年月日_时分秒.ext ``` #### 路由接口 ```vb ' 获取当前用户的文件列表 Public Sub GetMyFilesList(Inst As cWinsock, Data As cJson) → 响应: FileManage/OnFilesList ' 删除指定文件 Public Sub DeleteMyFile(Inst As cWinsock, Data As cJson) → 响应: FileManage/OnFileDeleted ``` *** ## 传输协议 ### 分片数据结构 文件传输使用 JSON 协议，每个分片包含以下字段： ```json { "FileID": "GUID字符串", "FileName": "原始文件名", "FileSize": 1048576, "ChunkSize": 32768, "TotalChunks": 32, "CurrentChunk": 5, "NextChunk": 6, "ChunkData": "Base64编码的数据...", "IsLastChunk": false } ``` ### 传输流程 #### 客户端 → 服务端（上传） ``` ┌─────────┐ ┌─────────┐ │ Client │ │ Server │ └────┬────┘ └────┬────┘ │ │ │ 1. 发送第1片 (CurrentChunk=1) │ │ ────────────────────────────────────────────────>│ │ action: "FileServer/RecvFromClient" │ │ │ │ │──┐ 写入临时文件 │ │ │ files/tmp/{FileID}.tmp │ │<-┘ │ │ │ 2. 请求第2片 │ │ <────────────────────────────────────────────────│ │ action: "FileClient/SendMeNextFileChunk" │ │ { "NextChunk": 2 } │ │ │ │ 3. 发送第2片 │ │ ────────────────────────────────────────────────>│ │ ... │ │ │ │ n. 发送最后一片 (IsLastChunk=true) │ │ ────────────────────────────────────────────────>│ │ │ │ n+1. 发送完成确认 │ │ <────────────────────────────────────────────────│ │ action: "FileClient/OnSendComplete" │ │ │──┐ 归档到目标目录 │ │ │ files/{user}/{yyyy}/{mm}/ │ │<-┘ ``` #### 服务端 → 客户端（下发） ``` ┌─────────┐ ┌─────────┐ │ Client │ │ Server │ └────┬────┘ └────┬────┘ │ │ │ 1. 发送第1片 │ │ <────────────────────────────────────────────────│ │ action: "FileClient/RecvFromServer" │ │ │ │──┐ 写入临时文件 │ │ │ {FileID}.tmp │ │<-┘ │ │ │ │ 2. 请求下一片 │ │ ────────────────────────────────────────────────>│ │ action: "FileServer/SendMeNextFileChunk" │ │ │ │ 3. 发送下一片 │ │ <────────────────────────────────────────────────│ │ ... │ │ │ │ n. 发送完成 │ │ <────────────────────────────────────────────────│ │ (服务端清理资源) │ ``` *** ## 身份验证 文件传输通道使用 Token 绑定机制进行身份验证： ### 连接建立流程 ```vb ' 客户端连接成功后，自动发送 Token 绑定 Private Sub mTcp_Connect(Client As VBMANLIB.cWinsock) With New cJson .Item("token") = Common.UserToken ' 从登录获取的凭证 Set .Item("user") = Insts.CurrentUser.Root ' 当前用户信息 Common.SendTo Client, "FileServer/BindClientToken", .Root End With End Sub ``` ### 服务端绑定处理 ```vb Public Sub BindClientToken(Inst As cWinsock, Data As cJson) Inst.CurrentUserToken = Data("token") Inst.CurrentUserInfo.Decode Data("user") Inst.CurrentUser = Data("user")("UserName") End Sub ``` > **注意**：文件传输通道继承主消息通道的 Token，连接时需要显式绑定才能通过中间件验证。 *** ## 使用示例 ### 客户端发送文件 ```vb Dim WithEvents FileClient As cFileClient ' 初始化并连接 Set FileClient = New cFileClient FileClient.StartConnectTo "192.168.1.100", 801 ' 发送文件 If FileClient.SendToServer("C:\Documents\report.pdf") Then Debug.Print "开始发送..." Else Debug.Print "发送失败: " & FileClient.LastError End If ' 监听进度 Private Sub FileClient_OnSending(ByVal FileName As String, ByVal CurrentChunk As Long, ByVal TotalChunks As Long, ByVal Percent As Long) ProgressBar1.Value = Percent Label1.Caption = "发送中: " & Percent & "%" End Sub ' 发送完成 Private Sub FileClient_OnSendFinish(ByVal FileName As String) MsgBox "文件发送完成: " & FileName End Sub ``` ### 服务端主动下发文件 ```vb ' 在 bFileManage 中调用 Public Sub SendFileToUser_Click() Dim UserName As String UserName = "zhangsan" If bFileManage.SendFileToUser(UserName, "C:\Files\notice.pdf") Then Debug.Print "开始发送给 " & UserName End If End Sub ``` ### 获取文件列表 ```vb ' 客户端请求 With New cJson Common.SendTo Insts.TcpClient, "FileManage/GetMyFilesList", .Root End With ' 客户端接收响应 (在 bFileManage 中实现) Public Sub OnFilesList(Data As cJson) ' Data.Root 包含文件列表数组 For Each FileItem In Data.Root ListView.AddItem FileItem("Name") Next End Sub ``` *** ## 配置说明 ### 分片大小调整 ```vb ' 客户端 FileClient.ChunkSize = 64& * 1024& ' 设置为 64KB ' 服务端 bFileManage.StartMe Port mFileServer.ChunkSize = 1024& * 1024& ' 设置为 1MB ``` > **建议**： > > * 局域网环境：64KB ~ 1MB > * 互联网环境：16KB ~ 32KB > * 超大文件：增大分片可减少协议开销 *** ## 错误处理 ### 常见错误 | 错误信息 | 原因 | 解决方案 | | -------------------- | ---------------------- | ------------------------------------------- | | 当前有正在发送的文件 | 同时发起多个发送请求 | 等待当前传输完成或创建新的 cFileClient 实例 | | 用户不在线 | 服务端下发时用户已断开 | 检查用户在线状态后再发送 | | 临时文件不存在 | 文件被清理或权限问题 | 检查目录权限和磁盘空间 | ### 事件中的错误处理 ```vb Private Sub FileClient_OnSendFinish(ByVal FileName As String) If FileClient.LastError <> "" Then MsgBox "传输出错: " & FileClient.LastError Else MsgBox "传输成功!" End If End Sub ``` *** ## 性能优化 1. **并发传输**：每个用户独立维护传输状态，支持多用户同时传输 2. **分片缓存**：接收时直接追加写入临时文件，减少内存占用 3. **Base64 编码**：兼容 JSON 传输，相比二进制略增 33% 体积 4. **独立通道**：文件传输与业务消息分离，避免阻塞 *** ## 安全建议 1. **文件类型过滤**：在 `bFileManage.OnClientSendFinish` 中检查扩展名 2. **大小限制**：在发送前检查 `FileSize` 是否超过限制 3. **路径校验**：`DeleteMyFile` 中已包含安全校验，确保只能删除自己的文件 4. **Token 过期**：与主通道 Token 生命周期保持一致 --- --- url: /zh/emoji/07C0-07FF.md --- # 西非書面語言 (N'Ko) 本页面展示了Unicode字符集中，位于U+07C0到U+07FF范围的西非書面語言字符。N'Ko是一种在西非使用的书写系统，由Solomana Kante在1949年发明。 | 字符 | Unicode | VB函数值 | 名称 | |:---:|:---:|:---:|:---| | ߀ | U+07C0 | ChrW(\&H07C0) | N'Ko数字零 | | ߁ | U+07C1 | ChrW(\&H07C1) | N'Ko数字一 | | ߂ | U+07C2 | ChrW(\&H07C2) | N'Ko数字二 | | ߃ | U+07C3 | ChrW(\&H07C3) | N'Ko数字三 | | ߄ | U+07C4 | ChrW(\&H07C4) | N'Ko数字四 | | ߅ | U+07C5 | ChrW(\&H07C5) | N'Ko数字五 | | ߆ | U+07C6 | ChrW(\&H07C6) | N'Ko数字六 | | ߇ | U+07C7 | ChrW(\&H07C7) | N'Ko数字七 | | ߈ | U+07C8 | ChrW(\&H07C8) | N'Ko数字八 | | ߉ | U+07C9 | ChrW(\&H07C9) | N'Ko数字九 | --- --- url: /zh/emoji/0400-04FF.md --- # 西里尔字母 (Cyrillic) 本页面展示了Unicode字符集中，位于U+0400到U+04FF范围的西里尔字母字符。西里尔字母是一种使用在斯拉夫语言中的字母系统，主要用于俄语、乌克兰语、白俄罗斯语等语言。 | 字符 | Unicode | VB函数值 | 名称 | |:---:|:---:|:---:|:---| | Ѐ | U+0400 | ChrW(\&H0400) | 西里尔字母大写Е带重音符号 | | Ё | U+0401 | ChrW(\&H0401) | 西里尔字母大写Ё | | Ђ | U+0402 | ChrW(\&H0402) | 西里尔字母大写ДЖЕ | | Ѓ | U+0403 | ChrW(\&H0403) | 西里尔字母大写ГЈЕ | | Є | U+0404 | ChrW(\&H0404) | 西里尔字母大写乌克兰IE | | Ѕ | U+0405 | ChrW(\&H0405) | 西里尔字母大写DZE | | І | U+0406 | ChrW(\&H0406) | 西里尔字母大写乌克兰I | | Ї | U+0407 | ChrW(\&H0407) | 西里尔字母大写YI | | Ј | U+0408 | ChrW(\&H0408) | 西里尔字母大写JE | | Љ | U+0409 | ChrW(\&H0409) | 西里尔字母大写LJE | --- --- url: /zh/emoji/0500-052F.md --- # 西里尔字母补充 (Cyrillic Supplement) 本页面展示了Unicode字符集中，位于U+0500到U+052F范围的西里尔字母补充字符。这个范围包含了一些用于非斯拉夫语言的西里尔字母变体。 | 字符 | Unicode | VB函数值 | 名称 | |:---:|:---:|:---:|:---| | Ԁ | U+0500 | ChrW(\&H0500) | 西里尔字母大写KOMI DE | | ԁ | U+0501 | ChrW(\&H0501) | 西里尔字母小写KOMI DE | | Ԃ | U+0502 | ChrW(\&H0502) | 西里尔字母大写KOMI DJE | | ԃ | U+0503 | ChrW(\&H0503) | 西里尔字母小写KOMI DJE | | Ԅ | U+0504 | ChrW(\&H0504) | 西里尔字母大写KOMI ZJE | | ԅ | U+0505 | ChrW(\&H0505) | 西里尔字母小写KOMI ZJE | | Ԇ | U+0506 | ChrW(\&H0506) | 西里尔字母大写KOMI DZJE | | ԇ | U+0507 | ChrW(\&H0507) | 西里尔字母小写KOMI DZJE | | Ԉ | U+0508 | ChrW(\&H0508) | 西里尔字母大写KOMI LJE | | ԉ | U+0509 | ChrW(\&H0509) | 西里尔字母小写KOMI LJE | --- --- url: /zh/emoji/0590-05FF.md --- # 希伯来文 (Hebrew) 本页面展示了Unicode字符集中，位于U+0590到U+05FF范围的希伯来文字符。希伯来文是闪米特语系中的一种语言，从右向左书写，主要用于现代希伯来语（即以色列国语）。 | 字符 | Unicode | VB函数值 | 名称 | |:---:|:---:|:---:|:---| | ֐ | U+0590 | ChrW(\&H0590) | 希伯来文重音符号ATNAH HAFUKH | | ֑ | U+0591 | ChrW(\&H0591) | 希伯来文重音符号ETNAHTA | | ֒ | U+0592 | ChrW(\&H0592) | 希伯来文重音符号SEGOL | | ֓ | U+0593 | ChrW(\&H0593) | 希伯来文重音符号SHALSHELET | | ֔ | U+0594 | ChrW(\&H0594) | 希伯来文重音符号ZAQEF QATAN | | ֕ | U+0595 | ChrW(\&H0595) | 希伯来文重音符号ZAQEF GADOL | | ֖ | U+0596 | ChrW(\&H0596) | 希伯来文重音符号TIPEHA | | ֗ | U+0597 | ChrW(\&H0597) | 希伯来文重音符号REVIA | | ֘ | U+0598 | ChrW(\&H0598) | 希伯来文重音符号ZARQA | | ֙ | U+0599 | ChrW(\&H0599) | 希伯来文重音符号PASHTA | --- --- url: /zh/emoji/0370-03FF.md --- # 希腊文及科普特文 本文档包含了Unicode基本多文种平面中的希腊文及科普特文字符，范围为U+0370至U+03FF。这个范围包括了现代和古典希腊语使用的字母，以及源自希腊字母的科普特文字母。 | 字符 | Unicode | VB函数值 | 名称 | |:---:|:---:|:---:|:---| | Ͱ | U+0370 | ChrW(\&H0370) | 大写字母HETA | | ͱ | U+0371 | ChrW(\&H0371) | 小写字母heta | | Ͳ | U+0372 | ChrW(\&H0372) | 大写字母ARCHAIC SAMPI | | ͳ | U+0373 | ChrW(\&H0373) | 小写字母archaic sampi | | ʹ | U+0374 | ChrW(\&H0374) | 希腊数字符号 | | ͵ | U+0375 | ChrW(\&H0375) | 希腊小数点 | | Ͷ | U+0376 | ChrW(\&H0376) | 大写字母PAMPHYLIAN DIGAMMA | | ͷ | U+0377 | ChrW(\&H0377) | 小写字母pamphylian digamma | | ͺ | U+037A | ChrW(\&H037A) | 希腊语YPOGEGRAMMENI | | ͻ | U+037B | ChrW(\&H037B) | 希腊小写倒置LUNATE SIGMA符号 | | ͼ | U+037C | ChrW(\&H037C) | 希腊小写点状LUNATE SIGMA符号 | | ͽ | U+037D | ChrW(\&H037D) | 希腊小写点状反向LUNATE SIGMA符号 | | ; | U+037E | ChrW(\&H037E) | 希腊问号 | | Ϳ | U+037F | ChrW(\&H037F) | 大写字母YOT | | ΀ | U+0380 | ChrW(\&H0380) | 希腊TONOS符号 | | ΁ | U+0381 | ChrW(\&H0381) | 希腊DIALYTIKA TONOS符号 | | ΂ | U+0382 | ChrW(\&H0382) | 希腊TONOS符号变体 | | ΃ | U+0383 | ChrW(\&H0383) | 希腊DIALYTIKA TONOS符号变体 | | ΄ | U+0384 | ChrW(\&H0384) | 希腊TONOS | | ΅ | U+0385 | ChrW(\&H0385) | 希腊DIALYTIKA TONOS | | Ά | U+0386 | ChrW(\&H0386) | 带TONOS的大写字母ALPHA | | · | U+0387 | ChrW(\&H0387) | 希腊ANO TELEIA | | Έ | U+0388 | ChrW(\&H0388) | 带TONOS的大写字母EPSILON | | Ή | U+0389 | ChrW(\&H0389) | 带TONOS的大写字母ETA | | Ί | U+038A | ChrW(\&H038A) | 带TONOS的大写字母IOTA | | Ό | U+038C | ChrW(\&H038C) | 带TONOS的大写字母OMICRON | | Ύ | U+038E | ChrW(\&H038E) | 带TONOS的大写字母UPSILON | | Ώ | U+038F | ChrW(\&H038F) | 带TONOS的大写字母OMEGA | | ΐ | U+0390 | ChrW(\&H0390) | 带DIALYTIKA和TONOS的小写字母IOTA | | Α | U+0391 | ChrW(\&H0391) | 大写字母ALPHA | | Β | U+0392 | ChrW(\&H0392) | 大写字母BETA | | Γ | U+0393 | ChrW(\&H0393) | 大写字母GAMMA | | Δ | U+0394 | ChrW(\&H0394) | 大写字母DELTA | | Ε | U+0395 | ChrW(\&H0395) | 大写字母EPSILON | | Ζ | U+0396 | ChrW(\&H0396) | 大写字母ZETA | | Η | U+0397 | ChrW(\&H0397) | 大写字母ETA | | Θ | U+0398 | ChrW(\&H0398) | 大写字母THETA | | Ι | U+0399 | ChrW(\&H0399) | 大写字母IOTA | | Κ | U+039A | ChrW(\&H039A) | 大写字母KAPPA | | Λ | U+039B | ChrW(\&H039B) | 大写字母LAMDA | | Μ | U+039C | ChrW(\&H039C) | 大写字母MU | | Ν | U+039D | ChrW(\&H039D) | 大写字母NU | | Ξ | U+039E | ChrW(\&H039E) | 大写字母XI | | Ο | U+039F | ChrW(\&H039F) | 大写字母OMICRON | | Π | U+03A0 | ChrW(\&H03A0) | 大写字母PI | | Ρ | U+03A1 | ChrW(\&H03A1) | 大写字母RHO | | Σ | U+03A3 | ChrW(\&H03A3) | 大写字母SIGMA | | Τ | U+03A4 | ChrW(\&H03A4) | 大写字母TAU | | Υ | U+03A5 | ChrW(\&H03A5) | 大写字母UPSILON | | Φ | U+03A6 | ChrW(\&H03A6) | 大写字母PHI | | Χ | U+03A7 | ChrW(\&H03A7) | 大写字母CHI | | Ψ | U+03A8 | ChrW(\&H03A8) | 大写字母PSI | | Ω | U+03A9 | ChrW(\&H03A9) | 大写字母OMEGA | | Ϊ | U+03AA | ChrW(\&H03AA) | 带DIALYTIKA的大写字母IOTA | | Ϋ | U+03AB | ChrW(\&H03AB) | 带DIALYTIKA的大写字母UPSILON | | ά | U+03AC | ChrW(\&H03AC) | 带TONOS的小写字母ALPHA | | έ | U+03AD | ChrW(\&H03AD) | 带TONOS的小写字母EPSILON | | ή | U+03AE | ChrW(\&H03AE) | 带TONOS的小写字母ETA | | ί | U+03AF | ChrW(\&H03AF) | 带TONOS的小写字母IOTA | | ΰ | U+03B0 | ChrW(\&H03B0) | 带DIALYTIKA和TONOS的小写字母UPSILON | | α | U+03B1 | ChrW(\&H03B1) | 小写字母ALPHA | | β | U+03B2 | ChrW(\&H03B2) | 小写字母BETA | | γ | U+03B3 | ChrW(\&H03B3) | 小写字母GAMMA | | δ | U+03B4 | ChrW(\&H03B4) | 小写字母DELTA | | ε | U+03B5 | ChrW(\&H03B5) | 小写字母EPSILON | | ζ | U+03B6 | ChrW(\&H03B6) | 小写字母ZETA | | η | U+03B7 | ChrW(\&H03B7) | 小写字母ETA | | θ | U+03B8 | ChrW(\&H03B8) | 小写字母THETA | | ι | U+03B9 | ChrW(\&H03B9) | 小写字母IOTA | | κ | U+03BA | ChrW(\&H03BA) | 小写字母KAPPA | | λ | U+03BB | ChrW(\&H03BB) | 小写字母LAMDA | | μ | U+03BC | ChrW(\&H03BC) | 小写字母MU | | ν | U+03BD | ChrW(\&H03BD) | 小写字母NU | | ξ | U+03BE | ChrW(\&H03BE) | 小写字母XI | | ο | U+03BF | ChrW(\&H03BF) | 小写字母OMICRON | | π | U+03C0 | ChrW(\&H03C0) | 小写字母PI | | ρ | U+03C1 | ChrW(\&H03C1) | 小写字母RHO | | ς | U+03C2 | ChrW(\&H03C2) | 小写字母FINAL SIGMA | | σ | U+03C3 | ChrW(\&H03C3) | 小写字母SIGMA | | τ | U+03C4 | ChrW(\&H03C4) | 小写字母TAU | | υ | U+03C5 | ChrW(\&H03C5) | 小写字母UPSILON | | φ | U+03C6 | ChrW(\&H03C6) | 小写字母PHI | | χ | U+03C7 | ChrW(\&H03C7) | 小写字母CHI | | ψ | U+03C8 | ChrW(\&H03C8) | 小写字母PSI | | ω | U+03C9 | ChrW(\&H03C9) | 小写字母OMEGA | | ϊ | U+03CA | ChrW(\&H03CA) | 带DIALYTIKA的小写字母IOTA | | ϋ | U+03CB | ChrW(\&H03CB) | 带DIALYTIKA的小写字母UPSILON | | ό | U+03CC | ChrW(\&H03CC) | 带TONOS的小写字母OMICRON | | ύ | U+03CD | ChrW(\&H03CD) | 带TONOS的小写字母UPSILON | | ώ | U+03CE | ChrW(\&H03CE) | 带TONOS的小写字母OMEGA | | Ϗ | U+03CF | ChrW(\&H03CF) | 大写字母KAI | | ϐ | U+03D0 | ChrW(\&H03D0) | 希腊符号BETA | | ϑ | U+03D1 | ChrW(\&H03D1) | 希腊符号THETA | | ϒ | U+03D2 | ChrW(\&H03D2) | 大写字母UPSILON WITH HOOK | | ϓ | U+03D3 | ChrW(\&H03D3) | 带TONOS的大写字母UPSILON WITH HOOK | | ϔ | U+03D4 | ChrW(\&H03D4) | 带DIALYTIKA的大写字母UPSILON WITH HOOK | | ϕ | U+03D5 | ChrW(\&H03D5) | 希腊符号PHI | | ϖ | U+03D6 | ChrW(\&H03D6) | 希腊符号PI | | ϗ | U+03D7 | ChrW(\&H03D7) | 希腊符号KAI | | Ϙ | U+03D8 | ChrW(\&H03D8) | 大写字母KOPPA | | ϙ | U+03D9 | ChrW(\&H03D9) | 小写字母KOPPA | | Ϛ | U+03DA | ChrW(\&H03DA) | 大写字母STIGMA | | ϛ | U+03DB | ChrW(\&H03DB) | 小写字母STIGMA | | Ϝ | U+03DC | ChrW(\&H03DC) | 大写字母DIGAMMA | | ϝ | U+03DD | ChrW(\&H03DD) | 小写字母DIGAMMA | | Ϟ | U+03DE | ChrW(\&H03DE) | 大写字母KOPPA | | ϟ | U+03DF | ChrW(\&H03DF) | 小写字母KOPPA | | Ϡ | U+03E0 | ChrW(\&H03E0) | 大写字母SAMPI | | ϡ | U+03E1 | ChrW(\&H03E1) | 小写字母SAMPI | | Ϣ | U+03E2 | ChrW(\&H03E2) | 科普特大写字母SHEI | | ϣ | U+03E3 | ChrW(\&H03E3) | 科普特小写字母SHEI | | Ϥ | U+03E4 | ChrW(\&H03E4) | 科普特大写字母FEI | | ϥ | U+03E5 | ChrW(\&H03E5) | 科普特小写字母FEI | | Ϧ | U+03E6 | ChrW(\&H03E6) | 科普特大写字母KHEI | | ϧ | U+03E7 | ChrW(\&H03E7) | 科普特小写字母KHEI | | Ϩ | U+03E8 | ChrW(\&H03E8) | 科普特大写字母HORI | | ϩ | U+03E9 | ChrW(\&H03E9) | 科普特小写字母HORI | | Ϫ | U+03EA | ChrW(\&H03EA) | 科普特大写字母GANGIA | | ϫ | U+03EB | ChrW(\&H03EB) | 科普特小写字母GANGIA | | Ϭ | U+03EC | ChrW(\&H03EC) | 科普特大写字母SHIMA | | ϭ | U+03ED | ChrW(\&H03ED) | 科普特小写字母SHIMA | | Ϯ | U+03EE | ChrW(\&H03EE) | 科普特大写字母DEI | | ϯ | U+03EF | ChrW(\&H03EF) | 科普特小写字母DEI | | ϰ | U+03F0 | ChrW(\&H03F0) | 希腊符号KAPPA | | ϱ | U+03F1 | ChrW(\&H03F1) | 希腊符号RHO | | ϲ | U+03F2 | ChrW(\&H03F2) | 希腊符号LUNATE SIGMA | | ϳ | U+03F3 | ChrW(\&H03F3) | 希腊字母YOT | | ϴ | U+03F4 | ChrW(\&H03F4) | 大写希腊字母带十字THETA | | ϵ | U+03F5 | ChrW(\&H03F5) | 希腊符号LUNATE EPSILON | | ϶ | U+03F6 | ChrW(\&H03F6) | 希腊符号REVERSED LUNATE EPSILON | | Ϸ | U+03F7 | ChrW(\&H03F7) | 大写字母SHO | | ϸ | U+03F8 | ChrW(\&H03F8) | 小写字母SHO | | Ϲ | U+03F9 | ChrW(\&H03F9) | 大写字母LUNATE SIGMA | | Ϻ | U+03FA | ChrW(\&H03FA) | 大写字母SAN | | ϻ | U+03FB | ChrW(\&H03FB) | 小写字母SAN | | ϼ | U+03FC | ChrW(\&H03FC) | 希腊符号RHO WITH STROKE | | Ͻ | U+03FD | ChrW(\&H03FD) | 大写字母REVERSED LUNATE SIGMA | | Ͼ | U+03FE | ChrW(\&H03FE) | 大写字母DOTTED LUNATE SIGMA | | Ͽ | U+03FF | ChrW(\&H03FF) | 大写字母REVERSED DOTTED LUNATE SIGMA | --- --- url: /zh/emoji/0A00-0A7F.md --- # 锡克教文 (Gurmukhi) 本页面展示了Unicode字符集中，位于U+0A00到U+0A7F范围的锡克教文字符。古尔穆奇文（Gurmukhi）是旁遮普语的主要书写系统，在印度的旁遮普邦被广泛使用。 | 字符 | Unicode | VB函数值 | 名称 | |:---:|:---:|:---:|:---| | ੀ | U+0A00 | ChrW(\&H0A00) | 古尔穆奇文标记ADAK BINDI | | ਁ | U+0A01 | ChrW(\&H0A01) | 古尔穆奇文标记BINDI | | ਂ | U+0A02 | ChrW(\&H0A02) | 古尔穆奇文标记ADAK BINDI | | ਃ | U+0A03 | ChrW(\&H0A03) | 古尔穆奇文标记VISARGA | | ਅ | U+0A05 | ChrW(\&H0A05) | 古尔穆奇文字母A | | ਆ | U+0A06 | ChrW(\&H0A06) | 古尔穆奇文字母AA | | ਇ | U+0A07 | ChrW(\&H0A07) | 古尔穆奇文字母I | | ਈ | U+0A08 | ChrW(\&H0A08) | 古尔穆奇文字母II | | ਉ | U+0A09 | ChrW(\&H0A09) | 古尔穆奇文字母U | | ਊ | U+0A0A | ChrW(\&H0A0A) | 古尔穆奇文字母UU | --- --- url: /zh/biz/cs-auther/architecture.md --- # 系统架构 ## 整体架构图 ``` ┌─────────────────────────────────────────────────────────────────┐ │ 客户端 (Client) │ │ ┌──────────┐ ┌──────────┐ ┌──────────┐ ┌──────────────┐ │ │ │ fLogin │ │ Form1 │ │ fSetting │ │ bCalc/bUser │ │ │ │ (登录窗) │ │ (主窗体) │ │ (配置窗) │ │ (业务类) │ │ │ └────┬─────┘ └────┬─────┘ └──────────┘ └──────┬───────┘ │ │ │ │ │ │ │ └──────────────┴───────────────┬───────────────┘ │ │ │ │ │ ┌────────────▼────────────┐ │ │ │ cWinsock (TcpClient) │ │ │ └────────────┬────────────┘ │ └──────────────────────────────────────┼──────────────────────────┘ │ TCP / JSON ┌──────────────────────────────────────┼──────────────────────────┐ │ ┌────────────▼────────────┐ │ │ │ cWinsock (TcpServer) │ │ │ └────────────┬────────────┘ │ │ │ │ │ ┌──────────────┬───────────────┼───────────────┐ │ │ │ │ │ │ │ │ ┌────┴─────┐ ┌────┴─────┐ ┌─────┴──────┐ ┌────┴─────┐ │ │ │ mAuth │ │ bUser │ │ bNotify │ │ bCalc │ │ │ │(中间件) │ │(登录业务)│ │(公告业务) │ │(参数计算)│ │ │ └──────────┘ └──────────┘ └────────────┘ └──────────┘ │ │ │ │ ┌──────────┐ ┌──────────┐ ┌───────────────────────────┐ │ │ │ Form1 │ │ fNotify │ │ cDataBase (Access .mdb) │ │ │ │(主监控窗)│ │(公告编辑)│ │ users 表 │ │ │ └──────────┘ └──────────┘ └───────────────────────────┘ │ │ 服务端 (Server) │ └─────────────────────────────────────────────────────────────────┘ ``` *** ## 运行流程 ### 1. 服务端启动流程 1. 启动 `Server.exe`，加载 `Form1` 2. 创建 `cWinsock` 实例，监听 **TCP 800 端口** 3. 连接同目录下的 `data.mdb`（Access 数据库） 4. 从数据库加载用户列表到左侧 `ListBox` 5. 注册中间件（`mAuth`）与业务路由（`bUser`, `bNotify`, `bCalc`, `cMessage`） 6. 等待客户端接入 ### 2. 客户端启动流程 1. 启动 `Client.exe`，首先加载 `fLogin`（登录窗体） 2. 读取 `config.ini` 中的服务器 IP 和端口 3. 若配置不存在，弹出 `fSetting` 强制用户配置 4. 注册业务路由（`bUser`, `bNotify`, `cMessage`） 5. 尝试连接服务端 6. 连接成功后启用登录按钮 ### 3. 用户登录流程 ``` ┌─────────┐ ┌─────────┐ │ Client │ │ Server │ └────┬────┘ └────┬────┘ │ │ │ ─────── TCP 连接建立 ─────────────>│ │ │ │ {action:"User/Login", data:{...}} │ │ ──────────────────────────────────>│ │ │ │ │──┐ 查询 Access 数据库 │ │ │ 验证用户名/密码 │ │<-┘ │ │ 生成 Token │ │ 绑定用户到连接实例 │ │ │ {action:"User/Info", token:"xxx"} │ │ <──────────────────────────────────│ │ │ │ 显示主窗体 Form1 │ │ 请求公告 Notify/CheckNew │ │ ──────────────────────────────────>│ │ │ ``` ### 4. 中间件校验流程 所有非白名单请求在执行业务逻辑前，都会经过中间件链： 1. 收到客户端数据 → `Common.HandleReciver` 2. 解析 JSON，提取 `action` 和 `token` 3. 判断是否在白名单（如 `User/Login`）→ 跳过中间件 4. 遍历所有中间件，执行 `Entry` 方法 5. 任一中间件返回 `False` → 中断流程，向客户端发送错误提示 6. 全部通过 → `CallByName` 调用对应的业务类方法 *** ## 模块关系 | 层级 | 客户端 | 服务端 | 说明 | |------|--------|--------|------| | **UI 层** | `fLogin`, `Form1`, `fSetting` | `Form1`, `fNotify` | 窗体界面与事件响应 | | **业务层** | `bUser`, `bNotify`, `bCalc` | `bUser`, `bNotify`, `bCalc` | 处理具体业务逻辑 | | **中间件层** | — | `mAuth` | 权限校验、前置拦截 | | **通信层** | `cWinsock` | `cWinsock` | TCP 连接、数据收发 | | **数据层** | `CurrentUser` (cJson) | `cDataBase` (Access) | 数据持久化与缓存 | | **公共层** | `Common.bas`, `cMessage.cls` | `Common.bas`, `cMessage.cls` | 路由、发送、消息处理 | *** ## 关键设计模式 ### 路由分发模式 采用字符串分割 + `CallByName` 实现轻量级路由： ```vb ' action = "User/Login" → 拆分为类名 "User" 和方法名 "Login" Dim Action As Variant: Action = Split(.Root("action"), "/") CallByName Router.Item(Action(0)), Action(1), VbMethod, Client, Data ``` * `Router` 是一个 `cCollection`，以类名为 Key 存储业务类实例 * 新增业务只需：新建类 → 实现 `Public Sub Xxx(Inst, Data)` → 注册到 Router ### 全局实例共享 通过标准模块中的 Public 变量实现跨模块共享： **客户端 (`Insts.bas`)**: ```vb Public TcpClient As cWinsock ' TCP 连接实例 Public CurrentUser As New cJson ' 当前登录用户信息 ``` **服务端 (`Insts.bas`)**: ```vb Public TcpServer As cWinsock ' TCP 监听实例 Public Db As cDataBase ' 数据库连接实例 ``` ### 事件驱动通信 客户端与服务端的窗体均通过 `WithEvents` 监听 `cWinsock` 事件： ```vb Dim WithEvents Tcp As cWinsock Private Sub Tcp_Connect(Client As cWinsock) ' 连接成功 End Sub Private Sub Tcp_DataArrival(Client As cWinsock, ByVal bytesTotal As Long) Common.HandleReciver Client, bytesTotal End Sub Private Sub Tcp_CloseEvent(Client As cWinsock) ' 连接断开 End Sub ``` --- --- url: /zh/packages/vbccr/system/sysinfo.md description: 系统信息控件（SysInfo） - VBCCR 开发手册，基于源码的完整 API 参考 --- # 系统信息控件（SysInfo） 提供系统事件监测，包括设备变更、电源状态、显示设置更改和主题变更等通知。运行时不可见。 ## 枚举 ### SysDeviceTypeConstants 设备类型常量。 | 常量 | 值 | 说明 | |------|-----|------| | SysDeviceTypeOEM | DBT\_DEVTYP\_OEM | OEM设备 | | SysDeviceTypeDevNode | DBT\_DEVTYP\_DEVNODE | 设备节点 | | SysDeviceTypeVolume | DBT\_DEVTYP\_VOLUME | 卷设备 | | SysDeviceTypePort | DBT\_DEVTYP\_PORT | 端口设备 | | SysDeviceTypeDevInterface | DBT\_DEVTYP\_DEVICEINTERFACE | 设备接口 | ### SysACStatusConstants 交流电源状态常量。 | 常量 | 值 | 说明 | |------|-----|------| | SysACStatusOffline | 0 | 离线（使用电池） | | SysACStatusOnline | 1 | 在线（使用交流电） | | SysACStatusUnknown | 255 | 未知 | ### SysBatteryStatusConstants 电池状态常量。 | 常量 | 值 | 说明 | |------|-----|------| | SysBatteryStatusHigh | 1 | 电量高 | | SysBatteryStatusLow | 2 | 电量低 | | SysBatteryStatusCritical | 4 | 电量严重不足 | | SysBatteryStatusCharging | 8 | 正在充电 | | SysBatteryStatusNone | 128 | 无电池 | | SysBatteryStatusUnknown | 255 | 未知 | ## 属性 ### Name ```vb Public Property Get Name() As String ``` 返回在代码中标识对象的名称。 ### Tag ```vb Public Property Get Tag() As String Public Property Let Tag(ByVal Value As String) ``` 存储程序所需的额外数据。 ### Parent ```vb Public Property Get Parent() As Object ``` 返回对象所在的对象。 ### hMain ```vb Public Property Get hMain() As LongPtr ``` 返回主窗口句柄。 ### ACStatus ```vb Public Property Get ACStatus() As SysACStatusConstants ``` 返回交流电源状态。 ### BatteryFullTime ```vb Public Property Get BatteryFullTime() As Long ``` 返回电池完全充满所需的时间（秒）。 ### BatteryLifePercent ```vb Public Property Get BatteryLifePercent() As Integer ``` 返回电池剩余电量百分比。 ### BatteryLifeTime ```vb Public Property Get BatteryLifeTime() As Long ``` 返回电池剩余使用时间（秒）。 ### BatteryStatus ```vb Public Property Get BatteryStatus() As SysBatteryStatusConstants ``` 返回电池状态。 ### WorkAreaLeft ```vb Public Property Get WorkAreaLeft() As Single ``` 返回工作区左边距。 ### WorkAreaTop ```vb Public Property Get WorkAreaTop() As Single ``` 返回工作区顶边距。 ### WorkAreaWidth ```vb Public Property Get WorkAreaWidth() As Single ``` 返回工作区宽度。 ### WorkAreaHeight ```vb Public Property Get WorkAreaHeight() As Single ``` 返回工作区高度。 ### ScrollBarSize ```vb Public Property Get ScrollBarSize() As Single ``` 返回滚动条尺寸。 ## 事件 ### SysColorsChanged ```vb Public Event SysColorsChanged() ``` 系统颜色改变时触发。 ### SettingChanged ```vb Public Event SettingChanged(ByVal Item As Long, ByVal Section As String) ``` 系统设置改变时触发。Item为设置项，Section为设置节。 ### DevModeChanged ```vb Public Event DevModeChanged() ``` 设备模式改变时触发。 ### TimeChanged ```vb Public Event TimeChanged() ``` 系统时间改变时触发。 ### FontChanged ```vb Public Event FontChanged() ``` 系统字体改变时触发。 ### DisplayChanged ```vb Public Event DisplayChanged(ByVal NewColorDepth As Long, ByVal NewWidth As Single, ByVal NewHeight As Single) ``` 显示设置改变时触发。NewColorDepth为新颜色深度，NewWidth/NewHeight为新分辨率。 ### DeviceArrival ```vb Public Event DeviceArrival(ByVal DeviceType As SysDeviceTypeConstants, ByVal DeviceID As Long, ByVal DeviceName As String, ByVal DeviceData As Long) ``` 设备插入时触发。 ### DeviceQueryRemove ```vb Public Event DeviceQueryRemove(ByVal DeviceType As SysDeviceTypeConstants, ByVal DeviceID As Long, ByVal DeviceName As String, ByVal DeviceData As Long, ByRef Cancel As Boolean) ``` 设备即将移除时触发。Cancel为True时阻止移除。 ### DeviceQueryRemoveFailed ```vb Public Event DeviceQueryRemoveFailed(ByVal DeviceType As SysDeviceTypeConstants, ByVal DeviceID As Long, ByVal DeviceName As String, ByVal DeviceData As Long) ``` 设备移除查询失败时触发。 ### DeviceRemoveComplete ```vb Public Event DeviceRemoveComplete(ByVal DeviceType As SysDeviceTypeConstants, ByVal DeviceID As Long, ByVal DeviceName As String, ByVal DeviceData As Long) ``` 设备移除完成时触发。 ### DeviceRemovePending ```vb Public Event DeviceRemovePending(ByVal DeviceType As SysDeviceTypeConstants, ByVal DeviceID As Long, ByVal DeviceName As String, ByVal DeviceData As Long) ``` 设备即将被移除时触发。 ### DevNodesChanged ```vb Public Event DevNodesChanged() ``` 设备节点改变时触发。 ### QueryChangeConfig ```vb Public Event QueryChangeConfig(ByRef Cancel As Boolean) ``` 配置即将改变时触发。Cancel为True时阻止改变。 ### ConfigChangeCancelled ```vb Public Event ConfigChangeCancelled() ``` 配置改变被取消时触发。 ### ConfigChanged ```vb Public Event ConfigChanged() ``` 配置改变完成时触发。 ### PowerQuerySuspend ```vb Public Event PowerQuerySuspend(ByRef Cancel As Boolean) ``` 系统即将挂起时触发。Cancel为True时阻止挂起。 ### PowerQuerySuspendFailed ```vb Public Event PowerQuerySuspendFailed() ``` 系统挂起请求失败时触发。 ### PowerResume ```vb Public Event PowerResume() ``` 系统从挂起恢复时触发。 ### PowerStatusChanged ```vb Public Event PowerStatusChanged() ``` 电源状态改变时触发。 ### PowerSuspend ```vb Public Event PowerSuspend() ``` 系统即将挂起时触发。 ### ThemeChanged ```vb Public Event ThemeChanged() ``` 系统主题改变时触发。 ## 代码示例 ### 基本用法 ```vb ' 监测电源状态 Private Sub SysInfo1_PowerStatusChanged() Select Case SysInfo1.ACStatus Case SysACStatusOnline Debug.Print "使用交流电源" Case SysACStatusOffline Debug.Print "使用电池, 剩余: " & SysInfo1.BatteryLifePercent & "%" End Select End Sub ' 监测设备变更 Private Sub SysInfo1_DeviceArrival(ByVal DeviceType As SysDeviceTypeConstants, _ ByVal DeviceID As Long, ByVal DeviceName As String, ByVal DeviceData As Long) Debug.Print "设备插入: " & DeviceName End Sub ' 监测显示设置变更 Private Sub SysInfo1_DisplayChanged(ByVal NewColorDepth As Long, _ ByVal NewWidth As Single, ByVal NewHeight As Single) Debug.Print "分辨率: " & NewWidth & "x" & NewHeight & " 色深: " & NewColorDepth End Sub ``` --- --- url: /zh/packages/vbccr/lists/vlistbox.md description: 虚拟列表框控件（VListBox） - VBCCR 开发手册，基于源码的完整 API 参考 --- # 虚拟列表框控件（VListBox） 提供虚拟数据列表框，使用LBS\_NODATA样式实现大数据量展示，按需提供数据，支持多选、自绘、插入标记和OLE拖放。 ## 枚举 ### VlbDrawModeConstants 绘制模式常量。 | 常量 | 值 | 说明 | |------|-----|------| | VlbDrawModeNormal | 0 | 标准绘制模式 | | VlbDrawModeOwnerDrawFixed | 1 | 固定高度自绘模式 | ## 属性 ### Name ```vb Public Property Get Name() As String ``` 返回在代码中标识对象的名称。 ### Tag ```vb Public Property Get Tag() As String Public Property Let Tag(ByVal Value As String) ``` 存储程序所需的额外数据。 ### Parent ```vb Public Property Get Parent() As Object ``` 返回对象所在的对象。 ### Container ```vb Public Property Get Container() As Object Public Property Set Container(ByVal Value As Object) ``` 返回/设置对象的容器。 ### Left ```vb Public Property Get Left() As Single Public Property Let Left(ByVal Value As Single) ``` 返回/设置对象与其容器左边缘的距离。 ### Top ```vb Public Property Get Top() As Single Public Property Let Top(ByVal Value As Single) ``` 返回/设置对象与其容器顶边缘的距离。 ### Width ```vb Public Property Get Width() As Single Public Property Let Width(ByVal Value As Single) ``` 返回/设置对象的宽度。 ### Height ```vb Public Property Get Height() As Single Public Property Let Height(ByVal Value As Single) ``` 返回/设置对象的高度。 ### Visible ```vb Public Property Get Visible() As Boolean Public Property Let Visible(ByVal Value As Boolean) ``` 返回/设置对象是否可见。 ### ToolTipText ```vb Public Property Get ToolTipText() As String Public Property Let ToolTipText(ByVal Value As String) ``` 返回/设置鼠标悬停时显示的提示文本。 ### HelpContextID ```vb Public Property Get HelpContextID() As Long Public Property Let HelpContextID(ByVal Value As Long) ``` 返回/设置帮助上下文ID。 ### WhatsThisHelpID ```vb Public Property Get WhatsThisHelpID() As Long Public Property Let WhatsThisHelpID(ByVal Value As Long) ``` 返回/设置关联的上下文帮助ID。 ### DragIcon ```vb Public Property Get DragIcon() As IPictureDisp Public Property Let DragIcon(ByVal Value As IPictureDisp) Public Property Set DragIcon(ByVal Value As IPictureDisp) ``` 返回/设置拖放操作中显示的图标。 ### DragMode ```vb Public Property Get DragMode() As Integer Public Property Let DragMode(ByVal Value As Integer) ``` 返回/设置拖动模式。 ### hWnd ```vb Public Property Get hWnd() As LongPtr ``` 返回控件句柄。 ### hWndUserControl ```vb Public Property Get hWndUserControl() As LongPtr ``` 返回UserControl句柄。 ### Font ```vb Public Property Get Font() As StdFont Public Property Let Font(ByVal NewFont As StdFont) Public Property Set Font(ByVal NewFont As StdFont) ``` 返回/设置字体。 ### VisualStyles ```vb Public Property Get VisualStyles() As Boolean Public Property Let VisualStyles(ByVal Value As Boolean) ``` 返回/设置是否启用视觉样式。需要comctl32.dll 6.0或更高版本。 ### BackColor ```vb Public Property Get BackColor() As OLE_COLOR Public Property Let BackColor(ByVal Value As OLE_COLOR) ``` 返回/设置背景色。 ### ForeColor ```vb Public Property Get ForeColor() As OLE_COLOR Public Property Let ForeColor(ByVal Value As OLE_COLOR) ``` 返回/设置前景色。 ### Enabled ```vb Public Property Get Enabled() As Boolean Public Property Let Enabled(ByVal Value As Boolean) ``` 返回/设置对象是否能响应用户事件。 ### OLEDragMode ```vb Public Property Get OLEDragMode() As VBRUN.OLEDragConstants Public Property Let OLEDragMode(ByVal Value As VBRUN.OLEDragConstants) ``` 返回/设置OLE拖拽模式。 ### OLEDragDropScroll ```vb Public Property Get OLEDragDropScroll() As Boolean Public Property Let OLEDragDropScroll(ByVal Value As Boolean) ``` 返回/设置OLE拖放时是否自动滚动。 ### OLEDropMode ```vb Public Property Get OLEDropMode() As OLEDropModeConstants Public Property Let OLEDropMode(ByVal Value As OLEDropModeConstants) ``` 返回/设置对象是否可以作为OLE放置目标。 ### MousePointer ```vb Public Property Get MousePointer() As CCMousePointerConstants Public Property Let MousePointer(ByVal Value As CCMousePointerConstants) ``` 返回/设置鼠标悬停时显示的指针类型。参见通用枚举。 ### MouseIcon ```vb Public Property Get MouseIcon() As IPictureDisp Public Property Let MouseIcon(ByVal Value As IPictureDisp) Public Property Set MouseIcon(ByVal Value As IPictureDisp) ``` 返回/设置自定义鼠标图标。 ### MouseTrack ```vb Public Property Get MouseTrack() As Boolean Public Property Let MouseTrack(ByVal Value As Boolean) ``` 返回/设置是否在鼠标进入或离开控件时触发事件。 ### RightToLeft ```vb Public Property Get RightToLeft() As Boolean Public Property Let RightToLeft(ByVal Value As Boolean) ``` 返回/设置从右到左显示方向。 ### RightToLeftMode ```vb Public Property Get RightToLeftMode() As CCRightToLeftModeConstants Public Property Let RightToLeftMode(ByVal Value As CCRightToLeftModeConstants) ``` 返回/设置从右到左模式。参见通用枚举。 ### Redraw ```vb Public Property Get Redraw() As Boolean Public Property Let Redraw(ByVal Value As Boolean) ``` 返回/设置是否重绘。禁用后可加速大量操作。 ### BorderStyle ```vb Public Property Get BorderStyle() As CCBorderStyleConstants Public Property Let BorderStyle(ByVal Value As CCBorderStyleConstants) ``` 返回/设置边框样式。参见通用枚举。 ### MultiColumn ```vb Public Property Get MultiColumn() As Boolean Public Property Let MultiColumn(ByVal Value As Boolean) ``` 返回/设置是否多列显示。 ### IntegralHeight ```vb Public Property Get IntegralHeight() As Boolean Public Property Let IntegralHeight(ByVal Value As Boolean) ``` 返回/设置是否调整高度为完整项。仅设计时可设置。 ### AllowSelection ```vb Public Property Get AllowSelection() As Boolean Public Property Let AllowSelection(ByVal Value As Boolean) ``` 返回/设置是否允许选择项。 ### MultiSelect ```vb Public Property Get MultiSelect() As VBRUN.MultiSelectConstants Public Property Let MultiSelect(ByVal Value As VBRUN.MultiSelectConstants) ``` 返回/设置多选模式。使用VBRUN.MultiSelectConstants常量（vbMultiSelectNone=0, vbMultiSelectSimple=1, vbMultiSelectExtended=2）。 ### HorizontalExtent ```vb Public Property Get HorizontalExtent() As Single Public Property Let HorizontalExtent(ByVal Value As Single) ``` 返回/设置水平滚动范围。仅在MultiColumn为False时有效。 ### UseTabStops ```vb Public Property Get UseTabStops() As Boolean Public Property Let UseTabStops(ByVal Value As Boolean) ``` 返回/设置是否识别和展开制表符。 ### DisableNoScroll ```vb Public Property Get DisableNoScroll() As Boolean Public Property Let DisableNoScroll(ByVal Value As Boolean) ``` 返回/设置不需要滚动条时是否禁用而非隐藏。 ### DrawMode ```vb Public Property Get DrawMode() As VlbDrawModeConstants Public Property Let DrawMode(ByVal Value As VlbDrawModeConstants) ``` 返回/设置绘制模式。仅设计时可设置。 ### InsertMarkColor ```vb Public Property Get InsertMarkColor() As OLE_COLOR Public Property Let InsertMarkColor(ByVal Value As OLE_COLOR) ``` 返回/设置插入标记颜色。 ### ScrollTrack ```vb Public Property Get ScrollTrack() As Boolean Public Property Let ScrollTrack(ByVal Value As Boolean) ``` 返回/设置是否启用滚动跟踪（拖动滑块时实时滚动）。 ### ListCount ```vb Public Property Get ListCount() As Long Public Property Let ListCount(ByVal Value As Long) ``` 返回/设置列表项数量。虚拟列表中为数据项总数。 ### List ```vb Public Property Get List(ByVal Index As Long) As String ``` 获取指定索引的列表项文本。通过GetVirtualItem事件获取数据。 ### ListIndex ```vb Public Property Get ListIndex() As Long Public Property Let ListIndex(ByVal Value As Long) ``` 返回/设置当前选中项索引。 ### Text ```vb Public Property Get Text() As String Public Property Let Text(ByVal Value As String) ``` 返回/设置当前选中项文本。设置时触发FindVirtualItem查找匹配项。 ### SelCount ```vb Public Property Get SelCount() As Long ``` 返回选中项数量。 ### Selected ```vb Public Property Get Selected(ByVal Index As Long) As Boolean Public Property Let Selected(ByVal Index As Long, ByVal Value As Boolean) ``` 返回/设置指定索引项的选中状态。 ### ItemHeight ```vb Public Property Get ItemHeight() As Single Public Property Let ItemHeight(ByVal Value As Single) ``` 返回/设置项高度。 ### TopIndex ```vb Public Property Get TopIndex() As Long Public Property Let TopIndex(ByVal Value As Long) ``` 返回/设置列表顶部可见项索引。 ### AnchorIndex ```vb Public Property Get AnchorIndex() As Long Public Property Let AnchorIndex(ByVal Value As Long) ``` 返回/设置锚点项索引（多项选择的起始项）。 ### InsertMark ```vb Public Property Get InsertMark(Optional ByRef After As Boolean) As Long Public Property Let InsertMark(Optional ByRef After As Boolean, ByVal Value As Long) ``` 返回/设置插入标记位置。After参数指示插入标记在项目的上方(False)还是下方(True)。设为-1取消插入标记。 ### OLEDraggedItem ```vb Public Property Get OLEDraggedItem() As Long ``` 返回当前OLE拖拽项的索引。 ## 方法 ### OLEDrag ```vb Public Sub OLEDrag() ``` 启动OLE拖放操作。 ### Drag ```vb Public Sub Drag(Optional ByRef Action As Variant) ``` 开始、结束或取消拖动操作。 ### SetFocus ```vb Public Sub SetFocus() ``` 将焦点移到指定对象。 ### ZOrder ```vb Public Sub ZOrder(Optional ByRef Position As Variant) ``` 设置Z顺序。 ### Refresh ```vb Public Sub Refresh() ``` 强制完全重绘对象。 ### SetSelRange ```vb Public Sub SetSelRange(ByVal StartIndex As Long, ByVal EndIndex As Long) ``` 设置选择范围（多选模式下）。 ### SetColumnWidth ```vb Public Sub SetColumnWidth(ByVal Value As Single) ``` 设置多列列表的列宽。 ### ItemsPerColumn ```vb Public Function ItemsPerColumn() As Long ``` 获取每列项数。 ### SelectedIndices ```vb Public Function SelectedIndices() As Collection ``` 返回所有选中项索引的集合。 ### HitTest ```vb Public Function HitTest(ByVal X As Single, ByVal Y As Single) As Long ``` 命中测试，返回指定坐标处的项索引。不在任何项上返回-1。 ### HitTestInsertMark ```vb Public Function HitTestInsertMark(ByVal X As Single, ByVal Y As Single, Optional ByRef After As Boolean) As Long ``` 插入标记命中测试，同时获取插入标记应出现在项目上方还是下方。 ### FindItem ```vb Public Function FindItem(ByVal Text As String, Optional ByVal Index As Long = -1, Optional ByVal Partial As Boolean) As Long ``` 查找列表项。返回匹配项索引，未找到返回-1。 ### GetIdealHorizontalExtent ```vb Public Function GetIdealHorizontalExtent() As Single ``` 获取理想的水平滚动范围。 ### SelectItem ```vb Public Function SelectItem(ByVal Text As String, Optional ByVal Index As Long = -1) As Long ``` 搜索并选择匹配的列表项。返回选中项索引。 ## 事件 ### Click ```vb Public Event Click() ``` 用户单击控件时触发。 ### DblClick ```vb Public Event DblClick() ``` 用户双击控件时触发。 ### Scroll ```vb Public Event Scroll() ``` 列表滚动时触发。 ### ContextMenu ```vb Public Event ContextMenu(ByVal X As Single, ByVal Y As Single) ``` 右键上下文菜单事件。X和Y为-1时表示键盘触发（Shift+F10）。 ### GetVirtualItem ```vb Public Event GetVirtualItem(ByVal Item As Long, ByRef Text As String) ``` 请求虚拟项数据时触发。需设置Text参数返回项文本。 ### FindVirtualItem ```vb Public Event FindVirtualItem(ByVal StartIndex As Long, ByVal SearchText As String, ByVal Partial As Boolean, ByRef FoundIndex As Long) ``` 搜索虚拟项时触发。需设置FoundIndex返回匹配项索引，未找到设为-1。 ### IncrementalSearch ```vb Public Event IncrementalSearch(ByVal SearchString As String, ByVal StartIndex As Long, ByRef FoundIndex As Long) ``` 增量搜索时触发。需设置FoundIndex返回匹配项索引。 ### ItemDraw ```vb Public Event ItemDraw(ByVal Item As Long, ByVal ItemAction As Long, ByVal ItemState As Long, ByVal hDC As Long, ByVal Left As Long, ByVal Top As Long, ByVal Right As Long, ByVal Bottom As Long) ``` 自绘项时触发（DrawMode为OwnerDrawFixed时）。 ### PreviewKeyDown ```vb Public Event PreviewKeyDown(ByVal KeyCode As Integer, ByRef IsInputKey As Boolean) ``` 按键预览事件。设置IsInputKey为True可将按键标记为输入键。 ### PreviewKeyUp ```vb Public Event PreviewKeyUp(ByVal KeyCode As Integer, ByRef IsInputKey As Boolean) ``` 按键释放预览事件。 ### KeyDown ```vb Public Event KeyDown(KeyCode As Integer, Shift As Integer) ``` 按下键盘键时触发。 ### KeyUp ```vb Public Event KeyUp(KeyCode As Integer, Shift As Integer) ``` 释放键盘键时触发。 ### KeyPress ```vb Public Event KeyPress(KeyChar As Integer) ``` 按下并释放ANSI键时触发。 ### MouseDown ```vb Public Event MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` 按下鼠标按钮时触发。 ### MouseMove ```vb Public Event MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` 移动鼠标时触发。 ### MouseUp ```vb Public Event MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` 释放鼠标按钮时触发。 ### MouseEnter ```vb Public Event MouseEnter() ``` 鼠标进入控件区域时触发。 ### MouseLeave ```vb Public Event MouseLeave() ``` 鼠标离开控件区域时触发。 ### OLECompleteDrag ```vb Public Event OLECompleteDrag(Effect As Long) ``` OLE拖放操作完成时触发。 ### OLEDragDrop ```vb Public Event OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single) ``` OLE拖放操作放置时触发。 ### OLEDragOver ```vb Public Event OLEDragOver(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single, State As Integer) ``` OLE拖放操作悬停时触发。 ### OLEGiveFeedback ```vb Public Event OLEGiveFeedback(Effect As Long, DefaultCursors As Boolean) ``` OLE拖放操作给反馈时触发。 ### OLESetData ```vb Public Event OLESetData(Data As DataObject, DataFormat As Integer) ``` OLE拖放操作设置数据时触发。 ### OLEStartDrag ```vb Public Event OLEStartDrag(Data As DataObject, AllowedEffects As Long) ``` OLE拖放操作开始时触发。 ## 代码示例 ### 基本用法 ```vb ' 设置虚拟列表框 With VListBox1 .ListCount = 10000 .MultiSelect = vbMultiSelectExtended .InsertMarkColor = vbBlue .ScrollTrack = True End With ' 提供虚拟项数据 Private Sub VListBox1_GetVirtualItem(ByVal Item As Long, ByRef Text As String) Text = "第 " & CStr(Item + 1) & " 项" End Sub ' 查找虚拟项 Private Sub VListBox1_FindVirtualItem(ByVal StartIndex As Long, _ ByVal SearchText As String, ByVal Partial As Boolean, ByRef FoundIndex As Long) FoundIndex = -1 End Sub ' 自绘项示例 Private Sub VListBox1_ItemDraw(ByVal Item As Long, ByVal ItemAction As Long, _ ByVal ItemState As Long, ByVal hDC As Long, ByVal Left As Long, _ ByVal Top As Long, ByVal Right As Long, ByVal Bottom As Long) ' 自定义绘制代码 End Sub ``` --- --- url: /zh/packages/vbccr/lists/virtualcombo.md description: 虚拟组合框控件（VirtualCombo） - VBCCR 开发手册，基于源码的完整 API 参考 --- # 虚拟组合框控件（VirtualCombo） 提供虚拟数据组合框，使用LBS\_NODATA样式实现大数据量展示，按需提供数据，支持自绘、增量搜索和OLE拖放。 ## 枚举 ### VcbStyleConstants 组合框样式常量。 | 常量 | 值 | 说明 | |------|-----|------| | VcbStyleDropDownCombo | 0 | 下拉组合框（可编辑） | | VcbStyleSimpleCombo | 1 | 简单组合框 | | VcbStyleDropDownList | 2 | 下拉列表框（不可编辑） | ### VcbDrawModeConstants 绘制模式常量。 | 常量 | 值 | 说明 | |------|-----|------| | VcbDrawModeNormal | 0 | 标准绘制模式 | | VcbDrawModeOwnerDrawFixed | 1 | 固定高度自绘模式 | ## 属性 ### Name ```vb Public Property Get Name() As String ``` 返回在代码中标识对象的名称。 ### Tag ```vb Public Property Get Tag() As String Public Property Let Tag(ByVal Value As String) ``` 存储程序所需的额外数据。 ### Parent ```vb Public Property Get Parent() As Object ``` 返回对象所在的对象。 ### Container ```vb Public Property Get Container() As Object Public Property Set Container(ByVal Value As Object) ``` 返回/设置对象的容器。 ### Left ```vb Public Property Get Left() As Single Public Property Let Left(ByVal Value As Single) ``` 返回/设置对象与其容器左边缘的距离。 ### Top ```vb Public Property Get Top() As Single Public Property Let Top(ByVal Value As Single) ``` 返回/设置对象与其容器顶边缘的距离。 ### Width ```vb Public Property Get Width() As Single Public Property Let Width(ByVal Value As Single) ``` 返回/设置对象的宽度。 ### Height ```vb Public Property Get Height() As Single Public Property Let Height(ByVal Value As Single) ``` 返回/设置对象的高度。 ### Visible ```vb Public Property Get Visible() As Boolean Public Property Let Visible(ByVal Value As Boolean) ``` 返回/设置对象是否可见。 ### ToolTipText ```vb Public Property Get ToolTipText() As String Public Property Let ToolTipText(ByVal Value As String) ``` 返回/设置鼠标悬停时显示的提示文本。 ### HelpContextID ```vb Public Property Get HelpContextID() As Long Public Property Let HelpContextID(ByVal Value As Long) ``` 返回/设置帮助上下文ID。 ### WhatsThisHelpID ```vb Public Property Get WhatsThisHelpID() As Long Public Property Let WhatsThisHelpID(ByVal Value As Long) ``` 返回/设置关联的上下文帮助ID。 ### DragIcon ```vb Public Property Get DragIcon() As IPictureDisp Public Property Let DragIcon(ByVal Value As IPictureDisp) Public Property Set DragIcon(ByVal Value As IPictureDisp) ``` 返回/设置拖放操作中显示的图标。 ### DragMode ```vb Public Property Get DragMode() As Integer Public Property Let DragMode(ByVal Value As Integer) ``` 返回/设置拖动模式。 ### hWnd ```vb Public Property Get hWnd() As LongPtr ``` 返回控件句柄。 ### hWndUserControl ```vb Public Property Get hWndUserControl() As LongPtr ``` 返回UserControl句柄。 ### hWndEdit ```vb Public Property Get hWndEdit() As LongPtr ``` 返回编辑框句柄。 ### hWndList ```vb Public Property Get hWndList() As LongPtr ``` 返回下拉列表框句柄。 ### Font ```vb Public Property Get Font() As StdFont Public Property Let Font(ByVal NewFont As StdFont) Public Property Set Font(ByVal NewFont As StdFont) ``` 返回/设置字体。 ### VisualStyles ```vb Public Property Get VisualStyles() As Boolean Public Property Let VisualStyles(ByVal Value As Boolean) ``` 返回/设置是否启用视觉样式。需要comctl32.dll 6.0或更高版本。 ### BackColor ```vb Public Property Get BackColor() As OLE_COLOR Public Property Let BackColor(ByVal Value As OLE_COLOR) ``` 返回/设置背景色。 ### ForeColor ```vb Public Property Get ForeColor() As OLE_COLOR Public Property Let ForeColor(ByVal Value As OLE_COLOR) ``` 返回/设置前景色。 ### Enabled ```vb Public Property Get Enabled() As Boolean Public Property Let Enabled(ByVal Value As Boolean) ``` 返回/设置对象是否能响应用户事件。 ### OLEDragMode ```vb Public Property Get OLEDragMode() As VBRUN.OLEDragConstants Public Property Let OLEDragMode(ByVal Value As VBRUN.OLEDragConstants) ``` 返回/设置OLE拖拽模式。 ### OLEDropMode ```vb Public Property Get OLEDropMode() As OLEDropModeConstants Public Property Let OLEDropMode(ByVal Value As OLEDropModeConstants) ``` 返回/设置对象是否可以作为OLE放置目标。 ### MousePointer ```vb Public Property Get MousePointer() As CCMousePointerConstants Public Property Let MousePointer(ByVal Value As CCMousePointerConstants) ``` 返回/设置鼠标悬停时显示的指针类型。参见通用枚举。 ### MouseIcon ```vb Public Property Get MouseIcon() As IPictureDisp Public Property Let MouseIcon(ByVal Value As IPictureDisp) Public Property Set MouseIcon(ByVal Value As IPictureDisp) ``` 返回/设置自定义鼠标图标。 ### MouseTrack ```vb Public Property Get MouseTrack() As Boolean Public Property Let MouseTrack(ByVal Value As Boolean) ``` 返回/设置是否在鼠标进入或离开控件时触发事件。 ### RightToLeft ```vb Public Property Get RightToLeft() As Boolean Public Property Let RightToLeft(ByVal Value As Boolean) ``` 返回/设置从右到左显示方向。 ### RightToLeftMode ```vb Public Property Get RightToLeftMode() As CCRightToLeftModeConstants Public Property Let RightToLeftMode(ByVal Value As CCRightToLeftModeConstants) ``` 返回/设置从右到左模式。参见通用枚举。 ### Style ```vb Public Property Get Style() As VcbStyleConstants Public Property Let Style(ByVal Value As VcbStyleConstants) ``` 返回/设置组合框样式。仅设计时可设置。 ### Locked ```vb Public Property Get Locked() As Boolean Public Property Let Locked(ByVal Value As Boolean) ``` 返回/设置是否锁定（禁止编辑和选择）。 ### Text ```vb Public Property Get Text() As String Public Property Let Text(ByVal Value As String) ``` 返回/设置编辑框文本。 ### Default ```vb Public Property Get Default() As String Public Property Let Default(ByVal Value As String) ``` 返回/设置默认文本。 ### ExtendedUI ```vb Public Property Get ExtendedUI() As Boolean Public Property Let ExtendedUI(ByVal Value As Boolean) ``` 返回/设置是否使用扩展用户界面（F4键打开下拉列表，ESC键关闭）。 ### MaxDropDownItems ```vb Public Property Get MaxDropDownItems() As Integer Public Property Let MaxDropDownItems(ByVal Value As Integer) ``` 返回/设置下拉列表最大显示项数。 ### IntegralHeight ```vb Public Property Get IntegralHeight() As Boolean Public Property Let IntegralHeight(ByVal Value As Boolean) ``` 返回/设置是否调整高度为完整项。仅设计时可设置。 ### MaxLength ```vb Public Property Get MaxLength() As Long Public Property Let MaxLength(ByVal Value As Long) ``` 返回/设置编辑框最大文本长度。 ### UseListBackColor ```vb Public Property Get UseListBackColor() As Boolean Public Property Let UseListBackColor(ByVal Value As Boolean) ``` 返回/设置是否使用列表背景色。 ### UseListForeColor ```vb Public Property Get UseListForeColor() As Boolean Public Property Let UseListForeColor(ByVal Value As Boolean) ``` 返回/设置是否使用列表前景色。 ### ListBackColor ```vb Public Property Get ListBackColor() As OLE_COLOR Public Property Let ListBackColor(ByVal Value As OLE_COLOR) ``` 返回/设置下拉列表背景色。 ### ListForeColor ```vb Public Property Get ListForeColor() As OLE_COLOR Public Property Let ListForeColor(ByVal Value As OLE_COLOR) ``` 返回/设置下拉列表前景色。 ### HorizontalExtent ```vb Public Property Get HorizontalExtent() As Single Public Property Let HorizontalExtent(ByVal Value As Single) ``` 返回/设置下拉列表水平滚动范围。 ### DrawMode ```vb Public Property Get DrawMode() As VcbDrawModeConstants Public Property Let DrawMode(ByVal Value As VcbDrawModeConstants) ``` 返回/设置绘制模式。仅设计时可设置。 ### IMEMode ```vb Public Property Get IMEMode() As CCIMEModeConstants Public Property Let IMEMode(ByVal Value As CCIMEModeConstants) ``` 返回/设置输入法模式。参见通用枚举。 ### ScrollTrack ```vb Public Property Get ScrollTrack() As Boolean Public Property Let ScrollTrack(ByVal Value As Boolean) ``` 返回/设置是否启用滚动跟踪（拖动滑块时实时滚动）。 ### AutoSelect ```vb Public Property Get AutoSelect() As Boolean Public Property Let AutoSelect(ByVal Value As Boolean) ``` 返回/设置是否自动选择匹配项。 ### AlwaysFindExact ```vb Public Property Get AlwaysFindExact() As Boolean Public Property Let AlwaysFindExact(ByVal Value As Boolean) ``` 返回/设置是否始终进行精确查找。 ### ListCount ```vb Public Property Get ListCount() As Long ``` 返回列表项数量。 ### List ```vb Public Property Get List(ByVal Index As Long) As String ``` 获取指定索引的列表项文本。通过GetVirtualItem事件获取数据。 ### ListIndex ```vb Public Property Get ListIndex() As Long Public Property Let ListIndex(ByVal Value As Long) ``` 返回/设置当前选中项索引。 ### SelStart ```vb Public Property Get SelStart() As Long Public Property Let SelStart(ByVal Value As Long) ``` 返回/设置选择起始位置。 ### SelLength ```vb Public Property Get SelLength() As Long Public Property Let SelLength(ByVal Value As Long) ``` 返回/设置选择长度。 ### SelText ```vb Public Property Get SelText() As String Public Property Let SelText(ByVal Value As String) ``` 返回/设置选择的文本。 ### ItemHeight ```vb Public Property Get ItemHeight() As Single Public Property Let ItemHeight(ByVal Value As Single) ``` 返回/设置项高度。 ### FieldHeight ```vb Public Property Get FieldHeight() As Single ``` 返回编辑框高度。 ### DroppedDown ```vb Public Property Get DroppedDown() As Boolean Public Property Let DroppedDown(ByVal Value As Boolean) ``` 返回/设置是否处于下拉状态。 ### DropDownWidth ```vb Public Property Get DropDownWidth() As Single Public Property Let DropDownWidth(ByVal Value As Single) ``` 返回/设置下拉列表宽度。 ### DropDownHeight ```vb Public Property Get DropDownHeight() As Single Public Property Let DropDownHeight(ByVal Value As Single) ``` 返回/设置下拉列表高度。 ### TopIndex ```vb Public Property Get TopIndex() As Long Public Property Let TopIndex(ByVal Value As Long) ``` 返回/设置下拉列表顶部可见项索引。 ## 方法 ### OLEDrag ```vb Public Sub OLEDrag() ``` 启动OLE拖放操作。 ### Drag ```vb Public Sub Drag(Optional ByRef Action As Variant) ``` 开始、结束或取消拖动操作。 ### SetFocus ```vb Public Sub SetFocus() ``` 将焦点移到指定对象。 ### ZOrder ```vb Public Sub ZOrder(Optional ByRef Position As Variant) ``` 设置Z顺序。 ### Refresh ```vb Public Sub Refresh() ``` 强制完全重绘对象。 ### FindItem ```vb Public Function FindItem(ByVal Text As String, Optional ByVal Index As Long = -1, Optional ByVal Partial As Boolean) As Long ``` 查找列表项。返回匹配项索引，未找到返回-1。 ### GetIdealHorizontalExtent ```vb Public Function GetIdealHorizontalExtent() As Single ``` 获取理想的水平滚动范围。 ### SelectItem ```vb Public Function SelectItem(ByVal Text As String, Optional ByVal Index As Long = -1) As Long ``` 搜索并选择匹配的列表项。返回选中项索引。 ## 事件 ### Click ```vb Public Event Click() ``` 用户单击控件时触发。 ### DblClick ```vb Public Event DblClick() ``` 用户双击控件时触发。 ### Scroll ```vb Public Event Scroll() ``` 下拉列表滚动时触发。 ### Change ```vb Public Event Change() ``` 文本内容改变时触发。 ### ContextMenu ```vb Public Event ContextMenu(ByRef Handled As Boolean, ByVal X As Single, ByVal Y As Single) ``` 右键上下文菜单事件。设置Handled为True可禁止默认菜单。 ### GetVirtualItem ```vb Public Event GetVirtualItem(ByVal Item As Long, ByRef Text As String) ``` 请求虚拟项数据时触发。需设置Text参数返回项文本。 ### FindVirtualItem ```vb Public Event FindVirtualItem(ByVal StartIndex As Long, ByVal SearchText As String, ByVal Partial As Boolean, ByRef FoundIndex As Long) ``` 搜索虚拟项时触发。需设置FoundIndex返回匹配项索引，未找到设为-1。 ### IncrementalSearch ```vb Public Event IncrementalSearch(ByVal SearchString As String, ByVal StartIndex As Long, ByRef FoundIndex As Long) ``` 增量搜索时触发。需设置FoundIndex返回匹配项索引。 ### DropDown ```vb Public Event DropDown() ``` 下拉列表展开时触发。 ### CloseUp ```vb Public Event CloseUp() ``` 下拉列表关闭时触发。 ### ItemDraw ```vb Public Event ItemDraw(ByVal Item As Long, ByVal ItemAction As Long, ByVal ItemState As Long, ByVal hDC As Long, ByVal Left As Long, ByVal Top As Long, ByVal Right As Long, ByVal Bottom As Long) ``` 自绘项时触发（DrawMode为OwnerDrawFixed时）。 ### PreviewKeyDown ```vb Public Event PreviewKeyDown(ByVal KeyCode As Integer, ByRef IsInputKey As Boolean) ``` 按键预览事件。设置IsInputKey为True可将按键标记为输入键。 ### PreviewKeyUp ```vb Public Event PreviewKeyUp(ByVal KeyCode As Integer, ByRef IsInputKey As Boolean) ``` 按键释放预览事件。 ### KeyDown ```vb Public Event KeyDown(KeyCode As Integer, Shift As Integer) ``` 按下键盘键时触发。 ### KeyUp ```vb Public Event KeyUp(KeyCode As Integer, Shift As Integer) ``` 释放键盘键时触发。 ### KeyPress ```vb Public Event KeyPress(KeyChar As Integer) ``` 按下并释放ANSI键时触发。 ### MouseDown ```vb Public Event MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` 按下鼠标按钮时触发。 ### MouseMove ```vb Public Event MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` 移动鼠标时触发。 ### MouseUp ```vb Public Event MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` 释放鼠标按钮时触发。 ### MouseEnter ```vb Public Event MouseEnter() ``` 鼠标进入控件区域时触发。 ### MouseLeave ```vb Public Event MouseLeave() ``` 鼠标离开控件区域时触发。 ### OLECompleteDrag ```vb Public Event OLECompleteDrag(Effect As Long) ``` OLE拖放操作完成时触发。 ### OLEDragDrop ```vb Public Event OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single) ``` OLE拖放操作放置时触发。 ### OLEDragOver ```vb Public Event OLEDragOver(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single, State As Integer) ``` OLE拖放操作悬停时触发。 ### OLEGiveFeedback ```vb Public Event OLEGiveFeedback(Effect As Long, DefaultCursors As Boolean) ``` OLE拖放操作给反馈时触发。 ### OLESetData ```vb Public Event OLESetData(Data As DataObject, DataFormat As Integer) ``` OLE拖放操作设置数据时触发。 ### OLEStartDrag ```vb Public Event OLEStartDrag(Data As DataObject, AllowedEffects As Long) ``` OLE拖放操作开始时触发。 ## 辅助模块 ### VirtualComboBase.bas 自定义窗口类辅助模块，注册/释放"VComboBoxWndClass"窗口类，为ComboLBox添加LBS\_NODATA样式。 #### VcbWndRegisterClass ```vb Public Sub VcbWndRegisterClass() ``` 注册自定义窗口类。 #### VcbWndReleaseClass ```vb Public Sub VcbWndReleaseClass() ``` 释放自定义窗口类。 ## 代码示例 ### 基本用法 ```vb ' 设置虚拟组合框 With VirtualCombo1 .Style = VcbStyleDropDownList .ListCount = 1000 .MaxDropDownItems = 15 End With ' 提供虚拟项数据 Private Sub VirtualCombo1_GetVirtualItem(ByVal Item As Long, ByRef Text As String) Text = "项目 " & CStr(Item) End Sub ' 查找虚拟项 Private Sub VirtualCombo1_FindVirtualItem(ByVal StartIndex As Long, _ ByVal SearchText As String, ByVal Partial As Boolean, ByRef FoundIndex As Long) FoundIndex = -1 End Sub ' 监听下拉事件 Private Sub VirtualCombo1_DropDown() Debug.Print "下拉列表已打开" End Sub Private Sub VirtualCombo1_Change() Debug.Print "当前文本: " & VirtualCombo1.Text End Sub ``` --- --- url: /zh/emoji/0700-074F.md --- # 叙利亚文 (Syriac) 本页面展示了Unicode字符集中，位于U+0700到U+074F范围的叙利亚文字符。叙利亚文是一种闪米特语系文字，主要用于古叙利亚语，从右向左书写。 | 字符 | Unicode | VB函数值 | 名称 | |:---:|:---:|:---:|:---| | ܐ | U+0710 | ChrW(\&H0710) | 叙利亚文字母ALAPH | | ܑ | U+0711 | ChrW(\&H0711) | 叙利亚文字母上标ALAPH | | ܒ | U+0712 | ChrW(\&H0712) | 叙利亚文字母BETH | | ܓ | U+0713 | ChrW(\&H0713) | 叙利亚文字母GAMAL | | ܔ | U+0714 | ChrW(\&H0714) | 叙利亚文字母GAMAL GARSHUNI | | ܕ | U+0715 | ChrW(\&H0715) | 叙利亚文字母DALATH | | ܖ | U+0716 | ChrW(\&H0716) | 叙利亚文字母DOTLESS DALATH RISH | | ܗ | U+0717 | ChrW(\&H0717) | 叙利亚文字母HE | | ܘ | U+0718 | ChrW(\&H0718) | 叙利亚文字母WAW | | ܙ | U+0719 | ChrW(\&H0719) | 叙利亚文字母ZAIN | --- --- url: /zh/packages/vbccr/buttons/optionbuttonw.md description: 选项按钮控件（OptionButtonW） - VBCCR 开发手册，基于源码的完整 API 参考 --- # 选项按钮控件（OptionButtonW） 封装 Windows 系统按钮控件（Button），以单选按钮样式运行，支持图形样式、所有者绘制、图像列表及视觉样式。 ## 枚举 ### OptImageListAlignmentConstants | 常量 | 值 | 说明 | |------|-----|------| | OptImageListAlignmentLeft | 0 | 左对齐 | | OptImageListAlignmentRight | 1 | 右对齐 | | OptImageListAlignmentTop | 2 | 顶部对齐 | | OptImageListAlignmentBottom | 3 | 底部对齐 | | OptImageListAlignmentCenter | 4 | 居中对齐 | ### OptDrawModeConstants | 常量 | 值 | 说明 | |------|-----|------| | OptDrawModeNormal | 0 | 标准模式，由系统绘制 | | OptDrawModeOwnerDraw | 1 | 所有者绘制模式，由代码处理绘制 | ### CCAppearanceConstants 参见通用枚举。 ### CCLeftRightAlignmentConstants 参见通用枚举。 ### CCVerticalAlignmentConstants 参见通用枚举。 ### CCMousePointerConstants 参见通用枚举。 ### CCRightToLeftModeConstants 参见通用枚举。 ### OLEDropModeConstants 参见通用枚举。 ## 属性 ### Value ```vb Property Get Value() As OLE_OPTEXCLUSIVE Property Let Value(ByVal NewValue As OLE_OPTEXCLUSIVE) ``` 选项按钮的选中状态。True 表示选中。 ### Caption ```vb Property Get Caption() As String Property Let Caption(ByVal Value As String) ``` 显示在控件上的文本标题。 ### Alignment ```vb Property Get Alignment() As CCLeftRightAlignmentConstants Property Let Alignment(ByVal Value As CCLeftRightAlignmentConstants) ``` 选项按钮标题的对齐方式（左侧或右侧）。参见通用枚举。 ### TextAlignment ```vb Property Get TextAlignment() As VBRUN.AlignmentConstants Property Let TextAlignment(ByVal Value As VBRUN.AlignmentConstants) ``` 标题文本的对齐方式（左对齐、居中或右对齐）。 ### PushLike ```vb Property Get PushLike() As Boolean Property Let PushLike(ByVal Value As Boolean) ``` 是否使控件外观和行为类似下压按钮。 ### Picture ```vb Property Get Picture() As IPictureDisp Property Let Picture(ByVal Value As IPictureDisp) Property Set Picture(ByVal Value As IPictureDisp) ``` 显示在控件上的图片。 ### WordWrap ```vb Property Get WordWrap() As Boolean Property Let WordWrap(ByVal Value As Boolean) ``` 是否允许标题文本换行以防止溢出。 ### Transparent ```vb Property Get Transparent() As Boolean Property Let Transparent(ByVal Value As Boolean) ``` 是否以底层背景的副本模拟透明背景。设计时忽略此属性。 ### VerticalAlignment ```vb Property Get VerticalAlignment() As CCVerticalAlignmentConstants Property Let VerticalAlignment(ByVal Value As CCVerticalAlignmentConstants) ``` 垂直对齐方式。参见通用枚举。 ### Style ```vb Property Get Style() As VBRUN.ButtonConstants Property Let Style(ByVal Value As VBRUN.ButtonConstants) ``` 控件外观样式，标准或图形。当 DrawMode 不为 Normal 时，Style 必须为 Standard。 ### DisabledPicture ```vb Property Get DisabledPicture() As IPictureDisp Property Let DisabledPicture(ByVal Value As IPictureDisp) Property Set DisabledPicture(ByVal Value As IPictureDisp) ``` 按钮禁用时显示的图片。仅当 Style 为图形样式时适用。 ### DownPicture ```vb Property Get DownPicture() As IPictureDisp Property Let DownPicture(ByVal Value As IPictureDisp) Property Set DownPicture(ByVal Value As IPictureDisp) ``` 按钮按下时显示的图片。仅当 Style 为图形样式时适用。 ### UseMaskColor ```vb Property Get UseMaskColor() As Boolean Property Let UseMaskColor(ByVal Value As Boolean) ``` 是否使用 MaskColor 属性作为透明色。仅当 Style 为图形样式时适用。 ### MaskColor ```vb Property Get MaskColor() As OLE_COLOR Property Let MaskColor(ByVal Value As OLE_COLOR) ``` 图片中作为透明色（遮罩）的颜色。仅当 Style 为图形样式时适用。 ### DrawMode ```vb Property Get DrawMode() As OptDrawModeConstants Property Let DrawMode(ByVal Value As OptDrawModeConstants) ``` 绘制模式，标准或所有者绘制。 ### ImageList ```vb Property Get ImageList() As Variant Property Let ImageList(ByVal Value As Variant) Property Set ImageList(ByVal Value As Variant) ``` 关联的图像列表控件。图像列表应包含单个图片（用于所有状态）或每种状态的独立图片。需要 comctl32.dll 6.0 或更高版本。 ### ImageListAlignment ```vb Property Get ImageListAlignment() As OptImageListAlignmentConstants Property Let ImageListAlignment(ByVal Value As OptImageListAlignmentConstants) ``` 图像列表中图像的对齐方式。需要 comctl32.dll 6.0 或更高版本。 ### ImageListMargin ```vb Property Get ImageListMargin() As Single Property Let ImageListMargin(ByVal Value As Single) ``` 图像列表中图像的边距。需要 comctl32.dll 6.0 或更高版本。 ### Pushed ```vb Property Get Pushed() As Boolean Property Let Pushed(ByVal Value As Boolean) ``` 选项按钮是否处于按下状态。 ### Hot ```vb Property Get Hot() As Boolean Property Let Hot(ByVal Value As Boolean) ``` 选项按钮是否处于热态（鼠标悬停）。只读，写入时引发错误 383。需要 comctl32.dll 6.0 或更高版本。 ### VisualStyles ```vb Property Get VisualStyles() As Boolean Property Let VisualStyles(ByVal Value As Boolean) ``` 是否启用视觉样式。需要 comctl32.dll 6.0 或更高版本。 ### Appearance ```vb Property Get Appearance() As CCAppearanceConstants Property Let Appearance(ByVal Value As CCAppearanceConstants) ``` 控件外观，平面或三维效果。参见通用枚举。 ### BackColor ```vb Property Get BackColor() As OLE_COLOR Property Let BackColor(ByVal Value As OLE_COLOR) ``` 背景颜色。 ### ForeColor ```vb Property Get ForeColor() As OLE_COLOR Property Let ForeColor(ByVal Value As OLE_COLOR) ``` 前景颜色。 ### Enabled ```vb Property Get Enabled() As Boolean Property Let Enabled(ByVal Value As Boolean) ``` 是否可用。 ### OLEDropMode ```vb Property Get OLEDropMode() As OLEDropModeConstants Property Let OLEDropMode(ByVal Value As OLEDropModeConstants) ``` OLE 拖放目标模式。参见通用枚举。 ### MousePointer ```vb Property Get MousePointer() As CCMousePointerConstants Property Let MousePointer(ByVal Value As CCMousePointerConstants) ``` 鼠标指针样式。参见通用枚举。 ### MouseIcon ```vb Property Get MouseIcon() As IPictureDisp Property Let MouseIcon(ByVal Value As IPictureDisp) Property Set MouseIcon(ByVal Value As IPictureDisp) ``` 自定义鼠标图标。 ### MouseTrack ```vb Property Get MouseTrack() As Boolean Property Let MouseTrack(ByVal Value As Boolean) ``` 是否启用鼠标进入/离开跟踪。 ### RightToLeft ```vb Property Get RightToLeft() As Boolean Property Let RightToLeft(ByVal Value As Boolean) ``` 从右到左显示方向。 ### RightToLeftMode ```vb Property Get RightToLeftMode() As CCRightToLeftModeConstants Property Let RightToLeftMode(ByVal Value As CCRightToLeftModeConstants) ``` 从右到左模式。参见通用枚举。 ### Font ```vb Property Get Font() As StdFont Property Let Font(ByVal NewFont As StdFont) Property Set Font(ByVal NewFont As StdFont) ``` 字体。 ### hWnd ```vb Property Get hWnd() As LongPtr ``` 选项按钮控件的窗口句柄。 ### hWndUserControl ```vb Property Get hWndUserControl() As LongPtr ``` 用户控件的窗口句柄。 ### Name ```vb Property Get Name() As String ``` 控件名称。只读。 ### Tag ```vb Property Get Tag() As String Property Let Tag(ByVal Value As String) ``` 自定义数据。 ### Parent ```vb Property Get Parent() As Object ``` 父对象。只读。 ### Container ```vb Property Get Container() As Object Property Set Container(ByVal Value As Object) ``` 容器对象。 ### Left ```vb Property Get Left() As Single Property Let Left(ByVal Value As Single) ``` 左边距。 ### Top ```vb Property Get Top() As Single Property Let Top(ByVal Value As Single) ``` 顶边距。 ### Width ```vb Property Get Width() As Single Property Let Width(ByVal Value As Single) ``` 宽度。 ### Height ```vb Property Get Height() As Single Property Let Height(ByVal Value As Single) ``` 高度。 ### Visible ```vb Property Get Visible() As Boolean Property Let Visible(ByVal Value As Boolean) ``` 是否可见。 ### ToolTipText ```vb Property Get ToolTipText() As String Property Let ToolTipText(ByVal Value As String) ``` 工具提示文本。 ### HelpContextID ```vb Property Get HelpContextID() As Long Property Let HelpContextID(ByVal Value As Long) ``` 帮助上下文 ID。 ### WhatsThisHelpID ```vb Property Get WhatsThisHelpID() As Long Property Let WhatsThisHelpID(ByVal Value As Long) ``` "这是什么"帮助 ID。 ### DragIcon ```vb Property Get DragIcon() As IPictureDisp Property Let DragIcon(ByVal Value As IPictureDisp) Property Set DragIcon(ByVal Value As IPictureDisp) ``` 拖拽图标。 ### DragMode ```vb Property Get DragMode() As Integer Property Let DragMode(ByVal Value As Integer) ``` 拖拽模式。 ## 方法 ### Drag ```vb Public Sub Drag([ByRef Action As Variant]) ``` 开始、结束或取消拖放操作。 ### SetFocus ```vb Public Sub SetFocus() ``` 将焦点移至控件。 ### ZOrder ```vb Public Sub ZOrder([ByRef Position As Variant]) ``` 设置控件的 Z 顺序。 ### OLEDrag ```vb Public Sub OLEDrag() ``` 启动 OLE 拖放操作。 ### Refresh ```vb Public Sub Refresh() ``` 强制重绘控件。 ## 事件 ### Click ```vb Public Event Click() ``` 在控件上按下并释放鼠标按钮时触发。 ### DblClick ```vb Public Event DblClick() ``` 在控件上双击鼠标时触发。 ### HotChanged ```vb Public Event HotChanged() ``` 选项按钮的热态状态发生变化时触发。需要 comctl32.dll 6.0 或更高版本。 ### OwnerDraw ```vb Public Event OwnerDraw(ByVal Action As Long, ByVal State As Long, ByVal hDC As Long, ByVal Left As Long, ByVal Top As Long, ByVal Right As Long, ByVal Bottom As Long) ``` 所有者绘制按钮的某个视觉方面发生变化时触发。 ### PreviewKeyDown ```vb Public Event PreviewKeyDown(ByVal KeyCode As Integer, ByRef IsInputKey As Boolean) ``` 在 KeyDown 事件之前触发。 ### PreviewKeyUp ```vb Public Event PreviewKeyUp(ByVal KeyCode As Integer, ByRef IsInputKey As Boolean) ``` 在 KeyUp 事件之前触发。 ### KeyDown ```vb Public Event KeyDown(KeyCode As Integer, Shift As Integer) ``` 按下按键时触发。 ### KeyUp ```vb Public Event KeyUp(KeyCode As Integer, Shift As Integer) ``` 释放按键时触发。 ### KeyPress ```vb Public Event KeyPress(KeyChar As Integer) ``` 按键字符输入时触发。 ### MouseDown ```vb Public Event MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` 按下鼠标按钮时触发。 ### MouseMove ```vb Public Event MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` 移动鼠标时触发。 ### MouseUp ```vb Public Event MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` 释放鼠标按钮时触发。 ### MouseEnter ```vb Public Event MouseEnter() ``` 鼠标进入控件时触发。 ### MouseLeave ```vb Public Event MouseLeave() ``` 鼠标离开控件时触发。 ### OLECompleteDrag ```vb Public Event OLECompleteDrag(Effect As Long) ``` OLE 拖放操作完成或取消后触发。 ### OLEDragDrop ```vb Public Event OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single) ``` 数据通过 OLE 拖放操作放到控件上时触发。 ### OLEDragOver ```vb Public Event OLEDragOver(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single, State As Integer) ``` OLE 拖放操作期间鼠标移过控件时触发。 ### OLEGiveFeedback ```vb Public Event OLEGiveFeedback(Effect As Long, DefaultCursors As Boolean) ``` OLE 拖放操作中需要更改鼠标光标时触发。 ### OLESetData ```vb Public Event OLESetData(Data As DataObject, DataFormat As Integer) ``` 放置目标请求 OLEDragStart 期间未提供的数据时触发。 ### OLEStartDrag ```vb Public Event OLEStartDrag(Data As DataObject, AllowedEffects As Long) ``` OLE 拖放操作启动时触发。 ## 代码示例 ```vb ' 基本选项按钮 OptionButtonW1.Caption = "选项 A" OptionButtonW1.Value = True ' 图形样式 OptionButtonW1.Style = vbButtonGraphical Set OptionButtonW1.Picture = LoadPicture("C:\icon.bmp") Set OptionButtonW1.DownPicture = LoadPicture("C:\icon_down.bmp") ' 按下式选项按钮 OptionButtonW1.PushLike = True ' 使用图像列表 Set OptionButtonW1.ImageList = ImageList1 OptionButtonW1.ImageListAlignment = OptImageListAlignmentLeft OptionButtonW1.ImageListMargin = 4 ' 所有者绘制 OptionButtonW1.DrawMode = OptDrawModeOwnerDraw ``` --- --- url: /zh/packages/vbccr/views/tabstrip.md description: 选项卡控件（TabStrip） - VBCCR 开发手册，基于源码的完整 API 参考 --- # 选项卡控件（TabStrip） 提供可自定义的选项卡容器，支持多种放置位置、多行标签、分隔符、自绘和OLE拖放。 ## 枚举 ### TbsPlacementConstants 选项卡放置位置常量。 | 常量 | 值 | 说明 | |------|-----|------| | TbsPlacementTop | 0 | 顶部放置 | | TbsPlacementBottom | 1 | 底部放置 | | TbsPlacementLeft | 2 | 左侧放置 | | TbsPlacementRight | 3 | 右侧放置 | ### TbsStyleConstants 选项卡控件样式常量。 | 常量 | 值 | 说明 | |------|-----|------| | TbsStyleTab | 0 | 标准选项卡样式 | | TbsStyleButton | 1 | 按钮样式 | | TbsStyleFlatButton | 2 | 扁平按钮样式 | ### TbsTabStyleConstants 选项卡标签样式常量。 | 常量 | 值 | 说明 | |------|-----|------| | TbsTabStyleTab | 0 | 标准标签样式 | | TbsTabStyleButton | 1 | 按钮标签样式 | ### TbsTabWidthStyleConstants 选项卡宽度样式常量。 | 常量 | 值 | 说明 | |------|-----|------| | TbsTabWidthStyleJustified | 0 | 根据标签宽度自动调整 | | TbsTabWidthStyleFixed | 1 | 固定宽度 | | TbsTabWidthStyleVariable | 2 | 可变宽度 | ### TbsTabAlignmentConstants 选项卡标签对齐方式常量。 | 常量 | 值 | 说明 | |------|-----|------| | TbsTabAlignmentNear | 0 | 靠近起始边对齐 | | TbsTabAlignmentCenter | 1 | 居中对齐 | | TbsTabAlignmentFar | 2 | 靠近结束边对齐 | ### TbsHitResultConstants 命中测试结果常量。 | 常量 | 值 | 说明 | |------|-----|------| | TbsHitNowhere | 0 | 未命中任何选项卡 | | TbsHitTab | 1 | 命中选项卡 | | TbsHitDivider | 2 | 命中分隔符 | | TbsHitDisplay | 3 | 命中显示区域 | ### TbsDrawModeConstants 自绘模式常量。 | 常量 | 值 | 说明 | |------|-----|------| | TbsDrawModeNormal | 0 | 正常绘制 | | TbsDrawModeOwnerDraw | 1 | 自绘模式 | ## 属性 ### Name ```vb Public Property Get Name() As String ``` 返回在代码中标识对象的名称。 ### Tag ```vb Public Property Get Tag() As String Public Property Let Tag(ByVal Value As String) ``` 存储程序所需的额外数据。 ### Parent ```vb Public Property Get Parent() As Object ``` 返回对象所在的对象。 ### Container ```vb Public Property Get Container() As Object Public Property Set Container(ByVal Value As Object) ``` 返回/设置对象的容器。 ### Left ```vb Public Property Get Left() As Single Public Property Let Left(ByVal Value As Single) ``` 返回/设置对象与其容器左边缘的距离。 ### Top ```vb Public Property Get Top() As Single Public Property Let Top(ByVal Value As Single) ``` 返回/设置对象与其容器顶边缘的距离。 ### Width ```vb Public Property Get Width() As Single Public Property Let Width(ByVal Value As Single) ``` 返回/设置对象的宽度。 ### Height ```vb Public Property Get Height() As Single Public Property Let Height(ByVal Value As Single) ``` 返回/设置对象的高度。 ### Visible ```vb Public Property Get Visible() As Boolean Public Property Let Visible(ByVal Value As Boolean) ``` 返回/设置对象是否可见。 ### ToolTipText ```vb Public Property Get ToolTipText() As String Public Property Let ToolTipText(ByVal Value As String) ``` 返回/设置鼠标悬停时显示的提示文本。 ### WhatsThisHelpID ```vb Public Property Get WhatsThisHelpID() As Long Public Property Let WhatsThisHelpID(ByVal Value As Long) ``` 返回/设置关联的上下文帮助ID。 ### DragIcon ```vb Public Property Get DragIcon() As IPictureDisp Public Property Let DragIcon(ByVal Value As IPictureDisp) Public Property Set DragIcon(ByVal Value As IPictureDisp) ``` 返回/设置拖放操作中显示的图标。 ### DragMode ```vb Public Property Get DragMode() As Integer Public Property Let DragMode(ByVal Value As Integer) ``` 返回/设置拖动模式（手动或自动）。 ### hWnd ```vb Public Property Get hWnd() As LongPtr ``` 返回控件句柄。 ### hWndUserControl ```vb Public Property Get hWndUserControl() As LongPtr ``` 返回UserControl句柄。 ### Font ```vb Public Property Get Font() As StdFont Public Property Let Font(ByVal NewFont As StdFont) Public Property Set Font(ByVal NewFont As StdFont) ``` 返回/设置字体。 ### VisualStyles ```vb Public Property Get VisualStyles() As Boolean Public Property Let VisualStyles(ByVal Value As Boolean) ``` 返回/设置是否启用视觉样式。需要comctl32.dll 6.0或更高版本。 ### Enabled ```vb Public Property Get Enabled() As Boolean Public Property Let Enabled(ByVal Value As Boolean) ``` 返回/设置对象是否能响应用户事件。 ### OLEDropMode ```vb Public Property Get OLEDropMode() As OLEDropModeConstants Public Property Let OLEDropMode(ByVal Value As OLEDropModeConstants) ``` 返回/设置对象是否可以作为OLE放置目标。 ### MousePointer ```vb Public Property Get MousePointer() As CCMousePointerConstants Public Property Let MousePointer(ByVal Value As CCMousePointerConstants) ``` 返回/设置鼠标悬停时显示的指针类型。参见通用枚举。 ### MouseIcon ```vb Public Property Get MouseIcon() As IPictureDisp Public Property Let MouseIcon(ByVal Value As IPictureDisp) Public Property Set MouseIcon(ByVal Value As IPictureDisp) ``` 返回/设置自定义鼠标图标。 ### MouseTrack ```vb Public Property Get MouseTrack() As Boolean Public Property Let MouseTrack(ByVal Value As Boolean) ``` 返回/设置是否在鼠标进入或离开控件时触发事件。 ### RightToLeft ```vb Public Property Get RightToLeft() As Boolean Public Property Let RightToLeft(ByVal Value As Boolean) ``` 返回/设置从右到左显示方向。 ### RightToLeftLayout ```vb Public Property Get RightToLeftLayout() As Boolean Public Property Let RightToLeftLayout(ByVal Value As Boolean) ``` 返回/设置从右到左布局。 ### RightToLeftMode ```vb Public Property Get RightToLeftMode() As CCRightToLeftModeConstants Public Property Let RightToLeftMode(ByVal Value As CCRightToLeftModeConstants) ``` 返回/设置从右到左模式。参见通用枚举。 ### BackColor ```vb Public Property Get BackColor() As OLE_COLOR Public Property Let BackColor(ByVal Value As OLE_COLOR) ``` 返回/设置背景色。 ### ImageList ```vb Public Property Get ImageList() As Variant Public Property Let ImageList(ByVal Value As Variant) Public Property Set ImageList(ByVal Value As Variant) ``` 返回/设置关联的ImageList控件。可以是对象引用、字符串键名或LongPtr句柄。 ### Placement ```vb Public Property Get Placement() As TbsPlacementConstants Public Property Let Placement(ByVal Value As TbsPlacementConstants) ``` 返回/设置选项卡的放置位置。 ### MultiRow ```vb Public Property Get MultiRow() As Boolean Public Property Let MultiRow(ByVal Value As Boolean) ``` 返回/设置选项卡是否允许多行显示。 ### MultiSelect ```vb Public Property Get MultiSelect() As Boolean Public Property Let MultiSelect(ByVal Value As Boolean) ``` 返回/设置是否允许选择多个选项卡。 ### HotTracking ```vb Public Property Get HotTracking() As Boolean Public Property Let HotTracking(ByVal Value As Boolean) ``` 返回/设置是否启用热点跟踪。 ### Style ```vb Public Property Get Style() As TbsStyleConstants Public Property Let Style(ByVal Value As TbsStyleConstants) ``` 返回/设置选项卡控件样式。 ### TabStyle ```vb Public Property Get TabStyle() As TbsTabStyleConstants Public Property Let TabStyle(ByVal Value As TbsTabStyleConstants) ``` 返回/设置选项卡标签样式。 ### TabWidthStyle ```vb Public Property Get TabWidthStyle() As TbsTabWidthStyleConstants Public Property Let TabWidthStyle(ByVal Value As TbsTabWidthStyleConstants) ``` 返回/设置选项卡宽度样式。 ### TabFixedWidth ```vb Public Property Get TabFixedWidth() As Single Public Property Let TabFixedWidth(ByVal Value As Single) ``` 返回/设置固定宽度样式下选项卡的宽度。 ### TabFixedHeight ```vb Public Property Get TabFixedHeight() As Single Public Property Let TabFixedHeight(ByVal Value As Single) ``` 返回/设置固定高度样式下选项卡的高度。 ### TabMinWidth ```vb Public Property Get TabMinWidth() As Single Public Property Let TabMinWidth(ByVal Value As Single) ``` 返回/设置选项卡的最小宽度。 ### TabAlignment ```vb Public Property Get TabAlignment() As TbsTabAlignmentConstants Public Property Let TabAlignment(ByVal Value As TbsTabAlignmentConstants) ``` 返回/设置选项卡标签的对齐方式。 ### Separators ```vb Public Property Get Separators() As Boolean Public Property Let Separators(ByVal Value As Boolean) ``` 返回/设置是否在选项卡之间显示分隔符。 ### ShowTips ```vb Public Property Get ShowTips() As Boolean Public Property Let ShowTips(ByVal Value As Boolean) ``` 返回/设置是否显示工具提示。 ### DrawMode ```vb Public Property Get DrawMode() As TbsDrawModeConstants Public Property Let DrawMode(ByVal Value As TbsDrawModeConstants) ``` 返回/设置绘制模式。 ### TabScrollWheel ```vb Public Property Get TabScrollWheel() As Boolean Public Property Let TabScrollWheel(ByVal Value As Boolean) ``` 返回/设置是否允许使用鼠标滚轮切换选项卡。 ### DoubleBuffer ```vb Public Property Get DoubleBuffer() As Boolean Public Property Let DoubleBuffer(ByVal Value As Boolean) ``` 返回/设置是否启用双缓冲绘制。 ### Transparent ```vb Public Property Get Transparent() As Boolean Public Property Let Transparent(ByVal Value As Boolean) ``` 返回/设置选项卡控件是否透明。 ### Tabs ```vb Public Property Get Tabs() As TbsTabs ``` 返回选项卡集合。 ### ClientLeft ```vb Public Property Get ClientLeft() As Single ``` 返回客户区域的左边距。 ### ClientTop ```vb Public Property Get ClientTop() As Single ``` 返回客户区域的顶边距。 ### ClientWidth ```vb Public Property Get ClientWidth() As Single ``` 返回客户区域的宽度。 ### ClientHeight ```vb Public Property Get ClientHeight() As Single ``` 返回客户区域的高度。 ### SelectedItem ```vb Public Property Get SelectedItem() As TbsTab Public Property Let SelectedItem(ByVal Value As TbsTab) ``` 返回/设置当前选中的选项卡。 ### RowCount ```vb Public Property Get RowCount() As Long ``` 返回选项卡行数。 ## 方法 ### Refresh ```vb Public Sub Refresh() ``` 强制完全重绘对象。 ### DeselectAll ```vb Public Sub DeselectAll() ``` 取消所有选项卡的选中状态。 ### HitTest ```vb Public Function HitTest(ByVal X As Single, ByVal Y As Single) As TbsHitResultConstants ``` 对指定坐标进行命中测试，返回命中结果。 ### DrawBackground ```vb Public Sub DrawBackground(ByVal hdc As LongPtr, ByVal Left As Long, ByVal Top As Long, ByVal Right As Long, ByVal Bottom As Long) ``` 在指定设备上下文中绘制选项卡控件背景。 ### OLEDrag ```vb Public Sub OLEDrag() ``` 启动OLE拖放操作。 ### Drag ```vb Public Sub Drag(Optional ByRef Action As Variant) ``` 开始、结束或取消拖动操作。 ### SetFocus ```vb Public Sub SetFocus() ``` 将焦点移至控件。 ### ZOrder ```vb Public Sub ZOrder(Optional ByRef Position As Variant) ``` 设置Z顺序。 ## 事件 ### TabBeforeClick ```vb Public Event TabBeforeClick(ByVal Tab As TbsTab, ByRef Cancel As Boolean) ``` 选项卡即将被点击时触发。Cancel为True时取消切换。 ### TabClick ```vb Public Event TabClick(ByVal Tab As TbsTab) ``` 选项卡被点击时触发。 ### ItemDraw ```vb Public Event ItemDraw(ByVal Index As Long, ByVal ItemData As Long, ByVal hdc As LongPtr, ByVal Left As Long, ByVal Top As Long, ByVal Right As Long, ByVal Bottom As Long) ``` 自绘模式下绘制选项卡时触发。 ### PreviewKeyDown ```vb Public Event PreviewKeyDown(KeyCode As Integer, Shift As Integer) ``` 在KeyDown事件之前触发，用于预处理键盘输入。 ### PreviewKeyUp ```vb Public Event PreviewKeyUp(KeyCode As Integer, Shift As Integer) ``` 在KeyUp事件之前触发。 ### KeyDown ```vb Public Event KeyDown(KeyCode As Integer, Shift As Integer) ``` 按下键盘按键时触发。 ### KeyUp ```vb Public Event KeyUp(KeyCode As Integer, Shift As Integer) ``` 释放键盘按键时触发。 ### KeyPress ```vb Public Event KeyPress(KeyAscii As Integer) ``` 按下并释放ANSI键时触发。 ### MouseDown ```vb Public Event MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` 按下鼠标按钮时触发。 ### MouseMove ```vb Public Event MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` 移动鼠标时触发。 ### MouseUp ```vb Public Event MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` 释放鼠标按钮时触发。 ### MouseEnter ```vb Public Event MouseEnter() ``` 鼠标进入控件区域时触发。 ### MouseLeave ```vb Public Event MouseLeave() ``` 鼠标离开控件区域时触发。 ### OLECompleteDrag ```vb Public Event OLECompleteDrag(Effect As Long) ``` OLE拖放操作完成时触发。 ### OLEDragDrop ```vb Public Event OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single) ``` OLE拖放操作放置时触发。 ### OLEDragOver ```vb Public Event OLEDragOver(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single, State As Integer) ``` OLE拖放操作悬停时触发。 ### OLEGiveFeedback ```vb Public Event OLEGiveFeedback(Effect As Long, DefaultCursors As Boolean) ``` OLE拖放操作给反馈时触发。 ### OLESetData ```vb Public Event OLESetData(Data As DataObject, DataFormat As Integer) ``` OLE拖放操作设置数据时触发。 ### OLEStartDrag ```vb Public Event OLEStartDrag(Data As DataObject, AllowedEffects As Long) ``` OLE拖放操作开始时触发。 ## 子对象 ### TbsTab 类 选项卡标签对象。 #### TbsTab 属性 #### Index ```vb Public Property Get Index() As Long ``` 选项卡在集合中的索引。 #### Key ```vb Public Property Get Key() As String Public Property Let Key(ByVal Value As String) ``` 选项卡的唯一标识键。 #### Tag ```vb Public Property Get Tag() As Variant Public Property Let Tag(ByVal Value As Variant) ``` 额外数据。 #### Caption ```vb Public Property Get Caption() As String Public Property Let Caption(ByVal Value As String) ``` 选项卡标题。 #### ToolTipText ```vb Public Property Get ToolTipText() As String Public Property Let ToolTipText(ByVal Value As String) ``` 工具提示文本。 #### Image ```vb Public Property Get Image() As Variant Public Property Let Image(ByVal Value As Variant) ``` 选项卡图像。 #### ImageIndex ```vb Public Property Get ImageIndex() As Long ``` 图像索引。 #### Selected ```vb Public Property Get Selected() As Boolean Public Property Let Selected(ByVal Value As Boolean) ``` 是否选中。 #### Pressed ```vb Public Property Get Pressed() As Boolean Public Property Let Pressed(ByVal Value As Boolean) ``` 是否按下。 #### HighLighted ```vb Public Property Get HighLighted() As Boolean Public Property Let HighLighted(ByVal Value As Boolean) ``` 是否高亮显示。 #### Left ```vb Public Property Get Left() As Single ``` 选项卡左边距。 #### Top ```vb Public Property Get Top() As Single ``` 选项卡顶边距。 #### Width ```vb Public Property Get Width() As Single ``` 选项卡宽度。 #### Height ```vb Public Property Get Height() As Single ``` 选项卡高度。 ### TbsTabs 类 选项卡集合。 #### TbsTabs 成员 #### NewEnum ```vb Public Function NewEnum() As IUnknown ``` 枚举器（隐藏）。 #### Add ```vb Public Function Add(Optional ByVal Index As Variant, Optional ByVal Key As Variant, Optional ByVal Caption As Variant, Optional ByVal Image As Variant) As TbsTab ``` 添加选项卡。 #### Item ```vb Public Function Item(ByVal Index As Variant) As TbsTab ``` 获取选项卡（默认成员）。 #### Exists ```vb Public Function Exists(ByVal Index As Variant) As Boolean ``` 检查选项卡是否存在。 #### Count ```vb Public Property Get Count() As Long ``` 选项卡数量。 #### Clear ```vb Public Sub Clear() ``` 清除所有选项卡。 #### Remove ```vb Public Sub Remove(ByVal Index As Variant) ``` 移除选项卡。 ## 代码示例 ### 基本用法 ```vb ' 创建选项卡 With TabStrip1.Tabs .Add , "Tab1", "常规" .Add , "Tab2", "高级" .Add , "Tab3", "关于" End With ' 设置选项卡样式 TabStrip1.Placement = TbsPlacementTop TabStrip1.Style = TbsStyleTab TabStrip1.TabWidthStyle = TbsTabWidthStyleFixed TabStrip1.TabFixedWidth = 80 TabStrip1.MultiRow = False TabStrip1.HotTracking = True ' 处理选项卡切换 Private Sub TabStrip1_TabBeforeClick(ByVal Tab As TbsTab, ByRef Cancel As Boolean) If Tab.Key = "Tab3" Then Cancel = True MsgBox "此选项卡已禁用" End If End Sub Private Sub TabStrip1_TabClick(ByVal Tab As TbsTab) MsgBox "选中的选项卡: " & Tab.Caption End Sub ' 使用客户区域定位子控件 Private Sub TabStrip1_TabClick(ByVal Tab As TbsTab) Dim l As Single, t As Single l = TabStrip1.ClientLeft t = TabStrip1.ClientTop Frame1.Move l, t, TabStrip1.ClientWidth, TabStrip1.ClientHeight End Sub ``` --- --- url: /zh/emoji/0530-058F.md --- # 亚美尼亚语 (Armenian) 本页面展示了Unicode字符集中，位于U+0530到U+058F范围的亚美尼亚语字符。亚美尼亚字母是世界上最古老的字母文字之一，始于公元405年。 | 字符 | Unicode | VB函数值 | 名称 | |:---:|:---:|:---:|:---| | Ա | U+0531 | ChrW(\&H0531) | 亚美尼亚大写字母AYB | | Բ | U+0532 | ChrW(\&H0532) | 亚美尼亚大写字母BEN | | Գ | U+0533 | ChrW(\&H0533) | 亚美尼亚大写字母GIM | | Դ | U+0534 | ChrW(\&H0534) | 亚美尼亚大写字母DA | | Ե | U+0535 | ChrW(\&H0535) | 亚美尼亚大写字母ECH | | Զ | U+0536 | ChrW(\&H0536) | 亚美尼亚大写字母ZA | | Է | U+0537 | ChrW(\&H0537) | 亚美尼亚大写字母EH | | Ը | U+0538 | ChrW(\&H0538) | 亚美尼亚大写字母ET | | Թ | U+0539 | ChrW(\&H0539) | 亚美尼亚大写字母TO | | Ժ | U+053A | ChrW(\&H053A) | 亚美尼亚大写字母ZHE | --- --- url: /zh/cases.md description: VBMAN 用户案例展示 - 物联网、工业控制、Web应用等领域的实际项目 --- # 用户案例 欢迎来到 **VBMAN 用户案例** 展示区！ 这里汇集了使用 VBMAN 系列产品开发的优秀项目和实际应用。每一个案例都是 VBMAN 能力的真实验证。 ## 按应用领域浏览 ### 🌡️ 物联网 / IoT 设备数据上云、传感器采集、远程控制 * [轻量物联网云平台](/cases/case-iot-cloud) — 拼个 URL 就能读写数据，ESP32/Arduino/Python 全支持 ### 🏭 工业控制 设备监控、数据采集、Modbus 通信 * 暂无真实案例 【占位案例，非实际】 ### 🌐 Web 应用 后台管理、在线服务、数据可视化 * 暂无真实案例 【占位案例，非实际】 ### 📚 教育 / 办公 在线考试、图书管理、信息系统 * 暂无真实案例 【占位案例，非实际】 ## 按核心模块浏览 | VBMAN 模块 | 相关案例 | | --- | --- | | **cHttpServer** | [轻量物联网云平台](/cases/case-iot-cloud) — REST API + CORS + 数据持久化 | | **WebSocket** | 更多案例征集中... | | **Redis** | 更多案例征集中... | | **Database** | 更多案例征集中... | | **WebView2** | 更多案例征集中... | | **Modbus** | 更多案例征集中... | ## 按难度浏览 | 难度 | 案例 | 说明 | | --- | --- | --- | | 🟢 入门级 | 暂无 | 适合刚接触 VBMAN 的开发者 | | 🟡 进阶级 | [轻量物联网云平台](/cases/case-iot-cloud) | 需要理解路由、JSON、数据存储 | | 🔴 高级 | 暂无 | 涉及多模块协作、复杂业务逻辑 | ## 提交您的案例 我们相信 **每一个 VB6 开发者都是艺术家**，您的作品值得被更多人看见！ ### 提交方式 1. **GitHub PR（推荐）**：Fork 项目 → 在 `docs/zh/cases/` 下创建 `case-xxx.md` → 提交 PR 2. **邮件提交**：发送至 **cases@vb6.pro**，主题格式：`【用户案例】项目名称 - 作者名` 3. **QQ 群提交**：联系群管理员提交 ### 提交内容建议 ```markdown --- title: 项目名称 description: 一句话描述项目 category: 应用领域（物联网/工业控制/Web应用/教育办公） tags: [核心模块标签] difficulty: 入门/进阶/高级 author: 作者名 date: 日期 --- # 项目名称 > 一句话亮点 ## 项目概览 （基本信息表格） ## VBMAN 技术实现 （使用了哪些 VBMAN 模块，关键代码片段） ## 实际效果 （截图、数据、部署规模等） ## 项目亮点总结 （亮点表格） ``` ::: tip 提示 提交案例即代表您同意在官网展示。所有提交需经过内容审核。支持匿名展示。 ::: --- --- url: /zh/cases/README.md --- # 用户案例目录 本目录用于存放 VBMAN 用户案例相关文档。 ## 文件说明 * `index.md` - 用户案例主页面（介绍页面） * `featured-cases.md` - 精选案例展示（由 index.md 引入） * `case-*.md` - 具体案例的详细介绍文件（按需添加） ## 目录结构建议 ``` cases/ ├── index.md # 主介绍页面 ├── featured-cases.md # 精选案例列表 ├── case-001.md # 案例1详细介绍 ├── case-002.md # 案例2详细介绍 └── ... ``` ## 添加新案例 1. 在本目录下创建新的 Markdown 文件（如 `case-xxx.md`） 2. 编写案例详细内容 3. 在 `featured-cases.md` 中添加案例概要（可选） 4. 更新主页面引用（如需要） --- --- url: /zh/packages/vbccr/datetime/monthview.md description: 月历视图控件（MonthView） - VBCCR 开发手册，基于源码的完整 API 参考 --- # 月历视图控件（MonthView） 封装 SysMonthCal32 系统月历控件，用于日期选择和日历显示，支持多日期选择、多月份视图等高级功能。 ## 枚举 ### MvwViewConstants | 常量 | 值 | 说明 | |------|-----|------| | MvwViewMonth | 0 | 月视图 | | MvwViewYear | 1 | 年视图 | | MvwViewDecade | 2 | 十年视图 | | MvwViewCentury | 3 | 百年视图 | ### MvwHitResultConstants | 常量 | 值 | 说明 | |------|-----|------| | MvwHitResultNowhere | 0 | 无命中 | | MvwHitResultTitleBg | 1 | 标题背景 | | MvwHitResultTitleMonth | 2 | 标题月份 | | MvwHitResultTitleYear | 3 | 标题年份 | | MvwHitResultTitlePrevMonth | 4 | 上一个月按钮 | | MvwHitResultTitleNextMonth | 5 | 下一个月按钮 | | MvwHitResultCalendarBg | 6 | 日历背景 | | MvwHitResultCalendarDate | 7 | 日历日期 | | MvwHitResultCalendarDateMin | 8 | 日历最小日期 | | MvwHitResultCalendarDateMax | 9 | 日历最大日期 | | MvwHitResultCalendarWeekNumber | 10 | 周数 | | MvwHitResultCalendarPrevMonth | 11 | 上个月的日期 | | MvwHitResultCalendarNextMonth | 12 | 下个月的日期 | | MvwHitResultTodayLink | 13 | "今天"链接 | ### CCMousePointerConstants 参见通用枚举。 ## 属性 ### Value ```vb Property Get Value() As Date Property Let Value(ByVal Value As Date) ``` 当前选中的日期。 ### MinDate ```vb Property Get MinDate() As Date Property Let MinDate(ByVal Value As Date) ``` 最小可选日期。 ### MaxDate ```vb Property Get MaxDate() As Date Property Let MaxDate(ByVal Value As Date) ``` 最大可选日期。 ### Year ```vb Property Get Year() As Integer Property Let Year(ByVal Value As Integer) ``` 当前年份。 ### Month ```vb Property Get Month() As Integer Property Let Month(ByVal Value As Integer) ``` 当前月份（1-12）。 ### Week ```vb Property Get Week() As Integer Property Let Week(ByVal Value As Integer) ``` 当前周数。 ### Day ```vb Property Get Day() As Integer Property Let Day(ByVal Value As Integer) ``` 当前日（1-31）。 ### DayCount ```vb Property Get DayCount() As Long ``` 当前可见月份中包含的天数。只读。 ### CalendarCount ```vb Property Get CalendarCount() As Long ``` 当前显示的月份数量。只读。 ### ShowToday ```vb Property Get ShowToday() As Boolean Property Let ShowToday(ByVal Value As Boolean) ``` 是否显示"今天"日期。 ### ShowTodayCircle ```vb Property Get ShowTodayCircle() As Boolean Property Let ShowTodayCircle(ByVal Value As Boolean) ``` 是否用圆圈标记今天。 ### ShowWeekNumbers ```vb Property Get ShowWeekNumbers() As Boolean Property Let ShowWeekNumbers(ByVal Value As Boolean) ``` 是否显示周数。 ### ShowTrailingDates ```vb Property Get ShowTrailingDates() As Boolean Property Let ShowTrailingDates(ByVal Value As Boolean) ``` 是否显示上/下个月的拖尾日期。 ### ScrollRate ```vb Property Get ScrollRate() As Long Property Let ScrollRate(ByVal Value As Long) ``` 滚动速率。 ### StartOfWeek ```vb Property Get StartOfWeek() As Integer Property Let StartOfWeek(ByVal Value As Integer) ``` 一周的开始日（0=周日，1=周一...6=周六）。 ### MultiSelect ```vb Property Get MultiSelect() As Boolean Property Let MultiSelect(ByVal Value As Boolean) ``` 是否允许多日期选择。 ### DayState ```vb Property Get DayState() As String Property Let DayState(ByVal Value As String) ``` 日期状态位图字符串，控制日期的粗体显示。 ### MaxSelCount ```vb Property Get MaxSelCount() As Long Property Let MaxSelCount(ByVal Value As Long) ``` 多选时的最大可选天数。 ### MonthColumns ```vb Property Get MonthColumns() As Long Property Let MonthColumns(ByVal Value As Long) ``` 水平显示的月份数。 ### MonthRows ```vb Property Get MonthRows() As Long Property Let MonthRows(ByVal Value As Long) ``` 垂直显示的月份数。 ### View ```vb Property Get View() As MvwViewConstants Property Let View(ByVal Value As MvwViewConstants) ``` 日历视图模式。 ### UseShortestDayNames ```vb Property Get UseShortestDayNames() As Boolean Property Let UseShortestDayNames(ByVal Value As Boolean) ``` 是否使用最短的星期名称。 ### BackColor ```vb Property Get BackColor() As OLE_COLOR Property Let BackColor(ByVal Value As OLE_COLOR) ``` 背景颜色。 ### ForeColor ```vb Property Get ForeColor() As OLE_COLOR Property Let ForeColor(ByVal Value As OLE_COLOR) ``` 前景颜色。 ### TitleBackColor ```vb Property Get TitleBackColor() As OLE_COLOR Property Let TitleBackColor(ByVal Value As OLE_COLOR) ``` 标题背景颜色。 ### TitleForeColor ```vb Property Get TitleForeColor() As OLE_COLOR Property Let TitleForeColor(ByVal Value As OLE_COLOR) ``` 标题前景颜色。 ### TrailingForeColor ```vb Property Get TrailingForeColor() As OLE_COLOR Property Let TrailingForeColor(ByVal Value As OLE_COLOR) ``` 拖尾日期的前景颜色。 ### SelStart ```vb Property Get SelStart() As Date Property Let SelStart(ByVal Value As Date) ``` 选择范围的起始日期。 ### SelEnd ```vb Property Get SelEnd() As Date Property Let SelEnd(ByVal Value As Date) ``` 选择范围的结束日期。 ### Today ```vb Property Get Today() As Date ``` 返回今天的日期。只读。 ### SystemStartOfWeek ```vb Property Get SystemStartOfWeek() As Integer ``` 返回系统设置的一周开始日。只读。 ### DayOfWeek ```vb Property Get DayOfWeek() As Integer ``` 返回 Value 对应的星期几。只读。 ### VisualStyles ```vb Property Get VisualStyles() As Boolean Property Let VisualStyles(ByVal Value As Boolean) ``` 是否启用视觉样式。 ### hWnd ```vb Property Get hWnd() As LongPtr ``` 月历视图控件的窗口句柄。 ### hWndUserControl ```vb Property Get hWndUserControl() As LongPtr ``` 用户控件的窗口句柄。 ### Font ```vb Property Get Font() As StdFont Property Let Font(ByVal NewFont As StdFont) Property Set Font(ByVal NewFont As StdFont) ``` 字体。 ### Enabled ```vb Property Get Enabled() As Boolean Property Let Enabled(ByVal Value As Boolean) ``` 是否可用。 ### MousePointer ```vb Property Get MousePointer() As CCMousePointerConstants Property Let MousePointer(ByVal Value As CCMousePointerConstants) ``` 鼠标指针样式。参见通用枚举。 ### MouseIcon ```vb Property Get MouseIcon() As IPictureDisp Property Let MouseIcon(ByVal Value As IPictureDisp) Property Set MouseIcon(ByVal Value As IPictureDisp) ``` 自定义鼠标图标。 ### MouseTrack ```vb Property Get MouseTrack() As Boolean Property Let MouseTrack(ByVal Value As Boolean) ``` 是否启用鼠标进入/离开跟踪。 ### RightToLeft ```vb Property Get RightToLeft() As Boolean Property Let RightToLeft(ByVal Value As Boolean) ``` 从右到左显示方向。 ### RightToLeftMode ```vb Property Get RightToLeftMode() As CCRightToLeftModeConstants Property Let RightToLeftMode(ByVal Value As CCRightToLeftModeConstants) ``` 从右到左模式。参见通用枚举。 ### Name ```vb Property Get Name() As String ``` 控件名称。只读。 ### Tag ```vb Property Get Tag() As String Property Let Tag(ByVal Value As String) ``` 自定义数据。 ### Parent ```vb Property Get Parent() As Object ``` 父对象。只读。 ### Container ```vb Property Get Container() As Object Property Set Container(ByVal Value As Object) ``` 容器对象。 ### Left ```vb Property Get Left() As Single Property Let Left(ByVal Value As Single) ``` 左边距。 ### Top ```vb Property Get Top() As Single Property Let Top(ByVal Value As Single) ``` 顶边距。 ### Width ```vb Property Get Width() As Single Property Let Width(ByVal Value As Single) ``` 宽度。 ### Height ```vb Property Get Height() As Single Property Let Height(ByVal Value As Single) ``` 高度。 ### Visible ```vb Property Get Visible() As Boolean Property Let Visible(ByVal Value As Boolean) ``` 是否可见。 ### ToolTipText ```vb Property Get ToolTipText() As String Property Let ToolTipText(ByVal Value As String) ``` 工具提示文本。 ### HelpContextID ```vb Property Get HelpContextID() As Long Property Let HelpContextID(ByVal Value As Long) ``` 帮助上下文 ID。 ### WhatsThisHelpID ```vb Property Get WhatsThisHelpID() As Long Property Let WhatsThisHelpID(ByVal Value As Long) ``` "这是什么"帮助 ID。 ### DragIcon ```vb Property Get DragIcon() As IPictureDisp Property Let DragIcon(ByVal Value As IPictureDisp) Property Set DragIcon(ByVal Value As IPictureDisp) ``` 拖拽图标。 ### DragMode ```vb Property Get DragMode() As Integer Property Let DragMode(ByVal Value As Integer) ``` 拖拽模式。 ## 方法 ### SetSelRange ```vb Public Sub SetSelRange(ByVal StartDate As Date, ByVal EndDate As Date) ``` 设置日期选择范围。 ### ComputeControlSize ```vb Public Sub ComputeControlSize() ``` 根据当前设置重新计算控件大小。 ### GetMonthRange ```vb Public Function GetMonthRange() As String ``` 获取当前显示的月份范围。 ### HitTest ```vb Public Function HitTest(ByVal X As Single, ByVal Y As Single) As MvwHitResultConstants ``` 测试指定坐标处的命中区域。 ### Drag ```vb Public Sub Drag([ByRef Action As Variant]) ``` 开始、结束或取消拖放操作。 ### SetFocus ```vb Public Sub SetFocus() ``` 将焦点移至控件。 ### ZOrder ```vb Public Sub ZOrder([ByRef Position As Variant]) ``` 设置控件的 Z 顺序。 ### OLEDrag ```vb Public Sub OLEDrag() ``` 启动 OLE 拖放操作。 ### Refresh ```vb Public Sub Refresh() ``` 强制重绘控件。 ## 事件 ### GetDayBold ```vb Public Event GetDayBold(ByRef DayState As String) ``` 需要获取日期粗体状态时触发。 ### SelChange ```vb Public Event SelChange(ByVal StartDate As Date, ByVal EndDate As Date) ``` 选择范围发生改变时触发。 ### DateClick ```vb Public Event DateClick(ByVal DateClicked As Date) ``` 单击某个日期时触发。 ### ViewChange ```vb Public Event ViewChange() ``` 视图模式发生改变时触发。 ### ContextMenu ```vb Public Event ContextMenu(ByRef Handled As Boolean, ByVal X As Single, ByVal Y As Single) ``` 右键单击或按 Shift+F10 时触发。 ### Click ```vb Public Event Click() ``` 单击控件时触发。 ### DblClick ```vb Public Event DblClick() ``` 双击控件时触发。 ### MouseDown ```vb Public Event MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` 按下鼠标按钮时触发。 ### MouseUp ```vb Public Event MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` 释放鼠标按钮时触发。 ### MouseMove ```vb Public Event MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` 移动鼠标时触发。 ### MouseEnter ```vb Public Event MouseEnter() ``` 鼠标进入控件时触发。 ### MouseLeave ```vb Public Event MouseLeave() ``` 鼠标离开控件时触发。 ### KeyDown ```vb Public Event KeyDown(KeyCode As Integer, Shift As Integer) ``` 按下按键时触发。 ### KeyUp ```vb Public Event KeyUp(KeyCode As Integer, Shift As Integer) ``` 释放按键时触发。 ### KeyPress ```vb Public Event KeyPress(KeyChar As Integer) ``` 按键字符输入时触发。 ### OLEDragDrop ```vb Public Event OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single) ``` OLE 拖放完成时触发。 ### OLEDragOver ```vb Public Event OLEDragOver(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single, State As Integer) ``` OLE 拖放经过控件时触发。 ### OLEGiveFeedback ```vb Public Event OLEGiveFeedback(Effect As Long, DefaultCursors As Boolean) ``` OLE 拖放需要更改光标时触发。 ### OLEStartDrag ```vb Public Event OLEStartDrag(Data As DataObject, AllowedEffects As Long) ``` OLE 拖放开始时触发。 ### OLECompleteDrag ```vb Public Event OLECompleteDrag(Effect As Long) ``` OLE 拖放完成时触发。 ### OLESetData ```vb Public Event OLESetData(Data As DataObject, DataFormat As Integer) ``` OLE 放置目标请求数据时触发。 ## 代码示例 ```vb ' 基本日期选择 MonthView1.Value = Date ' 限制可选日期范围 MonthView1.MinDate = #1/1/2025# MonthView1.MaxDate = #12/31/2025# ' 多日期选择 MonthView1.MultiSelect = True MonthView1.MaxSelCount = 7 Call MonthView1.SetSelRange(#1/1/2025#, #1/7/2025#) ' 多月份显示 MonthView1.MonthColumns = 2 MonthView1.MonthRows = 1 ``` --- --- url: /zh/emoji/2300-23FF.md --- # 杂项工业符号 (U+2300 - U+23FF) 本节包含各种用于工业和技术用途的符号，包括键盘符号、数学和技术图形等。 | 字符 | Unicode | VB函数值 | 名称 | |:---:|:---:|:---:|:---| | ⌀ | U+2300 | ChrW(\&H2300) | 直径符号 | | ⌁ | U+2301 | ChrW(\&H2301) | 电源符号 | | ⌂ | U+2302 | ChrW(\&H2302) | 房屋符号 | | ⌃ | U+2303 | ChrW(\&H2303) | 上控制符号 | | ⌄ | U+2304 | ChrW(\&H2304) | 下控制符号 | | ⌅ | U+2305 | ChrW(\&H2305) | 投影符号 | | ⌆ | U+2306 | ChrW(\&H2306) | 透视符号 | | ⌇ | U+2307 | ChrW(\&H2307) | 波浪符号 | | ⌈ | U+2308 | ChrW(\&H2308) | 左上角括号 | | ⌉ | U+2309 | ChrW(\&H2309) | 右上角括号 | | ⌊ | U+230A | ChrW(\&H230A) | 左下角括号 | | ⌋ | U+230B | ChrW(\&H230B) | 右下角括号 | | ⌌ | U+230C | ChrW(\&H230C) | 左上角弧 | | ⌍ | U+230D | ChrW(\&H230D) | 右上角弧 | | ⌎ | U+230E | ChrW(\&H230E) | 左下角弧 | | ⌏ | U+230F | ChrW(\&H230F) | 右下角弧 | | ⌐ | U+2310 | ChrW(\&H2310) | 逆向非符号 | | ⌑ | U+2311 | ChrW(\&H2311) | 方形符号 | | ⌒ | U+2312 | ChrW(\&H2312) | 弧形符号 | | ⌓ | U+2313 | ChrW(\&H2313) | 段符号 | | ⌔ | U+2314 | ChrW(\&H2314) | 点划线符号 | | ⌕ | U+2315 | ChrW(\&H2315) | 电话录音机符号 | | ⌖ | U+2316 | ChrW(\&H2316) | 位置指示符号 | | ⌗ | U+2317 | ChrW(\&H2317) | 查看符号 | | ⌘ | U+2318 | ChrW(\&H2318) | 花苞符号(Command键) | | ⌙ | U+2319 | ChrW(\&H2319) | 转接符号 | | ⌚ | U+231A | ChrW(\&H231A) | 手表符号 | | ⌛ | U+231B | ChrW(\&H231B) | 沙漏符号 | | ⌜ | U+231C | ChrW(\&H231C) | 左上角 | | ⌝ | U+231D | ChrW(\&H231D) | 右上角 | | ⌞ | U+231E | ChrW(\&H231E) | 左下角 | | ⌟ | U+231F | ChrW(\&H231F) | 右下角 | --- --- url: /demo/stop.md --- # 暂停开放的通知 因被群友提醒直接下载有风险，现在暂停开放。 正在着手制作《用户使用协议》和开发者绑定流程。待完善后即可开放下载。 ## 加群关注 具体开放时间可以加QQ群关注：915520648 或者点击链接加入群聊 [【vbman 官方群】](http://qm.qq.com/cgi-bin/qm/qr?_wv=1027\&k=N7akYcHZ6b_vpZpaAbOrEw3C4DV6aXDq\&authKey=NgvYiAwUFBi%2Fd7e03Y3aP5nczelbOxRTPiDWalaG2BIQHAx9OeMvRHn9kBWZo6LG\&noverify=0\&group_code=915520648) --- --- url: /zh/emoji/0F00-0FFF.md --- # 藏文 (Tibetan) 本页面展示了Unicode字符集中，位于U+0F00到U+0FFF范围的藏文字符。藏文是西藏自治区的官方文字，用于书写藏语。 | 字符 | Unicode | VB函数值 | 名称 | |:---:|:---:|:---:|:---| | ༀ | U+0F00 | ChrW(\&H0F00) | 藏文音节OM | | ༁ | U+0F01 | ChrW(\&H0F01) | 藏文标记GTER YIG MGO TRUNCATED A | | ༂ | U+0F02 | ChrW(\&H0F02) | 藏文标记GTER YIG MGO -UM RNAM BCAD MA | | ༃ | U+0F03 | ChrW(\&H0F03) | 藏文标记GTER YIG MGO -UM GTER TSHEG MA | | ༄ | U+0F04 | ChrW(\&H0F04) | 藏文标记INITIAL YIG MGO MDUN MA | | ༅ | U+0F05 | ChrW(\&H0F05) | 藏文标记CLOSING YIG MGO SGAB MA | | ༆ | U+0F06 | ChrW(\&H0F06) | 藏文标记CARET YIG MGO PHUR SHAD MA | | ༇ | U+0F07 | ChrW(\&H0F07) | 藏文标记YIG MGO TSHEG SHAD MA | | ༈ | U+0F08 | ChrW(\&H0F08) | 藏文标记SBRUL SHAD | | ༉ | U+0F09 | ChrW(\&H0F09) | 藏文标记BSKUR YIG MGO | --- --- url: /zh/packages/vbccr/system/framew.md description: 增强框架控件（FrameW） - VBCCR 开发手册，基于源码的完整 API 参考 --- # 增强框架控件（FrameW） 提供支持视觉样式、透明背景和图片显示的容器框架控件，可作为其他控件的容器。 ## 枚举 无专有公共枚举。使用以下通用枚举：CCAppearanceConstants、CCLeftRightAlignmentConstants、CCMousePointerConstants、CCRightToLeftModeConstants、OLEDropModeConstants。 ## 属性 ### Name ```vb Property Get Name() As String ``` 返回控件的名称。 ### Tag ```vb Property Get/Let Tag() As String ``` 返回/设置控件的标记值。 ### Parent ```vb Property Get Parent() As Object ``` 返回控件的父对象。 ### Container ```vb Property Get/Set Container() As Object ``` 返回/设置控件的容器。 ### Left ```vb Property Get/Let Left() As Single ``` 返回/设置控件左边缘的位置。 ### Top ```vb Property Get/Let Top() As Single ``` 返回/设置控件上边缘的位置。 ### Width ```vb Property Get/Let Width() As Single ``` 返回/设置控件的宽度。 ### Height ```vb Property Get/Let Height() As Single ``` 返回/设置控件的高度。 ### Visible ```vb Property Get/Let Visible() As Boolean ``` 返回/设置控件是否可见。 ### ToolTipText ```vb Property Get/Let ToolTipText() As String ``` 返回/设置控件的工具提示文本。 ### WhatsThisHelpID ```vb Property Get/Let WhatsThisHelpID() As Long ``` 返回/设置控件的"这是什么"帮助 ID。 ### DragIcon ```vb Property Get/Let/Set DragIcon() As IPictureDisp ``` 返回/设置拖动操作时显示的图标。 ### DragMode ```vb Property Get/Let DragMode() As Integer ``` 返回/设置拖动模式（手动或自动）。 ### hWnd ```vb Property Get hWnd() As LongPtr ``` 返回控件的窗口句柄。 ### Font ```vb Property Get/Let/Set Font() As StdFont ``` 返回/设置控件使用的字体。 ### VisualStyles ```vb Property Get/Let VisualStyles() As Boolean ``` 返回/设置是否启用视觉样式。 ### Appearance ```vb Property Get/Let Appearance() As CCAppearanceConstants ``` 返回/设置控件的视觉外观。参见通用枚举。 ### BackColor ```vb Property Get/Let BackColor() As OLE_COLOR ``` 返回/设置控件的背景色。 ### ForeColor ```vb Property Get/Let ForeColor() As OLE_COLOR ``` 返回/设置控件的前景色（标题文字颜色）。 ### Enabled ```vb Property Get/Let Enabled() As Boolean ``` 返回/设置控件是否可用。 ### OLEDropMode ```vb Property Get/Let OLEDropMode() As OLEDropModeConstants ``` 返回/设置 OLE 放置模式。参见通用枚举。 ### MousePointer ```vb Property Get/Let MousePointer() As CCMousePointerConstants ``` 返回/设置鼠标指针类型。参见通用枚举。 ### MouseIcon 无此属性。框架控件不支持自定义鼠标图标。 ### MouseTrack ```vb Property Get/Let MouseTrack() As Boolean ``` 返回/设置是否启用鼠标进入/离开跟踪。 ### RightToLeft ```vb Property Get/Let RightToLeft() As Boolean ``` 返回/设置是否启用从右到左布局。 ### RightToLeftMode ```vb Property Get/Let RightToLeftMode() As CCRightToLeftModeConstants ``` 返回/设置从右到左模式。参见通用枚举。 ### BorderStyle ```vb Property Get/Let BorderStyle() As Integer ``` 返回/设置控件的边框样式。值：0 (vbBSNone) 无边框，1 (vbFixedSingle) 固定单线边框。 ### Caption ```vb Property Get/Let Caption() As String ``` 返回/设置框架标题文本。 ### UseMnemonic ```vb Property Get/Let UseMnemonic() As Boolean ``` 返回/设置标题中的 & 符号是否作为访问键。 ### Alignment ```vb Property Get/Let Alignment() As VBRUN.AlignmentConstants ``` 返回/设置标题的对齐方式。 ### Transparent ```vb Property Get/Let Transparent() As Boolean ``` 返回/设置控件是否透明。 ### Picture ```vb Property Get/Let/Set Picture() As IPictureDisp ``` 返回/设置框架中显示的图片。 ### PictureAlignment ```vb Property Get/Let PictureAlignment() As CCLeftRightAlignmentConstants ``` 返回/设置图片的对齐方式。参见通用枚举。 ### ContainedControls ```vb Property Get ContainedControls() As VBRUN.ContainedControls ``` 返回框架包含的控件集合。只读。 ## 方法 ### OLEDrag ```vb Public Sub OLEDrag() ``` 启动 OLE 拖动操作。 ### Drag ```vb Public Sub Drag(Optional ByRef Action As Variant) ``` 开始、结束或取消拖动操作。 ### ZOrder ```vb Public Sub ZOrder(Optional ByRef Position As Variant) ``` 设置控件在其层级中的 Z 顺序位置。 ### Refresh ```vb Public Sub Refresh() ``` 强制完全重绘控件。 ## 事件 ### Click ```vb Public Event Click() ``` 单击控件时发生。 ### DblClick ```vb Public Event DblClick() ``` 双击控件时发生。 ### Resize ```vb Public Event Resize() ``` 控件大小改变时发生。 ### MouseDown ```vb Public Event MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` 按下鼠标按钮时发生。 ### MouseMove ```vb Public Event MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` 移动鼠标时发生。 ### MouseUp ```vb Public Event MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` 释放鼠标按钮时发生。 ### MouseEnter ```vb Public Event MouseEnter() ``` 鼠标进入控件时发生。 ### MouseLeave ```vb Public Event MouseLeave() ``` 鼠标离开控件时发生。 ### OLECompleteDrag ```vb Public Event OLECompleteDrag(Effect As Long) ``` OLE 拖放操作完成或取消后，在源控件上发生。 ### OLEDragDrop ```vb Public Event OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single) ``` 数据通过 OLE 拖放操作放置到控件上时发生。 ### OLEDragOver ```vb Public Event OLEDragOver(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single, State As Integer) ``` OLE 拖放操作期间鼠标移过控件时发生。 ### OLEGiveFeedback ```vb Public Event OLEGiveFeedback(Effect As Long, DefaultCursors As Boolean) ``` OLE 拖放操作期间需要更改鼠标光标时，在源控件上发生。 ### OLESetData ```vb Public Event OLESetData(Data As DataObject, DataFormat As Integer) ``` 放置目标请求数据时，在源控件上发生。 ### OLEStartDrag ```vb Public Event OLEStartDrag(Data As DataObject, AllowedEffects As Long) ``` OLE 拖放操作启动时发生。 ## 代码示例 ### 基本用法 ```vb Private Sub Form_Load() With FrameW1 .Caption = "选项设置" .BorderStyle = vbFixedSingle .UseMnemonic = True .Alignment = vbLeftJustify .VisualStyles = True End With End Sub Private Sub FrameW1_Resize() Debug.Print "框架尺寸: " & FrameW1.Width & " x " & FrameW1.Height End Sub ``` --- --- url: /zh/vbman/tls/certfile.md --- # 证书文件模式 (TlsCertFile) ## 概述 证书文件模式是最常用、最简单的 TLS 配置方式。将证书文件路径和密码传入 `TlsCertFile()` 链式函数，底层自动解析文件格式并加载证书。 ## 函数签名 ```vb Public Function TlsCertFile( _ ByVal CertFile As String, _ Optional ByVal Password As String, _ Optional ByVal AlpnProtocols As String = "...") As <组件类型> ``` ### 参数 | 参数 | 类型 | 必要 | 说明 | |------|------|------|------| | `CertFile` | String | 是 | 证书文件路径，支持 PFX/P12 和 PEM 格式 | | `Password` | String | 否 | 证书密码。PEM 无加密私钥时留空 | | `AlpnProtocols` | String | 否 | ALPN 协议协商。各组件默认值不同，见下表 | | 组件 | AlpnProtocols 默认值 | |------|---------------------| | cHttpServer | `"http/1.1"` | | cWinsock | `"http/1.1"` | | cWebSocketServer | `""`（空） | ## 支持的文件格式 ### 1. PFX / P12（PKCS#12） 二进制格式，单文件包含证书链和私钥，最方便管理。 ```vb Server.TlsCertFile("C:\certs\server.pfx", "my-password").Start 443 ``` **特点：** * 单文件包含完整证书链 + 私钥 * 支持密码保护 * Windows 证书导出标准格式 * IIS 证书导出的默认格式 **获取方式：** * 从 CA 机构下载 * OpenSSL 生成：`openssl req -x509 -newkey rsa:2048 -keyout key.pem -out cert.pem -days 365 -nodes` * OpenSSL 转 PFX：`openssl pkcs12 -export -out server.pfx -inkey key.pem -in cert.pem` * Windows 证书管理器导出（含私钥） ### 2. PEM 格式 — 单文件 文本格式，文件中同时包含证书和私钥。 ```vb Server.TlsCertFile("C:\certs\server.pem").Start 443 ``` **文件内容示例：** ``` -----BEGIN CERTIFICATE----- MIIFazCCBFOgAwIBAgISA2Q3p... （服务器证书） -----END CERTIFICATE----- -----BEGIN CERTIFICATE----- MIIFazCCBFOgAwIBAgISA3B4q... （中间证书） -----END CERTIFICATE----- -----BEGIN PRIVATE KEY----- MIIEvgIBADANBgkqhkiG9w0BAQ... （私钥） -----END PRIVATE KEY----- ``` ### 3. PEM 格式 — 多文件（用 `|` 分隔） 最灵活的方式，证书和私钥分别存放在不同文件中。使用 `|` 管道符分隔多个文件路径。 ```vb ' Let's Encrypt 标准输出格式 Server.TlsCertFile("C:\certs\fullchain.pem|C:\certs\privkey.pem").Start 443 ' 三文件：证书 + 中间证书 + 私钥 Server.TlsCertFile("C:\certs\cert.pem|C:\certs\chain.pem|C:\certs\privkey.pem").Start 443 ``` **底层处理：** 1. 首先尝试作为 PFX/P12 解析（单文件时） 2. 失败后将 `CertFile` 按 `|` 分割为数组 3. 对每个文件路径调用 PEM 解析 4. 自动识别 PEM 块类型（CERTIFICATE / PRIVATE KEY / RSA PRIVATE KEY / EC PRIVATE KEY） ## 各组件使用示例 ### cHttpServer（HTTPS） ```vb ' PEM 多文件（Let's Encrypt 最常见） Server.TlsCertFile("C:\certs\fullchain.pem|C:\certs\privkey.pem").Start 443 ' PFX 带密码 + WebRoot Server.TlsCertFile("C:\certs\server.pfx", "password").WebRoot("C:\www").Start 443 ' PEM 单文件 Server.TlsCertFile("C:\certs\server.pem").Start 443 ' HTTP + HTTPS 双端口 Dim httpSvr As New cHttpServer httpSvr.WebRoot("C:\www").Start 80 Dim httpsSvr As New cHttpServer httpsSvr.TlsCertFile("C:\certs\server.pfx", "pwd").WebRoot("C:\www").Start 443 ``` ### cWinsock（TLS TCP） ```vb ' 服务端：出示证书 Dim svr As New cWinsock svr.TlsCertFile("C:\certs\server.pfx", "password").Listen 443 ' 客户端：只需启用 TLS（无需证书） Dim cli As New cWinsock cli.Tls.Connect "example.com", 443 ``` ### cWebSocketServer（wss://） ```vb ' PFX 证书 Dim wsSvr As New cWebSocketServer wsSvr.TlsCertFile("C:\certs\server.pfx", "password").Listen 443 ' PEM 多文件 wsSvr.TlsCertFile("C:\certs\fullchain.pem|C:\certs\privkey.pem").Listen 443 ``` ## Let's Encrypt 自动化 Let's Encrypt 是最常见的免费证书来源，其输出文件与 PEM 多文件模式完美匹配： ``` /etc/letsencrypt/live/example.com/ ├── fullchain.pem ← 服务器证书 + 中间证书 ├── privkey.pem ← 私钥 ├── cert.pem ← 仅服务器证书 └── chain.pem ← 仅中间证书 ``` ```vb ' 使用 fullchain + privkey（推荐） Server.TlsCertFile("/etc/letsencrypt/live/example.com/fullchain.pem|" & _ "/etc/letsencrypt/live/example.com/privkey.pem").Start 443 ``` **注意：** Windows 上路径使用反斜杠 `C:\certs\fullchain.pem|C:\certs\privkey.pem`。 ## 自签名证书（开发测试） 使用 OpenSSL 生成自签名证书： ```bash # 生成私钥和证书（有效期 365 天） openssl req -x509 -newkey rsa:2048 -keyout key.pem -out cert.pem -days 365 -nodes -subj "/CN=localhost" # 合并为单文件 PEM type cert.pem key.pem > server.pem # 或转换为 PFX openssl pkcs12 -export -out server.pfx -inkey key.pem -in cert.pem ``` ```vb ' 使用自签名 PEM Server.TlsCertFile("C:\dev\server.pem").Start 443 ' 使用自签名 PFX Server.TlsCertFile("C:\dev\server.pfx").Start 443 ``` ## 证书链完整性 PEM 格式必须包含完整的证书链，否则客户端会报证书不可信： ``` ✅ 正确：fullchain.pem = 服务器证书 + 中间证书 ❌ 错误：cert.pem = 仅服务器证书（缺少中间证书） ``` 常见 CA 的中间证书： * Let's Encrypt：ISRG Root X1 → R3/R4/R10 等 * DigiCert：DigiCert Global Root CA → 中间 CA * GlobalSign：GlobalSign Root CA → 中间 CA ## 常见问题 ### 1. 文件路径找不到 ``` LastError: 证书文件不存在或格式错误 ``` **解决：** 检查文件路径是否正确，注意 Windows 路径使用反斜杠。 ### 2. 密码错误 ``` LastError: 证书文件不存在或格式错误 ``` **解决：** PFX 密码区分大小写，确认密码正确。PEM 私钥未加密时 Password 留空。 ### 3. PEM 缺少私钥 ``` LastError: 证书文件不存在或格式错误 ``` **解决：** 确保 PEM 文件或文件组合中包含 `-----BEGIN PRIVATE KEY-----` 或 `-----BEGIN RSA PRIVATE KEY-----` 块。 ### 4. 证书过期 ``` 浏览器显示：您的连接不是私密连接 ``` **解决：** 更新证书。Let's Encrypt 证书有效期 90 天，需配置自动续期。 ## 底层处理流程 ``` TlsCertFile(path, pwd) │ ├─ 尝试 PKCS#12 解析（单文件时） │ └─ pvPkiPkcs12ImportCertificates() │ └─ OpenSSL d2i_PKCS12 + PKCS12_parse │ └─ 尝试 PEM 解析（Split by "|"） └─ pvPkiPemImportCertificates() └─ OpenSSL PEM_read_bio_X509 + PEM_read_bio_PrivateKey ``` ## 相关文档 * [TLS 证书配置总览](./overview.md) * [Windows 证书存储模式](./certsubject.md) * [内存证书集合模式](./certmemory.md) * [cHttpServer TLS 支持](../httpserver/tls.md) * [cWinsock TLS 支持](../winsock/tls.md) * [cWebSocket TLS 支持](../websocket/tls.md) *** **最后更新**: 2026-06-09 --- --- url: /zh/vbman/database/execute.md --- # 执行操作 本文档详细介绍 cDataBase 类的数据修改操作，包括 INSERT、UPDATE、DELETE 等。 *** ## ? 目录 * [Exec 方法](#exec-方法) * [INSERT 操作](#insert-操作) * [UPDATE 操作](#update-操作) * [DELETE 操作](#delete-操作) * [获取影响行数](#获取影响行数) * [获取最后插入ID](#获取最后插入id) * [批量操作](#批量操作) *** ## Exec 方法 ### 基本语法 `Exec` 方法用于执行 INSERT、UPDATE、DELETE 等非查询 SQL 语句。 #### 语法 ```vb Function Exec(Optional RecordsAffected, Optional Options As Long = -1) As Boolean ``` #### 参数说明 | 参数 | 类型 | 说明 | | ----------------- | --------- | ------------------------- | | `RecordsAffected` | `Variant` | 返回受影响的行数（可选） | | `Options` | `Long` | 执行选项（可选，默认 -1） | #### 返回值 * `True` - 执行成功 * `False` - 执行失败（可通过 `LastErr` 查看错误信息） #### 示例 ```vb ' 执行 INSERT 语句 If db.Sql("INSERT INTO users (name, age) VALUES ('张三', 25)").Exec Then Debug.Print "插入成功" Else Debug.Print "插入失败: " & db.LastErr End If ``` *** ## INSERT 操作 ### 基本插入 ```vb ' 插入单条记录 If db.Sql("INSERT INTO users (name, age, email) VALUES ('张三', 25, 'zhangsan@example.com')").Exec Then Debug.Print "插入成功" End If ``` ### 插入多条记录 ```vb ' 使用 VALUES 子句插入多条 Dim sSql As String sSql = "INSERT INTO users (name, age) VALUES " & _ "('张三', 25), " & _ "('李四', 30), " & _ "('王五', 28)" If db.Sql(sSql).Exec Then Debug.Print "批量插入成功" End If ``` ### 使用参数化插入 ```vb ' 使用参数化查询（推荐，防止 SQL 注入） If db.Sql("INSERT INTO users (name, age, email) VALUES (?, ?, ?)") _ .Param("name", "张三", adVarWChar) _ .Param("age", 25, adInteger) _ .Param("email", "zhangsan@example.com", adVarWChar) _ .ExecParam Then Debug.Print "插入成功，ID: " & db.LastInsertId End If ' 注意：ExecParam 执行完毕后自动清理参数（调用 ClearParam），无需手动清理 ``` ```` ### INSERT SELECT ```vb ' 从其他表插入数据 If db.Sql("INSERT INTO users_backup SELECT * FROM users WHERE age > 30").Exec Then Debug.Print "数据复制成功" End If ```` *** ## UPDATE 操作 ### 基本更新 ```vb ' 更新单条记录 If db.Sql("UPDATE users SET age = 26 WHERE id = 1").Exec Then Debug.Print "更新成功" End If ``` ### 更新多条记录 ```vb ' 批量更新 If db.Sql("UPDATE users SET status = 'active' WHERE age > 18").Exec Then Debug.Print "批量更新成功" End If ``` ### 使用参数化更新 ```vb ' 使用参数化查询 If db.Sql("UPDATE users SET age = ?, email = ? WHERE id = ?") _ .Param("age", 26, adInteger) _ .Param("email", "newemail@example.com", adVarWChar) _ .Param("id", 1, adInteger) _ .ExecParam Then Debug.Print "更新成功" End If ``` ### 条件更新 ```vb ' 复杂条件更新 Dim sSql As String sSql = "UPDATE users SET status = 'inactive' " & _ "WHERE last_login < DATEADD(day, -30, GETDATE())" If db.Sql(sSql).Exec Then Debug.Print "过期用户已标记" End If ``` *** ## DELETE 操作 ### 基本删除 ```vb ' 删除单条记录 If db.Sql("DELETE FROM users WHERE id = 1").Exec Then Debug.Print "删除成功" End If ``` ### 批量删除 ```vb ' 删除多条记录 If db.Sql("DELETE FROM users WHERE age < 18").Exec Then Debug.Print "批量删除成功" End If ``` ### 使用参数化删除 ```vb ' 使用参数化查询 If db.Sql("DELETE FROM users WHERE id = ?") _ .Param("id", 1, adInteger) _ .ExecParam Then Debug.Print "删除成功" End If ``` ### 清空表 ```vb ' 清空表（注意：会删除所有数据） If db.Sql("DELETE FROM users").Exec Then Debug.Print "表已清空" End If ' 或者使用 TRUNCATE（更快，但不可回滚） If db.Sql("TRUNCATE TABLE users").Exec Then Debug.Print "表已清空" End If ``` *** ## 获取影响行数 ### RecordsAffected 参数 ```vb ' 获取受影响的行数 Dim lAffected As Long If db.Sql("UPDATE users SET status = 'active' WHERE age > 18").Exec(lAffected) Then Debug.Print "更新了 " & lAffected & " 条记录" End If ``` ### 示例 ```vb ' INSERT 操作 Dim lAffected As Long If db.Sql("INSERT INTO users (name) VALUES ('张三')").Exec(lAffected) Then Debug.Print "插入了 " & lAffected & " 条记录" End If ' UPDATE 操作 If db.Sql("UPDATE users SET status = 'active'").Exec(lAffected) Then Debug.Print "更新了 " & lAffected & " 条记录" End If ' DELETE 操作 If db.Sql("DELETE FROM users WHERE age < 18").Exec(lAffected) Then Debug.Print "删除了 " & lAffected & " 条记录" End If ``` *** ## 获取最后插入ID ### LastInsertId 方法 `LastInsertId` 方法获取最后插入的自增主键 ID。 #### 语法 ```vb Function LastInsertId() As Variant ``` #### 支持的数据库 * SQL Server - 使用 `SCOPE_IDENTITY()` * MySQL - 使用 `LAST_INSERT_ID()` * Access - 使用 `@@IDENTITY` #### 示例 ```vb ' 插入数据 If db.Sql("INSERT INTO users (name, age) VALUES ('张三', 25)").Exec Then ' 获取最后插入的 ID Dim lId As Variant lId = db.LastInsertId Debug.Print "新用户 ID: " & lId End If ``` ### 注意事项 1. **必须在 INSERT 后立即调用** ```vb ' ? 正确 db.Sql("INSERT INTO users (name) VALUES ('张三')").Exec Dim lId As Variant lId = db.LastInsertId ' ? 错误：中间有其他操作 db.Sql("INSERT INTO users (name) VALUES ('张三')").Exec db.Sql("SELECT * FROM users").Query ' 这会重置 ID Dim lId As Variant lId = db.LastInsertId ' 可能获取不到正确的 ID ``` 2. **仅支持自增主键** ```vb ' 表必须有自增主键 CREATE TABLE users ( id INT IDENTITY(1,1) PRIMARY KEY, -- SQL Server name NVARCHAR(50) ) ``` *** ## 批量操作 ### BatchInsert 方法 `BatchInsert` 方法批量插入数据，**内部自动使用事务保证数据一致性**。 #### 语法 ```vb Function BatchInsert(ByVal TableName As String, ByVal Data As Collection) As Boolean ``` #### 参数说明 | 参数 | 类型 | 说明 | | ----------- | ------------ | --------------------------------------- | | `TableName` | `String` | 表名（必需） | | `Data` | `Collection` | 数据集合，每个元素是 Dictionary（必需） | #### 示例 ```vb ' 准备数据 Dim colData As New Collection Dim dictRow As Dictionary ' 第一行 Set dictRow = New Dictionary dictRow.Add "name", "张三" dictRow.Add "age", 25 dictRow.Add "email", "zhangsan@example.com" colData.Add dictRow ' 第二行 Set dictRow = New Dictionary dictRow.Add "name", "李四" dictRow.Add "age", 30 dictRow.Add "email", "lisi@example.com" colData.Add dictRow ' 批量插入 If db.BatchInsert("users", colData) Then Debug.Print "批量插入成功" Else Debug.Print "批量插入失败: " & db.LastErr End If ``` ### 批量更新 ```vb ' 使用事务批量更新 db.TransBegin Dim i As Long For i = 1 To 100 Dim sSql As String sSql = "UPDATE users SET status = 'active' WHERE id = " & i If Not db.Sql(sSql).Exec Then db.TransRollback Exit For End If Next If db.TransCommit Then Debug.Print "批量更新成功" End If ``` *** ## 异步执行 ### Async 属性 使用 `Async` 属性可以异步执行 SQL 语句。**注意：异步执行仅对 `Exec` 方法有效**。 ```vb ' 异步执行 db.Sql("INSERT INTO users (name) VALUES ('张三')").Async.Exec ' 监听完成事件 Private Sub db_AsyncExecuteComplete(ByVal RecordsAffected As Long, _ ByVal pError As ADODB.Error, _ adStatus As ADODB.EventStatusEnum, _ ByVal pCommand As ADODB.Command, _ ByVal pRecordset As ADODB.Recordset, _ ByVal pConnection As ADODB.Connection) If pError Is Nothing Then Debug.Print "异步执行成功，影响行数: " & RecordsAffected Else Debug.Print "异步执行失败: " & pError.Description End If End Sub ``` *** ## 错误处理 ```vb ' 执行错误处理 If Not db.Sql("INSERT INTO users (name) VALUES ('张三')").Exec Then Debug.Print "执行失败" Debug.Print "错误代码: " & db.LastErrNumber Debug.Print "错误描述: " & db.LastErrDescription Debug.Print "完整信息: " & db.LastErr Exit Sub End If ``` *** ## 最佳实践 ### 1. 使用参数化查询 ```vb ' ? 推荐：使用参数化查询 db.Sql("INSERT INTO users (name, age) VALUES (?, ?)") _ .Param("name", txtName.Text, adVarWChar) _ .Param("age", CLng(txtAge.Text), adInteger) _ .ExecParam ' ? 不推荐：直接拼接 SQL（容易 SQL 注入） db.Sql("INSERT INTO users (name, age) VALUES ('" & txtName.Text & "', " & txtAge.Text & ")").Exec ``` ### 2. 使用事务保证一致性 ```vb ' ? 推荐：使用事务 db.TransBegin db.Sql("INSERT INTO users (name) VALUES ('张三')").Exec db.Sql("INSERT INTO posts (user_id, title) VALUES (1, '标题')").Exec If Not db.TransCommit Then Debug.Print "事务失败，已回滚" End If ``` ### 3. 检查返回值 ```vb ' ? 推荐：始终检查返回值 If db.Sql("INSERT INTO users (name) VALUES ('张三')").Exec Then ' 成功处理 Else ' 错误处理 End If ``` ### 4. 获取影响行数 ```vb ' ? 推荐：检查影响行数 Dim lAffected As Long If db.Sql("UPDATE users SET status = 'active'").Exec(lAffected) Then If lAffected > 0 Then Debug.Print "更新了 " & lAffected & " 条记录" Else Debug.Print "没有记录被更新" End If End If ``` *** **最后更新**: 2026-01-21 --- --- url: /zh/emoji/2500-257F.md --- # 制表符 (U+2500 - U+257F) 本节包含用于绘制表格和框线的字符，这些字符通常用于文本界面中创建表格、边框和其他图形元素。 | 字符 | Unicode | VB函数值 | 名称 | |:---:|:---:|:---:|:---| | ─ | U+2500 | ChrW(\&H2500) | 横线 | | ━ | U+2501 | ChrW(\&H2501) | 粗横线 | | │ | U+2502 | ChrW(\&H2502) | 竖线 | | ┃ | U+2503 | ChrW(\&H2503) | 粗竖线 | | ┄ | U+2504 | ChrW(\&H2504) | 虚横线 | | ┅ | U+2505 | ChrW(\&H2505) | 粗虚横线 | | ┆ | U+2506 | ChrW(\&H2506) | 虚竖线 | | ┇ | U+2507 | ChrW(\&H2507) | 粗虚竖线 | | ┈ | U+2508 | ChrW(\&H2508) | 密虚横线 | | ┉ | U+2509 | ChrW(\&H2509) | 粗密虚横线 | | ┊ | U+250A | ChrW(\&H250A) | 密虚竖线 | | ┋ | U+250B | ChrW(\&H250B) | 粗密虚竖线 | | ┌ | U+250C | ChrW(\&H250C) | 左上角 | | ┍ | U+250D | ChrW(\&H250D) | 左上角（粗上） | | ┎ | U+250E | ChrW(\&H250E) | 左上角（粗左） | | ┏ | U+250F | ChrW(\&H250F) | 左上角（粗） | | ┐ | U+2510 | ChrW(\&H2510) | 右上角 | | ┑ | U+2511 | ChrW(\&H2511) | 右上角（粗上） | | ┒ | U+2512 | ChrW(\&H2512) | 右上角（粗右） | | ┓ | U+2513 | ChrW(\&H2513) | 右上角（粗） | | └ | U+2514 | ChrW(\&H2514) | 左下角 | | ┕ | U+2515 | ChrW(\&H2515) | 左下角（粗下） | | ┖ | U+2516 | ChrW(\&H2516) | 左下角（粗左） | | ┗ | U+2517 | ChrW(\&H2517) | 左下角（粗） | | ┘ | U+2518 | ChrW(\&H2518) | 右下角 | | ┙ | U+2519 | ChrW(\&H2519) | 右下角（粗下） | | ┚ | U+251A | ChrW(\&H251A) | 右下角（粗右） | | ┛ | U+251B | ChrW(\&H251B) | 右下角（粗） | | ├ | U+251C | ChrW(\&H251C) | 左中连接 | | ┝ | U+251D | ChrW(\&H251D) | 左中连接（粗横） | | ┞ | U+251E | ChrW(\&H251E) | 左中连接（粗上） | | ┟ | U+251F | ChrW(\&H251F) | 左中连接（粗下） | | ┠ | U+2520 | ChrW(\&H2520) | 左中连接（粗左） | | ┡ | U+2521 | ChrW(\&H2521) | 左中连接（粗竖右） | | ┢ | U+2522 | ChrW(\&H2522) | 左中连接（粗竖左） | | ┣ | U+2523 | ChrW(\&H2523) | 左中连接（粗） | | ┤ | U+2524 | ChrW(\&H2524) | 右中连接 | | ┥ | U+2525 | ChrW(\&H2525) | 右中连接（粗横） | | ┦ | U+2526 | ChrW(\&H2526) | 右中连接（粗上） | | ┧ | U+2527 | ChrW(\&H2527) | 右中连接（粗下） | | ┨ | U+2528 | ChrW(\&H2528) | 右中连接（粗右） | | ┩ | U+2529 | ChrW(\&H2529) | 右中连接（粗竖右） | | ┪ | U+252A | ChrW(\&H252A) | 右中连接（粗竖左） | | ┫ | U+252B | ChrW(\&H252B) | 右中连接（粗） | --- --- url: /zh/CREDITS.md --- # 致谢 > 好的项目离不开前人优秀项目的启发和贡献，也离不开社区用户的支持与反馈。本页面汇总了 VB6 PRO 系列各项目的致谢信息。 ## 项目致谢 | 项目 | 描述 | | ------------------------------ | --------------------------------- | | [VBMAN 致谢](/vbman/CREDITS) | VBMAN 嵌入式 WEB 服务器和客户端库 | | [VBMAN2 致谢](/vbman2/CREDITS) | VBMAN2 WebView2 控件库 | ## 文章致谢 感谢以下文章站点对 VBMAN 的宣传与推荐： * **用VB6写Web后端?没错,这事真有人干成了!** — [微信公众号：左手EXCEL右手VBA](https://mp.weixin.qq.com/s/gv7NCNE4F8WLqQr3T5wCXw) *** 如果您对项目有任何贡献建议或发现需要感谢的人或项目，欢迎[联系我们](/CONTACT)。 --- --- url: /zh/vbman/CREDITS.md --- # VBMAN 致谢 感谢所有为 VBMAN 项目做出贡献的开发者和使用者。 ## 核心贡献者 * [@邓伟](https://a-vi.com) - 项目创建者、核心代码开发者 ## 贡献者 ## 特别感谢 ## 开源项目 感谢以下开源项目为 VBMAN 提供了灵感和基础： | 项目名称 | 许可证 | 用途 | | --------------------------------------------------------------- | ------ | ---------------------- | | [wqweto/VbAsyncSocket](https://github.com/wqweto/VbAsyncSocket) | MIT | 所有`socket`对象基于它 | | [wqweto/ZipArchive](https://github.com/wqweto/ZipArchive) | MIT | `cZipArchive`基于它 | | [Tim Hall/VBA-JSON](https://github.com/VBA-tools/VBA-JSON) | MIT | `cJson`对象后端使用它 | | [Jason Peter Brown/HttpMimeType](mailto://jason@bitspaces.com) | MIT | 使用了`HttpMimeType` | | [David Zimmer/cTimer](http://sandsprite.com) | / | `cTimer`对象来源于它 | ## 反馈与建议 感谢以下用户提供的问题反馈、功能建议和改进意见： * \[用户名/联系方式] - 反馈内容 *** 再次感谢所有支持 VBMAN 项目的朋友！ 如有任何贡献建议或发现需要感谢的人或项目，欢迎[联系我们](/CONTACT)。 [返回总致谢页](/CREDITS) --- --- url: /zh/vbman2/CREDITS.md --- # VBMAN2 致谢 感谢所有为 VBMAN2 项目做出贡献的开发者和使用者。 ## 核心贡献者 * [@邓伟](https://a-vi.com) - 项目创建者、核心代码开发者 ## 贡献者 ## 特别感谢 ## 开源项目 感谢以下开源项目为 VBMAN2 提供了灵感和基础： | 项目名称 | 许可证 | 用途 | | ---------------------------------------------------------------- | ------ | ------------------------ | | [twinBASIC WebView2Package](https://docs.twinbasic.com/WebView2) | MIT | 提供核心webview2基础能力 | ## 反馈与建议 感谢以下用户提供的问题反馈、功能建议和改进意见： * \[`周杰`/本群群友] - 提供了WEB页面任意元素绑定到VB6/VBA函数的建议 *** 再次感谢所有支持 VBMAN2 项目的朋友！ 如有任何贡献建议或发现需要感谢的人或项目，欢迎[联系我们](/CONTACT)。 [返回总致谢页](/CREDITS) --- --- url: /zh/vbman/httpserver/middleware.md --- # 中间件系统详解 ## 简介 中间件是 HttpServer 的请求/响应处理管道中的拦截器，可以在请求到达控制器之前和响应发送给客户端之后执行自定义逻辑。 ``` 请求流程: ┌─────────────┐ ┌─────────────┐ ┌─────────────┐ ┌─────────────┐ │ Request │ -> │ 前置 │ -> │ 控制器 │ -> │ 后置 │ -> Response │ 到达 │ │ 中间件 │ │ 处理 │ │ 中间件 │ └─────────────┘ └─────────────┘ └─────────────┘ └─────────────┘ ``` ## 中间件类型 | 类型 | 类 | 执行时机 | | ---------- | ------------------------ | ------------ | | 前置中间件 | `cHttpServerRouteBefore` | 路由匹配前 | | 后置中间件 | `cHttpServerRouterAfter` | 控制器处理后 | ## 前置中间件 (RouteBefore) ### 基本结构 ```vb ' cAuthMiddleware.cls Option Explicit Public Sub Entry(ctx As cHttpServerContext) ' 中间件逻辑 ' 终止后续处理 ' ctx.fIsAbort = True ' 跳过其他中间件 ' ctx.fIsSkipNextMiddleWare = True End Sub ``` ### 常用中间件示例 #### 1. 登录验证中间件 ```vb ' cAuthCheckMiddleware.cls Option Explicit Public Sub Entry(ctx As cHttpServerContext) ' 排除登录接口 If ctx.Request.PathInfo = "/login" Then Exit Sub If ctx.Request.PathInfo = "/register" Then Exit Sub ' 检查 Session If Not ctx.Session.Exists("user_id") Then ctx.Response.State401 "请先登录" ctx.fIsAbort = True ' 终止后续处理 End If End Sub ``` #### 2. IP 黑名单中间件 ```vb ' cIPBlacklistMiddleware.cls Option Explicit Dim Blacklist As Dictionary Private Sub Class_Initialize() Set Blacklist = New Dictionary Blacklist("192.168.1.100") = True Blacklist("10.0.0.50") = True End Sub Public Sub Entry(ctx As cHttpServerContext) Dim clientIP As String clientIP = ctx.ClientInfo.IP If Blacklist.Exists(clientIP) Then ctx.Response.State403 "您的IP已被封禁" ctx.fIsAbort = True End If End Sub ``` #### 3. 请求日志中间件 ```vb ' cRequestLogMiddleware.cls Option Explicit Public Sub Entry(ctx As cHttpServerContext) Dim log As String log = Now & " " & _ ctx.ClientInfo.IP & " " & _ ctx.Request.MethodName & " " & _ ctx.Request.PathInfo ' 写入日志文件 Call WriteLog(log) ' 在上下文中记录开始时间（用于计算响应时间） ctx.fStartTime = Timer End Sub Private Sub WriteLog(msg As String) Dim f As Integer f = FreeFile Open "C:\Logs\access.log" For Append As #f Print #f, msg Close #f End Sub ``` #### 4. CORS 预检处理 ```vb ' cCorsMiddleware.cls Option Explicit Public Sub Entry(ctx As cHttpServerContext) ' 处理 OPTIONS 预检请求 If ctx.Request.Method = ReqOptions Then ctx.Response.Header("Access-Control-Allow-Origin") = "*" ctx.Response.Header("Access-Control-Allow-Methods") = "GET, POST, PUT, DELETE, OPTIONS" ctx.Response.Header("Access-Control-Allow-Headers") = "Content-Type, Authorization" ctx.Response.Text "" ctx.fIsAbort = True End If End Sub ``` #### 5. 请求频率限制 ```vb ' cRateLimitMiddleware.cls Option Explicit Dim RequestCounts As Dictionary Dim LastReset As Date Private Sub Class_Initialize() Set RequestCounts = New Dictionary LastReset = Now End Sub Public Sub Entry(ctx As cHttpServerContext) ' 每分钟重置计数 If DateDiff("n", LastReset, Now) >= 1 Then Set RequestCounts = New Dictionary LastReset = Now End If Dim clientIP As String clientIP = ctx.ClientInfo.IP ' 统计请求次数 If Not RequestCounts.Exists(clientIP) Then RequestCounts(clientIP) = 0 End If RequestCounts(clientIP) = RequestCounts(clientIP) + 1 ' 限制每分钟 100 次 If RequestCounts(clientIP) > 100 Then ctx.Response.State429 "请求过于频繁，请稍后再试" ctx.fIsAbort = True End If End Sub ``` ### 中间件注册与优先级 ```vb Private Sub Form_Load() Set Server = New cHttpServer ' 注册中间件（按优先级顺序） Call Server.RouteBefore.Add("cors", New cCorsMiddleware) ' 第1个执行 Call Server.RouteBefore.Add("ratelimit", New cRateLimitMiddleware) ' 第2个执行 Call Server.RouteBefore.Add("ipblacklist", New cIPBlacklistMiddleware) ' 第3个执行 Call Server.RouteBefore.Add("requestlog", New cRequestLogMiddleware) ' 第4个执行 Call Server.RouteBefore.Add("authcheck", New cAuthCheckMiddleware) ' 第5个执行 ' 注册控制器 Call Server.Router.Reg("Api", New cApiController) Call Server.Router.Add("/api/data", "Api@Data") Call Server.Start(8080) End Sub ``` ### 上下文控制标志 | 标志 | 说明 | | --------------------------- | -------------------------- | | `ctx.fIsAbort` | 设为 True 终止整个请求处理 | | `ctx.fIsSkipNextMiddleWare` | 设为 True 跳过后续中间件 | ## 后置中间件 (RouteAfter) 后置中间件用于响应发送后的处理（当前版本为预留接口）。 ```vb ' cResponseLogMiddleware.cls Option Explicit Public Sub Entry(ctx As cHttpServerContext) ' 计算响应时间 If ctx.fStartTime > 0 Then Dim elapsed As Double elapsed = Timer - ctx.fStartTime ' 记录慢请求 If elapsed > 1 Then Call WriteSlowLog(ctx.Request.PathInfo & " 耗时 " & elapsed & " 秒") End If End If End Sub ``` ## 上下文扩展 可以在上下文中添加自定义属性供中间件和控制器共享： ```vb ' cHttpServerContext 扩展模块 ' 在 MiddleWare 中设置 Public Sub AuthMiddleware(ctx As cHttpServerContext) If IsValidToken Then ctx.fUserId = GetUserIdFromToken() ctx.fUserRole = GetUserRole() End If End Sub ' 在控制器中使用 Public Sub GetData(ctx As cHttpServerContext) ' 获取中间件设置的信息 Dim userId As String userId = ctx.fUserId ' 根据角色返回不同数据 If ctx.fUserRole = "admin" Then ' 返回所有数据 Else ' 返回部分数据 End If End Sub ``` ## 中间件链执行顺序 ``` 请求: GET /api/users 1. cCorsMiddleware -> 通过 2. cRateLimitMiddleware -> 通过 3. cIPBlacklistMiddleware -> 通过 4. cRequestLogMiddleware -> 通过 5. cAuthCheckMiddleware -> 检查 Session └─> 未登录 -> ctx.fIsAbort = True 请求被终止，返回 401 ``` *** **最后更新**: 2026-05-17 --- --- url: /zh/packages/vbccr/bars/statusbar.md description: 状态栏控件（StatusBar） - VBCCR 开发手册，基于源码的完整 API 参考 --- # 状态栏控件（StatusBar） 提供可自定义的状态栏，支持面板集合、简单/正常模式、大小调整手柄和OLE拖放。不可获得焦点。 ## 枚举 ### SbrStyleConstants 状态栏样式常量。 | 常量 | 值 | 说明 | |------|-----|------| | SbrStyleNormal | 0 | 正常模式（显示面板） | | SbrStyleSimple | 1 | 简单模式（仅显示SimpleText） | ### SbrPanelStyleConstants 面板样式常量。 | 常量 | 值 | 说明 | |------|-----|------| | SbrPanelStyleText | 0 | 文本面板 | | SbrPanelStyleCaps | 1 | Caps Lock状态 | | SbrPanelStyleNum | 2 | Num Lock状态 | | SbrPanelStyleIns | 3 | Insert状态 | | SbrPanelStyleScrl | 4 | Scroll Lock状态 | | SbrPanelStyleTime | 5 | 时间 | | SbrPanelStyleDate | 6 | 日期 | | SbrPanelStyleKana | 7 | Kana状态 | | SbrPanelStyleHangul | 8 | Hangul状态 | | SbrPanelStyleJunja | 9 | Junja状态 | | SbrPanelStyleFinal | 10 | Final状态 | | SbrPanelStyleKanji | 11 | Kanji状态 | | SbrPanelStyleHanja | 12 | Hanja状态 | ### SbrPanelBevelConstants 面板斜面样式常量。 | 常量 | 值 | 说明 | |------|-----|------| | SbrPanelBevelFlat | 0 | 平面 | | SbrPanelBevelInset | 1 | 内凹 | | SbrPanelBevelRaised | 2 | 凸起 | ### SbrPanelAutoSizeConstants 面板自动调整大小常量。 | 常量 | 值 | 说明 | |------|-----|------| | SbrPanelAutoSizeNone | 0 | 不自动调整 | | SbrPanelAutoSizeSpring | 1 | 弹性调整（填充剩余空间） | | SbrPanelAutoSizeContent | 2 | 根据内容调整 | ### SbrPanelAlignmentConstants 面板对齐方式常量。 | 常量 | 值 | 说明 | |------|-----|------| | SbrPanelAlignmentLeft | 0 | 左对齐 | | SbrPanelAlignmentCenter | 1 | 居中对齐 | | SbrPanelAlignmentRight | 2 | 右对齐 | | SbrPanelAlignmentLeftRight | 3 | 从左到右对齐（RTL支持） | ### SbrPanelDTFormatConstants 面板日期时间格式常量。 | 常量 | 值 | 说明 | |------|-----|------| | SbrPanelDTFormatShort | 0 | 短格式 | | SbrPanelDTFormatLong | 1 | 长格式 | ## 属性 ### Name ```vb Public Property Get Name() As String ``` 返回在代码中标识对象的名称。 ### Tag ```vb Public Property Get Tag() As String Public Property Let Tag(ByVal Value As String) ``` 存储程序所需的额外数据。 ### Parent ```vb Public Property Get Parent() As Object ``` 返回对象所在的对象。 ### Container ```vb Public Property Get Container() As Object Public Property Set Container(ByVal Value As Object) ``` 返回/设置对象的容器。 ### Left ```vb Public Property Get Left() As Single Public Property Let Left(ByVal Value As Single) ``` 返回/设置对象与其容器左边缘的距离。 ### Top ```vb Public Property Get Top() As Single Public Property Let Top(ByVal Value As Single) ``` 返回/设置对象与其容器顶边缘的距离。 ### Width ```vb Public Property Get Width() As Single Public Property Let Width(ByVal Value As Single) ``` 返回/设置对象的宽度。 ### Height ```vb Public Property Get Height() As Single Public Property Let Height(ByVal Value As Single) ``` 返回/设置对象的高度。 ### Visible ```vb Public Property Get Visible() As Boolean Public Property Let Visible(ByVal Value As Boolean) ``` 返回/设置对象是否可见。 ### ToolTipText ```vb Public Property Get ToolTipText() As String Public Property Let ToolTipText(ByVal Value As String) ``` 返回/设置鼠标悬停时显示的提示文本。 ### WhatsThisHelpID ```vb Public Property Get WhatsThisHelpID() As Long Public Property Let WhatsThisHelpID(ByVal Value As Long) ``` 返回/设置关联的上下文帮助ID。 ### Align ```vb Public Property Get Align() As Integer Public Property Let Align(ByVal Value As Integer) ``` 返回/设置控件在其窗体上的对齐方式。 ### DragIcon ```vb Public Property Get DragIcon() As IPictureDisp Public Property Let DragIcon(ByVal Value As IPictureDisp) Public Property Set DragIcon(ByVal Value As IPictureDisp) ``` 返回/设置拖放操作中显示的图标。 ### DragMode ```vb Public Property Get DragMode() As Integer Public Property Let DragMode(ByVal Value As Integer) ``` 返回/设置拖动模式。 ### hWnd ```vb Public Property Get hWnd() As LongPtr ``` 返回控件句柄。 ### hWndUserControl ```vb Public Property Get hWndUserControl() As LongPtr ``` 返回UserControl句柄。 ### Font ```vb Public Property Get Font() As StdFont Public Property Let Font(ByVal NewFont As StdFont) Public Property Set Font(ByVal NewFont As StdFont) ``` 返回/设置字体。 ### VisualStyles ```vb Public Property Get VisualStyles() As Boolean Public Property Let VisualStyles(ByVal Value As Boolean) ``` 返回/设置是否启用视觉样式。需要comctl32.dll 6.0或更高版本。 ### Enabled ```vb Public Property Get Enabled() As Boolean Public Property Let Enabled(ByVal Value As Boolean) ``` 返回/设置对象是否能响应用户事件。 ### OLEDropMode ```vb Public Property Get OLEDropMode() As OLEDropModeConstants Public Property Let OLEDropMode(ByVal Value As OLEDropModeConstants) ``` 返回/设置对象是否可以作为OLE放置目标。 ### MousePointer ```vb Public Property Get MousePointer() As CCMousePointerConstants Public Property Let MousePointer(ByVal Value As CCMousePointerConstants) ``` 返回/设置鼠标悬停时显示的指针类型。参见通用枚举。 ### MouseIcon ```vb Public Property Get MouseIcon() As IPictureDisp Public Property Let MouseIcon(ByVal Value As IPictureDisp) Public Property Set MouseIcon(ByVal Value As IPictureDisp) ``` 返回/设置自定义鼠标图标。 ### MouseTrack ```vb Public Property Get MouseTrack() As Boolean Public Property Let MouseTrack(ByVal Value As Boolean) ``` 返回/设置是否在鼠标进入或离开控件时触发事件。 ### RightToLeft ```vb Public Property Get RightToLeft() As Boolean Public Property Let RightToLeft(ByVal Value As Boolean) ``` 返回/设置从右到左显示方向。 ### RightToLeftLayout ```vb Public Property Get RightToLeftLayout() As Boolean Public Property Let RightToLeftLayout(ByVal Value As Boolean) ``` 返回/设置从右到左布局。 ### RightToLeftMode ```vb Public Property Get RightToLeftMode() As CCRightToLeftModeConstants Public Property Let RightToLeftMode(ByVal Value As CCRightToLeftModeConstants) ``` 返回/设置从右到左模式。参见通用枚举。 ### Style ```vb Public Property Get Style() As SbrStyleConstants Public Property Let Style(ByVal Value As SbrStyleConstants) ``` 返回/设置状态栏样式。 ### SimpleText ```vb Public Property Get SimpleText() As String Public Property Let SimpleText(ByVal Value As String) ``` 返回/设置简单模式下显示的文本。 ### AllowSizeGrip ```vb Public Property Get AllowSizeGrip() As Boolean Public Property Let AllowSizeGrip(ByVal Value As Boolean) ``` 返回/设置是否显示大小调整手柄。 ### ShowTips ```vb Public Property Get ShowTips() As Boolean Public Property Let ShowTips(ByVal Value As Boolean) ``` 返回/设置是否显示工具提示。 ### BackColor ```vb Public Property Get BackColor() As OLE_COLOR Public Property Let BackColor(ByVal Value As OLE_COLOR) ``` 返回/设置背景色。 ### DoubleBuffer ```vb Public Property Get DoubleBuffer() As Boolean Public Property Let DoubleBuffer(ByVal Value As Boolean) ``` 返回/设置是否启用双缓冲绘制。 ### Panels ```vb Public Property Get Panels() As SbrPanels ``` 返回面板集合。 ## 方法 ### Refresh ```vb Public Sub Refresh() ``` 强制完全重绘对象。 ### IncludesSizeGrip ```vb Public Function IncludesSizeGrip() As Boolean ``` 判断状态栏是否包含大小调整手柄。 ### HitTest ```vb Public Function HitTest(ByVal X As Single, ByVal Y As Single) As SbrPanel ``` 返回指定坐标处的面板。 ### OLEDrag ```vb Public Sub OLEDrag() ``` 启动OLE拖放操作。 ### Drag ```vb Public Sub Drag(Optional ByRef Action As Variant) ``` 开始、结束或取消拖动操作。 ### ZOrder ```vb Public Sub ZOrder(Optional ByRef Position As Variant) ``` 设置Z顺序。 ## 事件 ### Click ```vb Public Event Click() ``` 用户单击控件时触发。 ### DblClick ```vb Public Event DblClick() ``` 用户双击控件时触发。 ### StyleChange ```vb Public Event StyleChange() ``` 状态栏样式改变时触发。 ### PanelClick ```vb Public Event PanelClick(ByVal Panel As SbrPanel, ByVal Button As Integer) ``` 用户单击面板时触发。 ### PanelDblClick ```vb Public Event PanelDblClick(ByVal Panel As SbrPanel, ByVal Button As Integer) ``` 用户双击面板时触发。 ### MouseDown ```vb Public Event MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` 按下鼠标按钮时触发。 ### MouseMove ```vb Public Event MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` 移动鼠标时触发。 ### MouseUp ```vb Public Event MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` 释放鼠标按钮时触发。 ### MouseEnter ```vb Public Event MouseEnter() ``` 鼠标进入控件区域时触发。 ### MouseLeave ```vb Public Event MouseLeave() ``` 鼠标离开控件区域时触发。 ### OLECompleteDrag ```vb Public Event OLECompleteDrag(Effect As Long) ``` OLE拖放操作完成时触发。 ### OLEDragDrop ```vb Public Event OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single) ``` OLE拖放操作放置时触发。 ### OLEDragOver ```vb Public Event OLEDragOver(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single, State As Integer) ``` OLE拖放操作悬停时触发。 ### OLEGiveFeedback ```vb Public Event OLEGiveFeedback(Effect As Long, DefaultCursors As Boolean) ``` OLE拖放操作给反馈时触发。 ### OLESetData ```vb Public Event OLESetData(Data As DataObject, DataFormat As Integer) ``` OLE拖放操作设置数据时触发。 ### OLEStartDrag ```vb Public Event OLEStartDrag(Data As DataObject, AllowedEffects As Long) ``` OLE拖放操作开始时触发。 ## 子对象 ### SbrPanel 类 状态栏面板对象。 #### SbrPanel 属性 #### Index ```vb Public Property Get Index() As Long ``` 面板在集合中的索引。 #### Key ```vb Public Property Get Key() As String Public Property Let Key(ByVal Value As String) ``` 面板的唯一标识键。 #### Tag ```vb Public Property Get Tag() As Variant Public Property Let Tag(ByVal Value As Variant) Public Property Set Tag(ByVal Value As Variant) ``` 额外数据。 #### Text ```vb Public Property Get Text() As String Public Property Let Text(ByVal Value As String) ``` 面板文本。 #### ToolTipText ```vb Public Property Get ToolTipText() As String Public Property Let ToolTipText(ByVal Value As String) ``` 工具提示文本。 #### Style ```vb Public Property Get Style() As SbrPanelStyleConstants Public Property Let Style(ByVal Value As SbrPanelStyleConstants) ``` 面板样式。 #### Bevel ```vb Public Property Get Bevel() As SbrPanelBevelConstants Public Property Let Bevel(ByVal Value As SbrPanelBevelConstants) ``` 面板斜面样式。 #### AutoSize ```vb Public Property Get AutoSize() As SbrPanelAutoSizeConstants Public Property Let AutoSize(ByVal Value As SbrPanelAutoSizeConstants) ``` 面板自动调整大小方式。 #### Alignment ```vb Public Property Get Alignment() As SbrPanelAlignmentConstants Public Property Let Alignment(ByVal Value As SbrPanelAlignmentConstants) ``` 面板对齐方式。 #### DTFormat ```vb Public Property Get DTFormat() As SbrPanelDTFormatConstants Public Property Let DTFormat(ByVal Value As SbrPanelDTFormatConstants) ``` 面板日期时间格式。 #### ForeColor ```vb Public Property Get ForeColor() As OLE_COLOR Public Property Let ForeColor(ByVal Value As OLE_COLOR) ``` 前景色。 #### MinWidth ```vb Public Property Get MinWidth() As Single Public Property Let MinWidth(ByVal Value As Single) ``` 最小宽度。 #### Picture ```vb Public Property Get Picture() As IPictureDisp Public Property Let Picture(ByVal Value As IPictureDisp) Public Property Set Picture(ByVal Value As IPictureDisp) ``` 面板图片。 #### Enabled ```vb Public Property Get Enabled() As Boolean Public Property Let Enabled(ByVal Value As Boolean) ``` 是否可用。 #### Visible ```vb Public Property Get Visible() As Boolean Public Property Let Visible(ByVal Value As Boolean) ``` 是否可见。 #### Bold ```vb Public Property Get Bold() As Boolean Public Property Let Bold(ByVal Value As Boolean) ``` 是否以粗体显示文本。 #### PictureOnRight ```vb Public Property Get PictureOnRight() As Boolean Public Property Let PictureOnRight(ByVal Value As Boolean) ``` 图片是否显示在右侧。 #### Left ```vb Public Property Get Left() As Single ``` 面板左边距（只读）。 #### Width ```vb Public Property Get Width() As Single Public Property Let Width(ByVal Value As Single) ``` 面板宽度。 ### SbrPanels 类 状态栏面板集合。 #### SbrPanels 成员 #### NewEnum ```vb Public Function NewEnum() As IEnumVARIANT ``` 枚举器（隐藏）。 #### Add ```vb Public Function Add(Optional ByVal Index As Long, Optional ByVal Key As String, Optional ByVal Text As String, Optional ByVal Style As SbrPanelStyleConstants) As SbrPanel ``` 添加面板。 #### Item ```vb Public Property Get Item(ByVal Index As Variant) As SbrPanel ``` 获取面板（默认成员）。 #### Exists ```vb Public Function Exists(ByVal Index As Variant) As Boolean ``` 检查面板是否存在。 #### Count ```vb Public Property Get Count() As Long ``` 面板数量。 #### Clear ```vb Public Sub Clear() ``` 清除所有面板。 #### Remove ```vb Public Sub Remove(ByVal Index As Variant) ``` 移除面板。 ### SbrPanelProperties 类 面板内部属性对象。 #### SbrPanelProperties 属性 #### ForeColor ```vb Public Property Get ForeColor() As OLE_COLOR Public Property Let ForeColor(ByVal Value As OLE_COLOR) ``` 前景色。 ## 代码示例 ### 基本用法 ```vb ' 添加状态栏面板 With StatusBar1.Panels .Add , "Status", "就绪", sbrText .Add , "Caps", , sbrCaps .Add , "Time", , sbrTime End With ' 自定义面板样式 With StatusBar1.Panels(1) .AutoSize = sbrSpring .Bevel = sbrInset End With ' 切换到简单模式 StatusBar1.Style = sbrSimple StatusBar1.SimpleText = "正在加载数据..." ' 处理面板点击 Private Sub StatusBar1_PanelClick(ByVal Panel As SbrPanel, ByVal Button As Integer) Debug.Print "点击面板: " & Panel.Key End Sub ``` --- --- url: /zh/emoji/2100-214F.md --- # 字母式符号 (Letterlike Symbols) 本页面展示了Unicode字符集中，位于U+2100到U+214F范围的字母式符号。这些符号包括各种特殊的字母形式和计量单位符号。 | 字符 | Unicode | VB函数值 | 名称 | |:---:|:---:|:---:|:---| | ℀ | U+2100 | ChrW(\&H2100) | 账户符号 | | ℁ | U+2101 | ChrW(\&H2101) | 地址符号 | | ℂ | U+2102 | ChrW(\&H2102) | 复数集合符号 | | ℃ | U+2103 | ChrW(\&H2103) | 摄氏度符号 | | ℄ | U+2104 | ChrW(\&H2104) | 中线符号 | | ℅ | U+2105 | ChrW(\&H2105) | 照顾符号 | | ℆ | U+2106 | ChrW(\&H2106) | 每一符号 | | ℇ | U+2107 | ChrW(\&H2107) | 欧拉常数符号 | | ℈ | U+2108 | ChrW(\&H2108) | 舍费尔符号 | | ℉ | U+2109 | ChrW(\&H2109) | 华氏度符号 | | ℊ | U+210A | ChrW(\&H210A) | 小写g函数符号 | | ℋ | U+210B | ChrW(\&H210B) | 黑板体大写H | | ℌ | U+210C | ChrW(\&H210C) | 黑板体大写H变体 | | ℍ | U+210D | ChrW(\&H210D) | 黑板体大写H实数 | | ℎ | U+210E | ChrW(\&H210E) | 普朗克常数符号 | | ℏ | U+210F | ChrW(\&H210F) | 约化普朗克常数符号 | | ℐ | U+2110 | ChrW(\&H2110) | 黑板体大写I | | ℑ | U+2111 | ChrW(\&H2111) | 黑板体大写I虚数 | | ℒ | U+2112 | ChrW(\&H2112) | 拉普拉斯变换符号 | | ℓ | U+2113 | ChrW(\&H2113) | 小写l符号 | | ℔ | U+2114 | ChrW(\&H2114) | 镑符号 | | ℕ | U+2115 | ChrW(\&H2115) | 自然数集合符号 | | № | U+2116 | ChrW(\&H2116) | 编号符号 | | ℗ | U+2117 | ChrW(\&H2117) | 录音版权符号 | | ℘ | U+2118 | ChrW(\&H2118) | 威尔斯特拉斯p符号 | | ℙ | U+2119 | ChrW(\&H2119) | 黑板体大写P | | ℚ | U+211A | ChrW(\&H211A) | 有理数集合符号 | | ℛ | U+211B | ChrW(\&H211B) | 黑板体大写R | | ℜ | U+211C | ChrW(\&H211C) | 黑板体大写R实数 | | ℝ | U+211D | ChrW(\&H211D) | 实数集合符号 | | ℞ | U+211E | ChrW(\&H211E) | 处方符号 | | ℟ | U+211F | ChrW(\&H211F) | 响应符号 | | ℠ | U+2120 | ChrW(\&H2120) | 服务标记符号 | | ℡ | U+2121 | ChrW(\&H2121) | 电话符号 | | ™ | U+2122 | ChrW(\&H2122) | 商标符号 | | ℣ | U+2123 | ChrW(\&H2123) | 节符号 | | ℤ | U+2124 | ChrW(\&H2124) | 整数集合符号 | | ℥ | U+2125 | ChrW(\&H2125) | 盎司符号 | | Ω | U+2126 | ChrW(\&H2126) | 欧姆符号 | | ℧ | U+2127 | ChrW(\&H2127) | 倒欧姆符号 | | ℨ | U+2128 | ChrW(\&H2128) | 黑板体大写Z | | ℩ | U+2129 | ChrW(\&H2129) | 转置符号 | | K | U+212A | ChrW(\&H212A) | 开尔文符号 | | Å | U+212B | ChrW(\&H212B) | 埃米符号 | | ℬ | U+212C | ChrW(\&H212C) | 黑板体大写B | | ℭ | U+212D | ChrW(\&H212D) | 黑板体大写C | | ℮ | U+212E | ChrW(\&H212E) | 估计符号 | | ℯ | U+212F | ChrW(\&H212F) | 小写e符号 | | ℰ | U+2130 | ChrW(\&H2130) | 黑板体大写E | | ℱ | U+2131 | ChrW(\&H2131) | 黑板体大写F | | Ⅎ | U+2132 | ChrW(\&H2132) | 倒F符号 | | ℳ | U+2133 | ChrW(\&H2133) | 黑板体大写M | | ℴ | U+2134 | ChrW(\&H2134) | 小写o符号 | | ℵ | U+2135 | ChrW(\&H2135) | 阿列夫符号 | | ℶ | U+2136 | ChrW(\&H2136) | 贝特符号 | | ℷ | U+2137 | ChrW(\&H2137) | 吉梅尔符号 | | ℸ | U+2138 | ChrW(\&H2138) | 达列特符号 | | ℹ | U+2139 | ChrW(\&H2139) | 信息源符号 | | ℺ | U+213A | ChrW(\&H213A) | 旋转的Q符号 | | ℻ | U+213B | ChrW(\&H213B) | 传真符号 | | ℼ | U+213C | ChrW(\&H213C) | 双击pi符号 | | ℽ | U+213D | ChrW(\&H213D) | 双击gamma符号 | | ℾ | U+213E | ChrW(\&H213E) | 双击大写Gamma符号 | | ℿ | U+213F | ChrW(\&H213F) | 双击大写Pi符号 | | ⅀ | U+2140 | ChrW(\&H2140) | 双击求和符号 | | ⅁ | U+2141 | ChrW(\&H2141) | 倒G符号 | | ⅂ | U+2142 | ChrW(\&H2142) | 倒L符号 | | ⅃ | U+2143 | ChrW(\&H2143) | 反转L符号 | | ⅄ | U+2144 | ChrW(\&H2144) | 倒Y符号 | | ⅅ | U+2145 | ChrW(\&H2145) | 黑板体大写D | | ⅆ | U+2146 | ChrW(\&H2146) | 黑板体小写d | | ⅇ | U+2147 | ChrW(\&H2147) | 黑板体小写e | | ⅈ | U+2148 | ChrW(\&H2148) | 黑板体小写i | | ⅉ | U+2149 | ChrW(\&H2149) | 黑板体小写j | | ⅊ | U+214A | ChrW(\&H214A) | 资产符号 | | ⅋ | U+214B | ChrW(\&H214B) | 双叉号 | | ⅌ | U+214C | ChrW(\&H214C) | 每英寸符号 | | ⅍ | U+214D | ChrW(\&H214D) | 标量积符号 | | ⅎ | U+214E | ChrW(\&H214E) | 倒小写F | | ⅏ | U+214F | ChrW(\&H214F) | 符号FOR | --- --- url: /zh/packages/vbccr/lists/fontcombo.md description: 字体组合框控件（FontCombo） - VBCCR 开发手册，基于源码的完整 API 参考 --- # 字体组合框控件（FontCombo） 提供带最近使用列表的字体选择组合框控件，可枚举系统字体并按类型和间距过滤。 ## 枚举 ### FtcStyleConstants | 常量 | 值 | 说明 | |------|-----|------| | FtcStyleDropDownCombo | 0 | 下拉组合框（可输入） | | FtcStyleSimpleCombo | 1 | 简单组合框（列表始终可见） | | FtcStyleDropDownList | 2 | 下拉列表（仅选择） | ### FtcFontTypeConstants | 常量 | 值 | 说明 | |------|-----|------| | FtcFontTypeTrueType | 0 | 仅 TrueType 字体 | | FtcFontTypeBitmap | 1 | 仅位图字体 | | FtcFontTypeBitmapTrueType | 2 | 位图和 TrueType 字体 | ### FtcFontPitchConstants | 常量 | 值 | 说明 | |------|-----|------| | FtcFontPitchAll | 0 | 所有间距 | | FtcFontPitchFixed | 1 | 固定间距 | | FtcFontPitchVariable | 2 | 可变间距 | ## 属性 ### Name ```vb Property Get Name() As String ``` 返回控件的名称。 ### Tag ```vb Property Get/Let Tag() As String ``` 返回/设置控件的标记值。 ### Parent ```vb Property Get Parent() As Object ``` 返回控件的父对象。 ### Container ```vb Property Get/Set Container() As Object ``` 返回/设置控件的容器。 ### Left ```vb Property Get/Let Left() As Single ``` 返回/设置控件左边缘的位置。 ### Top ```vb Property Get/Let Top() As Single ``` 返回/设置控件上边缘的位置。 ### Width ```vb Property Get/Let Width() As Single ``` 返回/设置控件的宽度。 ### Height ```vb Property Get/Let Height() As Single ``` 返回/设置控件的高度。 ### Visible ```vb Property Get/Let Visible() As Boolean ``` 返回/设置控件是否可见。 ### ToolTipText ```vb Property Get/Let ToolTipText() As String ``` 返回/设置控件的工具提示文本。 ### HelpContextID ```vb Property Get/Let HelpContextID() As Long ``` 返回/设置控件的帮助上下文 ID。 ### WhatsThisHelpID ```vb Property Get/Let WhatsThisHelpID() As Long ``` 返回/设置控件的"这是什么"帮助 ID。 ### DragIcon ```vb Property Get/Let/Set DragIcon() As IPictureDisp ``` 返回/设置拖动操作时显示的图标。 ### DragMode ```vb Property Get/Let DragMode() As Integer ``` 返回/设置拖动模式（手动或自动）。 ### hWnd ```vb Property Get hWnd() As LongPtr ``` 返回组合框的窗口句柄。 ### hWndUserControl ```vb Property Get hWndUserControl() As LongPtr ``` 返回 UserControl 的窗口句柄。 ### hWndEdit ```vb Property Get hWndEdit() As LongPtr ``` 返回编辑框部分的窗口句柄。 ### hWndList ```vb Property Get hWndList() As LongPtr ``` 返回列表部分的窗口句柄。 ### Font ```vb Property Get/Let/Set Font() As StdFont ``` 返回/设置控件使用的字体。 ### VisualStyles ```vb Property Get/Let VisualStyles() As Boolean ``` 返回/设置是否启用视觉样式。 ### BackColor ```vb Property Get/Let BackColor() As OLE_COLOR ``` 返回/设置控件的背景色。 ### ForeColor ```vb Property Get/Let ForeColor() As OLE_COLOR ``` 返回/设置控件的前景色。 ### Enabled ```vb Property Get/Let Enabled() As Boolean ``` 返回/设置控件是否可用。 ### OLEDragMode ```vb Property Get/Let OLEDragMode() As VBRUN.OLEDragConstants ``` 返回/设置 OLE 拖动模式。 ### OLEDropMode ```vb Property Get/Let OLEDropMode() As OLEDropModeConstants ``` 返回/设置 OLE 放置模式。参见通用枚举。 ### MousePointer ```vb Property Get/Let MousePointer() As CCMousePointerConstants ``` 返回/设置鼠标指针类型。参见通用枚举。 ### MouseIcon ```vb Property Get/Let/Set MouseIcon() As IPictureDisp ``` 返回/设置自定义鼠标图标。 ### MouseTrack ```vb Property Get/Let MouseTrack() As Boolean ``` 返回/设置是否启用鼠标进入/离开跟踪。 ### RightToLeft ```vb Property Get/Let RightToLeft() As Boolean ``` 返回/设置是否启用从右到左布局。 ### RightToLeftMode ```vb Property Get/Let RightToLeftMode() As CCRightToLeftModeConstants ``` 返回/设置从右到左模式。参见通用枚举。 ### BuddyControl ```vb Property Get/Set/Let BuddyControl() As Variant ``` 返回/设置关联的伙伴控件，当选择字体时通知伙伴控件更新。 ### Style ```vb Property Get/Let Style() As FtcStyleConstants ``` 返回/设置组合框的样式。 ### FontType ```vb Property Get/Let FontType() As FtcFontTypeConstants ``` 返回/设置显示的字体类型过滤。 ### FontPitch ```vb Property Get/Let FontPitch() As FtcFontPitchConstants ``` 返回/设置显示的字体间距过滤。 ### Locked ```vb Property Get/Let Locked() As Boolean ``` 返回/设置控件是否锁定（禁止编辑和选择）。 ### Text ```vb Property Get/Let Text() As String ``` 返回/设置编辑框中的文本。 ### Default ```vb Property Get/Let Default() As String ``` 返回/设置默认字体名称。 ### ExtendedUI ```vb Property Get/Let ExtendedUI() As Boolean ``` 返回/设置是否使用扩展用户界面。 ### MaxDropDownItems ```vb Property Get/Let MaxDropDownItems() As Integer ``` 返回/设置下拉列表中可见的最大项目数。 ### IntegralHeight ```vb Property Get/Let IntegralHeight() As Boolean ``` 返回/设置是否只显示完整项目（不截断部分项目）。 ### MaxLength ```vb Property Get/Let MaxLength() As Long ``` 返回/设置编辑框中可输入的最大字符数。 ### HorizontalExtent ```vb Property Get/Let HorizontalExtent() As Single ``` 返回/设置列表的水平滚动宽度。 ### IMEMode ```vb Property Get/Let IMEMode() As CCIMEModeConstants ``` 返回/设置输入法编辑器模式。参见通用枚举。 ### ScrollTrack ```vb Property Get/Let ScrollTrack() As Boolean ``` 返回/设置滚动条是否实时跟踪。 ### AutoSelect ```vb Property Get/Let AutoSelect() As Boolean ``` 返回/设置获得焦点时是否自动选中编辑框文本。 ### AlwaysFindExact ```vb Property Get/Let AlwaysFindExact() As Boolean ``` 返回/设置是否始终精确查找匹配项。 ### RecentMax ```vb Property Get/Let RecentMax() As Integer ``` 返回/设置最近使用列表的最大项目数（0-9），0 表示不显示最近列表。 ### RecentBackColor ```vb Property Get/Let RecentBackColor() As OLE_COLOR ``` 返回/设置最近使用列表的背景色。 ### RecentForeColor ```vb Property Get/Let RecentForeColor() As OLE_COLOR ``` 返回/设置最近使用列表的前景色。 ### RecentCount ```vb Property Get RecentCount() As Long ``` 返回最近使用列表中的项目数。只读。 ### ListCount ```vb Property Get ListCount() As Long ``` 返回列表中的项目总数。只读。 ### List ```vb Property Get List(ByVal Index As Long) As String ``` 返回指定索引处的列表项文本。只读。 ### ListIndex ```vb Property Get/Let ListIndex() As Long ``` 返回/设置当前选中项的索引。 ### ItemData ```vb Property Get/Let ItemData(ByVal Index As Long) As LongPtr ``` 返回/设置指定索引项的附加数据。 ### SelStart ```vb Property Get/Let SelStart() As Long ``` 返回/设置选中文本的起始位置。 ### SelLength ```vb Property Get/Let SelLength() As Long ``` 返回/设置选中文本的长度。 ### SelText ```vb Property Get/Let SelText() As String ``` 返回/设置当前选中的文本。 ### ItemHeight ```vb Property Get ItemHeight() As Single ``` 返回列表项目的高度。只读。 ### FieldHeight ```vb Property Get FieldHeight() As Single ``` 返回编辑框（或静态文本）部分的高度。只读。 ### DroppedDown ```vb Property Get/Let DroppedDown() As Boolean ``` 返回/设置下拉列表是否展开。 ### DropDownWidth ```vb Property Get/Let DropDownWidth() As Single ``` 返回/设置下拉列表的宽度。简单样式下不支持。 ### TopIndex ```vb Property Get/Let TopIndex() As Long ``` 返回/设置列表中顶部可见项的索引。 ## 方法 ### OLEDrag ```vb Public Sub OLEDrag() ``` 启动 OLE 拖动操作。 ### Drag ```vb Public Sub Drag(Optional ByRef Action As Variant) ``` 开始、结束或取消拖动操作。 ### SetFocus ```vb Public Sub SetFocus() ``` 将焦点移到该控件。 ### ZOrder ```vb Public Sub ZOrder(Optional ByRef Position As Variant) ``` 设置控件在其层级中的 Z 顺序位置。 ### Refresh ```vb Public Sub Refresh() ``` 强制完全重绘控件。 ### FindItem ```vb Public Function FindItem(ByVal Text As String, Optional ByVal Index As Long = -1, Optional ByVal Partial As Boolean) As Long ``` 在字体组合框中查找项目并返回其索引。Partial 为 True 时进行部分匹配。 ### GetIdealHorizontalExtent ```vb Public Function GetIdealHorizontalExtent() As Single ``` 获取水平滚动宽度的理想值。 ### SelectItem ```vb Public Function SelectItem(ByVal Text As String, Optional ByVal Index As Long = -1) As Long ``` 搜索以指定字符串开头的项目并选中它。不区分大小写。 ### SaveRecent ```vb Public Function SaveRecent() As Variant ``` 保存最近使用列表，返回字符串数组。 ### RestoreRecent ```vb Public Sub RestoreRecent(ByVal ArgList As Variant) ``` 从之前保存的状态恢复最近使用列表。 ### ClearRecent ```vb Public Sub ClearRecent() ``` 清除最近使用列表的内容。 ## 事件 ### Click ```vb Public Event Click() ``` 单击控件时发生。 ### DblClick ```vb Public Event DblClick() ``` 双击控件时发生。 ### Scroll ```vb Public Event Scroll() ``` 滚动列表时发生。 ### Change ```vb Public Event Change() ``` 控件内容发生变化时发生。 ### ContextMenu ```vb Public Event ContextMenu(ByRef Handled As Boolean, ByVal X As Single, ByVal Y As Single) ``` 右键单击或按 Shift+F10 时发生。设置 Handled 为 True 可阻止默认上下文菜单。 ### DropDown ```vb Public Event DropDown() ``` 下拉列表即将展开时发生。 ### CloseUp ```vb Public Event CloseUp() ``` 下拉列表关闭时发生。 ### PreviewKeyDown ```vb Public Event PreviewKeyDown(ByVal KeyCode As Integer, ByRef IsInputKey As Boolean) ``` 在 KeyDown 事件之前发生，可设置 IsInputKey 标记按键是否为输入键。 ### PreviewKeyUp ```vb Public Event PreviewKeyUp(ByVal KeyCode As Integer, ByRef IsInputKey As Boolean) ``` 在 KeyUp 事件之前发生。 ### KeyDown ```vb Public Event KeyDown(KeyCode As Integer, Shift As Integer) ``` 按下键盘键时发生。 ### KeyUp ```vb Public Event KeyUp(KeyCode As Integer, Shift As Integer) ``` 释放键盘键时发生。 ### KeyPress ```vb Public Event KeyPress(KeyChar As Integer) ``` 按下并释放字符键时发生。 ### MouseDown ```vb Public Event MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` 按下鼠标按钮时发生。 ### MouseMove ```vb Public Event MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` 移动鼠标时发生。 ### MouseUp ```vb Public Event MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` 释放鼠标按钮时发生。 ### MouseEnter ```vb Public Event MouseEnter() ``` 鼠标进入控件时发生。 ### MouseLeave ```vb Public Event MouseLeave() ``` 鼠标离开控件时发生。 ### OLECompleteDrag ```vb Public Event OLECompleteDrag(Effect As Long) ``` OLE 拖放操作完成或取消后，在源控件上发生。 ### OLEDragDrop ```vb Public Event OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single) ``` 数据通过 OLE 拖放操作放置到控件上时发生。 ### OLEDragOver ```vb Public Event OLEDragOver(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single, State As Integer) ``` OLE 拖放操作期间鼠标移过控件时发生。 ### OLEGiveFeedback ```vb Public Event OLEGiveFeedback(Effect As Long, DefaultCursors As Boolean) ``` OLE 拖放操作期间需要更改鼠标光标时，在源控件上发生。 ### OLESetData ```vb Public Event OLESetData(Data As DataObject, DataFormat As Integer) ``` 放置目标请求数据时，在源控件上发生。 ### OLEStartDrag ```vb Public Event OLEStartDrag(Data As DataObject, AllowedEffects As Long) ``` OLE 拖放操作启动时发生。 ## 代码示例 ### 基本用法 ```vb Private Sub Form_Load() With FontCombo1 .Style = FtcStyleDropDownCombo .FontType = FtcFontTypeTrueType .FontPitch = FtcFontPitchAll .RecentMax = 5 End With End Sub Private Sub FontCombo1_Click() Me.Font.Name = FontCombo1.Text Debug.Print "选中字体: " & FontCombo1.Text End Sub Private Sub Form_Unload(Cancel As Integer) Dim v As Variant v = FontCombo1.SaveRecent SaveSetting App.Title, "FontCombo", "Recent", Join(v, vbTab) End Sub ``` --- --- url: /zh/packages/vbccr/lists/comboboxw.md description: 组合框控件（ComboBoxW） - VBCCR 开发手册，基于源码的完整 API 参考 --- # 组合框控件（ComboBoxW） 增强型组合框控件，支持视觉样式、自绘、大小写控制和提示文本。 ## 枚举 ### CboStyleConstants | 常量 | 值 | 说明 | |------|-----|------| | CboStyleDropDownCombo | 0 | 下拉组合框 | | CboStyleSimpleCombo | 1 | 简单组合框 | | CboStyleDropDownList | 2 | 下拉列表 | ### CboCharacterCasingConstants | 常量 | 值 | 说明 | |------|-----|------| | CboCharacterCasingNormal | 0 | 正常大小写 | | CboCharacterCasingUpper | 1 | 大写 | | CboCharacterCasingLower | 2 | 小写 | ### CboDrawModeConstants | 常量 | 值 | 说明 | |------|-----|------| | CboDrawModeNormal | 0 | 正常模式 | | CboDrawModeOwnerDrawFixed | 1 | 固定高度自绘 | | CboDrawModeOwnerDrawVariable | 2 | 可变高度自绘 | ## 属性 ### VisualStyles ```vb Property Get VisualStyles() As Boolean Property Let VisualStyles(ByVal Value As Boolean) ``` 是否启用视觉样式。 ### BackColor ```vb Property Get BackColor() As OLE_COLOR Property Let BackColor(ByVal Value As OLE_COLOR) ``` 背景色。 ### ForeColor ```vb Property Get ForeColor() As OLE_COLOR Property Let ForeColor(ByVal Value As OLE_COLOR) ``` 前景色。 ### OLEDropMode ```vb Property Get OLEDropMode() As OLEDropModeConstants Property Let OLEDropMode(ByVal Value As OLEDropModeConstants) ``` OLE 拖放模式。参见通用枚举。 ### Redraw ```vb Property Get Redraw() As Boolean Property Let Redraw(ByVal Value As Boolean) ``` 是否允许重绘。 ### Style ```vb Property Get Style() As CboStyleConstants Property Let Style(ByVal Value As CboStyleConstants) ``` 组合框样式。 ### Locked ```vb Property Get Locked() As Boolean Property Let Locked(ByVal Value As Boolean) ``` 是否锁定（不可编辑）。 ### Text ```vb Property Get Text() As String Property Let Text(ByVal Value As String) ``` 编辑框文本。 ### ExtendedUI ```vb Property Get ExtendedUI() As Boolean Property Let ExtendedUI(ByVal Value As Boolean) ``` 扩展用户界面模式。 ### MaxDropDownItems ```vb Property Get MaxDropDownItems() As Long Property Let MaxDropDownItems(ByVal Value As Long) ``` 下拉列表最大显示项数。 ### IntegralHeight ```vb Property Get IntegralHeight() As Boolean Property Let IntegralHeight(ByVal Value As Boolean) ``` 是否按整项高度调整列表大小。 ### MaxLength ```vb Property Get MaxLength() As Long Property Let MaxLength(ByVal Value As Long) ``` 编辑框最大字符数。 ### CueBanner ```vb Property Get CueBanner() As String Property Let CueBanner(ByVal Value As String) ``` 提示文本（编辑框为空时显示）。 ### UseListBackColor ```vb Property Get UseListBackColor() As Boolean Property Let UseListBackColor(ByVal Value As Boolean) ``` 是否使用自定义列表背景色。 ### ListBackColor ```vb Property Get ListBackColor() As OLE_COLOR Property Let ListBackColor(ByVal Value As OLE_COLOR) ``` 下拉列表背景色。 ### UseListForeColor ```vb Property Get UseListForeColor() As Boolean Property Let UseListForeColor(ByVal Value As Boolean) ``` 是否使用自定义列表前景色。 ### ListForeColor ```vb Property Get ListForeColor() As OLE_COLOR Property Let ListForeColor(ByVal Value As OLE_COLOR) ``` 下拉列表前景色。 ### Sorted ```vb Property Get Sorted() As Boolean Property Let Sorted(ByVal Value As Boolean) ``` 是否自动排序。 ### HorizontalExtent ```vb Property Get HorizontalExtent() As Long Property Let HorizontalExtent(ByVal Value As Long) ``` 下拉列表水平滚动范围。 ### DisableNoScroll ```vb Property Get DisableNoScroll() As Boolean Property Let DisableNoScroll(ByVal Value As Boolean) ``` 当项目不足以填满时是否禁用滚动条而非隐藏。 ### CharacterCasing ```vb Property Get CharacterCasing() As CboCharacterCasingConstants Property Let CharacterCasing(ByVal Value As CboCharacterCasingConstants) ``` 字符大小写模式。 ### DrawMode ```vb Property Get DrawMode() As CboDrawModeConstants Property Let DrawMode(ByVal Value As CboDrawModeConstants) ``` 绘制模式。 ### IMEMode ```vb Property Get IMEMode() As CCIMEModeConstants Property Let IMEMode(ByVal Value As CCIMEModeConstants) ``` 输入法模式。参见通用枚举。 ### ScrollTrack ```vb Property Get ScrollTrack() As Boolean Property Let ScrollTrack(ByVal Value As Boolean) ``` 是否启用滚动跟踪。 ### AutoSelect ```vb Property Get AutoSelect() As Boolean Property Let AutoSelect(ByVal Value As Boolean) ``` 是否自动选择匹配项。 ### AlwaysFindExact ```vb Property Get AlwaysFindExact() As Boolean Property Let AlwaysFindExact(ByVal Value As Boolean) ``` 是否始终精确查找。 ### ListCount ```vb Property Get ListCount() As Long ``` 列表项数。只读。 ### List ```vb Property Get List(ByVal Index As Long) As String Property Let List(ByVal Index As Long, ByVal Value As String) ``` 按索引存取列表项。 ### ListIndex ```vb Property Get ListIndex() As Long Property Let ListIndex(ByVal Value As Long) ``` 当前选中项索引。 ### ItemData ```vb Property Get ItemData(ByVal Index As Long) As Long Property Let ItemData(ByVal Index As Long, ByVal Value As Long) ``` 列表项关联数据。 ### NewIndex ```vb Property Get NewIndex() As Long ``` 最近添加项的索引。只读。 ### TopIndex ```vb Property Get TopIndex() As Long Property Let TopIndex(ByVal Value As Long) ``` 列表顶部可见项索引。 ### SelStart ```vb Property Get SelStart() As Long Property Let SelStart(ByVal Value As Long) ``` 选中文本起始位置。 ### SelLength ```vb Property Get SelLength() As Long Property Let SelLength(ByVal Value As Long) ``` 选中文本长度。 ### SelText ```vb Property Get SelText() As String Property Let SelText(ByVal Value As String) ``` 选中文本。 ### ItemHeight ```vb Property Get ItemHeight() As Single Property Let ItemHeight(ByVal Value As Single) ``` 列表项高度。 ### FieldHeight ```vb Property Get FieldHeight() As Single ``` 编辑框高度。只读。 ### DroppedDown ```vb Property Get DroppedDown() As Boolean Property Let DroppedDown(ByVal Value As Boolean) ``` 下拉列表是否展开。 ### DropDownWidth ```vb Property Get DropDownWidth() As Long Property Let DropDownWidth(ByVal Value As Long) ``` 下拉列表宽度。 ### DropDownHeight ```vb Property Get DropDownHeight() As Long Property Let DropDownHeight(ByVal Value As Long) ``` 下拉列表高度。 ### hWndEdit ```vb Property Get hWndEdit() As LongPtr ``` 编辑框窗口句柄。只读。 ### hWndList ```vb Property Get hWndList() As LongPtr ``` 列表框窗口句柄。只读。 ### hWnd / hWndUserControl / Font / Enabled / MousePointer / MouseIcon / MouseTrack 参见公共属性。 ### Name / Tag / Parent / Container / Left / Top / Width / Height / Visible / ToolTipText / HelpContextID / WhatsThisHelpID / DragIcon / DragMode 参见标准扩展器属性。 ## 方法 ### AddItem ```vb Public Sub AddItem(ByVal Item As String, Optional ByVal Index As Variant) ``` 添加列表项。 ### RemoveItem ```vb Public Sub RemoveItem(ByVal Index As Long) ``` 移除列表项。 ### Clear ```vb Public Sub Clear() ``` 清空所有列表项。 ### Refresh ```vb Public Sub Refresh() ``` 强制重绘。 ### FindItem ```vb Public Function FindItem(ByVal SearchString As String, Optional ByVal StartIndex As Long, Optional ByVal FindMode As Long) As Long ``` 查找列表项，返回索引。 ### GetIdealHorizontalExtent ```vb Public Function GetIdealHorizontalExtent() As Long ``` 获取理想的水平滚动范围。 ### SelectItem ```vb Public Sub SelectItem(ByVal SearchString As String) ``` 选择匹配的列表项。 ### OLEDrag ```vb Public Sub OLEDrag() ``` 启动 OLE 拖放。 ### Drag / ZOrder / SetFocus / Move 参见标准方法。 ## 事件 ### Click ```vb Public Event Click() ``` ### DblClick ```vb Public Event DblClick() ``` ### Scroll ```vb Public Event Scroll() ``` 列表滚动时触发。 ### Change ```vb Public Event Change() ``` 文本内容改变时触发。 ### ContextMenu ```vb Public Event ContextMenu() ``` 右键菜单。 ### DropDown ```vb Public Event DropDown() ``` 下拉列表展开。 ### CloseUp ```vb Public Event CloseUp() ``` 下拉列表关闭。 ### ItemMeasure ```vb Public Event ItemMeasure(ByVal Index As Long, ByVal ItemWidth As Long, ByVal ItemHeight As Long) ``` 自绘测量事件。 ### ItemDraw ```vb Public Event ItemDraw(ByVal Index As Long, ByVal ItemState As Long, ByVal hDC As LongPtr, ByVal Left As Long, ByVal Top As Long, ByVal Right As Long, ByVal Bottom As Long) ``` 自绘绘制事件。 ### KeyDown / KeyUp / KeyPress ### MouseDown / MouseMove / MouseUp / MouseEnter / MouseLeave ### OLECompleteDrag / OLEDragDrop / OLEDragOver / OLEGiveFeedback / OLESetData / OLEStartDrag ## 代码示例 ### 基本用法 ```vb ' 添加项目 ComboBoxW1.AddItem "苹果" ComboBoxW1.AddItem "香蕉" ComboBoxW1.ListIndex = 0 ' 设置提示文本 ComboBoxW1.CueBanner = "请选择水果..." ' 大写模式 ComboBoxW1.CharacterCasing = CboCharacterCasingUpper ' 自绘模式 ComboBoxW1.DrawMode = CboDrawModeOwnerDrawFixed ``` ### 自绘示例 ```vb Private Sub ComboBoxW1_ItemDraw(ByVal Index As Long, ByVal ItemState As Long, _ ByVal hDC As LongPtr, ByVal Left As Long, ByVal Top As Long, _ ByVal Right As Long, ByVal Bottom As Long) ' 绘制自定义列表项 End Sub ``` --- --- url: /zh/emoji/20D0-20FF.md --- # 组合用记号 (Combining Diacritics Marks for Symbols) 本页面展示了Unicode字符集中，位于U+20D0到U+20FF范围的组合用记号。这些符号主要用于修饰其他符号，特别是在数学和技术符号中。 | 字符 | Unicode | VB函数值 | 名称 | |:---:|:---:|:---:|:---| | ⃐ | U+20D0 | ChrW(\&H20D0) | 组合左指向箭头 | | ⃑ | U+20D1 | ChrW(\&H20D1) | 组合右指向箭头 | | ⃒ | U+20D2 | ChrW(\&H20D2) | 组合长垂直线覆盖 | | ⃓ | U+20D3 | ChrW(\&H20D3) | 组合短垂直线覆盖 | | ⃔ | U+20D4 | ChrW(\&H20D4) | 组合顺时针箭头 | | ⃕ | U+20D5 | ChrW(\&H20D5) | 组合逆时针箭头 | | ⃖ | U+20D6 | ChrW(\&H20D6) | 组合左指向箭头覆盖 | | ⃗ | U+20D7 | ChrW(\&H20D7) | 组合右指向箭头覆盖 | | ⃘ | U+20D8 | ChrW(\&H20D8) | 组合环形覆盖 | | ⃙ | U+20D9 | ChrW(\&H20D9) | 组合右侧环形覆盖 | | ⃚ | U+20DA | ChrW(\&H20DA) | 组合左侧环形覆盖 | | ⃛ | U+20DB | ChrW(\&H20DB) | 组合三点覆盖 | | ⃜ | U+20DC | ChrW(\&H20DC) | 组合四点覆盖 | | ⃝ | U+20DD | ChrW(\&H20DD) | 组合圆形封闭 | | ⃞ | U+20DE | ChrW(\&H20DE) | 组合方形封闭 | | ⃟ | U+20DF | ChrW(\&H20DF) | 组合菱形封闭 | | ⃠ | U+20E0 | ChrW(\&H20E0) | 组合圆形封闭带长斜线 | | ⃡ | U+20E1 | ChrW(\&H20E1) | 组合左右箭头 | | ⃢ | U+20E2 | ChrW(\&H20E2) | 组合屏蔽 | | ⃣ | U+20E3 | ChrW(\&H20E3) | 组合封闭键帽 | | ⃤ | U+20E4 | ChrW(\&H20E4) | 组合上升楔形覆盖 | | ⃥ | U+20E5 | ChrW(\&H20E5) | 组合反斜线覆盖 | | ⃦ | U+20E6 | ChrW(\&H20E6) | 组合双竖线覆盖 | | ⃧ | U+20E7 | ChrW(\&H20E7) | 组合对称封闭 | | ⃨ | U+20E8 | ChrW(\&H20E8) | 组合下三点 | | ⃩ | U+20E9 | ChrW(\&H20E9) | 组合宽桥覆盖 | | ⃪ | U+20EA | ChrW(\&H20EA) | 组合左点覆盖 | | ⃫ | U+20EB | ChrW(\&H20EB) | 组合右点覆盖 | | ⃬ | U+20EC | ChrW(\&H20EC) | 组合左箭头下 | | ⃭ | U+20ED | ChrW(\&H20ED) | 组合右箭头下 | | ⃮ | U+20EE | ChrW(\&H20EE) | 组合左箭头上 | | ⃯ | U+20EF | ChrW(\&H20EF) | 组合右箭头上 | | ⃰ | U+20F0 | ChrW(\&H20F0) | 组合星号上 | --- --- url: /zh/EULA.md --- # 最终用户许可协议 ## **VBMAN 系列产品使用协议与免责声明** **重要提示：在您下载、安装、使用或以任何方式接触本站（下称“本站”或“本网站”）提供的任何 VBMAN 系列产品（包括但不限于软件、代码、脚本、文档及相关资料，下称“本产品”）之前，请您务必仔细阅读、充分理解本协议的全部条款。您的任何下载、安装、使用行为，即被视为您已**完全理解、知悉并毫无保留地接受**本协议所有条款的约束。若您不同意本协议的任何内容，请**立即停止\*\*访问本站及使用本产品的任何行为。 ### **第一条 产品用途声明** 1.1 本产品仅限于**合法、正当、健康**的用途。用户承诺遵守其所在国家、地区及使用行为发生地的一切现行法律、法规及公序良俗。 1.2 **严格禁止**任何用户将本产品用于任何非法、侵权、欺诈、破坏网络安全、侵犯他人隐私、传播恶意信息或任何违反中华人民共和国法律法规及国际通行法律准则的活动。 ### **第二条 用户责任与行为规范** 2.1 用户理解并同意，其使用本产品的方式、行为及产生的一切后果，**均由用户自行负责**。用户应独立判断其使用行为的合法性，并承担由此引发的全部法律责任。 2.2 用户有义务确保其使用行为不侵犯任何第三方的合法权益（包括但不限于知识产权、隐私权、名誉权等），亦不损害社会公共利益。 ### **第三条 本站免责声明** 3.1 本站及本产品作者（下称“本作者”）**仅提供本产品本身**，对于用户**如何使用、在何种场景下使用、以及使用后造成的一切后果，不承担任何直接、间接、附带、特殊、惩罚性或衍生性的责任**。 3.2 因用户违反本协议或相关法律法规，导致任何第三方、行政机关向本站或本作者提出任何索赔、要求或导致任何损失的，用户应负责处理并承担全部赔偿费用，并确保本站及本作者免受任何损害。 3.3 用户明确知晓并同意，其后续的任何违法行为均**与本站及本作者无关**。法律责任由**使用者本人**独立承担。 ### **第四条 审查与配合义务** 4.1 尽管有前述免责声明，本作者郑重承诺，将严格遵守国家法律法规，履行公民和企业应尽的义务。 4.2 如因用户使用本产品涉嫌违法，在国家有权机关（如公安机关、司法机关、网信部门等）依照法定程序提出审查要求时，**本作者将依法予以必要的配合**，包括但不限于提供相关的下载记录、用户信息等法律要求提供的资料。但此等配合不构成本作者对用户行为的认可或责任承担。 ### **第五条 协议修改与解释权** 5.1 本作者有权在必要时单方修改本协议条款，并在本网站公布，无需另行单独通知用户。修改后的协议自公布之日起生效。 5.2 用户若继续使用本产品，即视为接受修改后的协议；若不同意修改内容，应立即停止使用。 5.3 本协议的解释权及法律效力，均依据中华人民共和国法律。本协议任何条款如被认定为无效或不可执行，不影响其余条款的持续有效。 *** **最后再次提醒：技术本身无善恶，唯人心所向。请务必将本产品用于正途，共同维护清朗的网络空间。您的下载与使用行为，即代表您已庄严承诺遵守上述全部约定。** *** --- --- url: /en/vbman/database/advanced.md --- # Advanced Features This document introduces the advanced features and best practices of the cDataBase class library, helping you make better use of the database class. *** ## Table of Contents * [Asynchronous Execution](#asynchronous-execution) * [Connection Pool Management](#connection-pool-management) * [Batch Operation Optimization](#batch-operation-optimization) * [Performance Optimization Tips](#performance-optimization-tips) * [Error Handling Strategy](#error-handling-strategy) * [Design Pattern Applications](#design-pattern-applications) * [Common Problem Solutions](#common-problem-solutions) *** ## Asynchronous Execution ### Async Property The `Async` property enables asynchronous SQL execution without blocking the main thread. #### Syntax ```vb Property Get Async() As cDataBase ``` #### Example ```vb ' Asynchronous INSERT execution db.Sql("INSERT INTO logs (message) VALUES ('test')").Async.Exec ' Listen for completion event Private Sub db_AsyncExecuteComplete(ByVal RecordsAffected As Long, _ ByVal pError As ADODB.Error, _ adStatus As ADODB.EventStatusEnum, _ ByVal pCommand As ADODB.Command, _ ByVal pRecordset As ADODB.Recordset, _ ByVal pConnection As ADODB.Connection) If pError Is Nothing Then Debug.Print "Async execution successful, rows affected: " & RecordsAffected Else Debug.Print "Async execution failed: " & pError.Description End If End Sub ``` ### Asynchronous Execution Scenarios ```vb ' Scenario 1: Logging (non-blocking main flow) Sub LogMessage(sMessage As String) db.Sql("INSERT INTO logs (message, created_at) VALUES (?, ?)") _ .Param("message", sMessage, VBMAN.adVarWChar) _ .Param("created_at", Now, VBMAN.adDate) _ .Async.ExecParam ' Don't wait for execution to complete, continue with subsequent code End Sub ' Scenario 2: Batch data processing Sub ProcessLargeDataset() ' Main thread continues processing ProcessData ' Save results asynchronously db.Sql("INSERT INTO results SELECT * FROM temp_table").Async.Exec End Sub ``` *** ## Connection Pool Management ### Multiple Database Connections Use connection pool to manage multiple database connections. ```vb Dim db As New VBMAN.cDataBase ' Main database db.Connect VBMAN.enumDbType_MsSql, "127.0.0.1,1433", "sa", "pwd", "maindb" ' Log database Dim dbLog As VBMAN.cDataBase Set dbLog = db.ConnInst("log", False) dbLog.Connect VBMAN.enumDbType_Mysql, "192.168.1.100:3306", "loguser", "pwd", "logdb" ' Cache database Dim dbCache As VBMAN.cDataBase Set dbCache = db.ConnInst("cache", False) dbCache.Connect VBMAN.enumDbType_MsSql, "127.0.0.1,1433", "sa", "pwd", "cachedb" ' Use different databases db.Sql("SELECT * FROM users").Query dbLog.Sql("INSERT INTO logs (msg) VALUES ('test')").Exec dbCache.Sql("SELECT * FROM cache_data").Query ``` ### Dynamic Connection Management ```vb ' Create connections dynamically based on configuration Function GetDatabase(sConfigName As String) As VBMAN.cDataBase Dim dbInst As VBMAN.cDataBase Set dbInst = db.ConnInst(sConfigName, False) ' Connect to different databases based on configuration Select Case sConfigName Case "main" dbInst.Connect VBMAN.enumDbType_MsSql, "127.0.0.1,1433", "sa", "pwd", "maindb" Case "backup" dbInst.Connect VBMAN.enumDbType_Mysql, "192.168.1.100:3306", "user", "pwd", "backupdb" Case "readonly" dbInst.Connect VBMAN.enumDbType_MsSql, "127.0.0.1,1433", "readonly", "pwd", "maindb" End Select Set GetDatabase = dbInst End Function ' Usage Dim dbMain As VBMAN.cDataBase Set dbMain = GetDatabase("main") dbMain.Sql("SELECT * FROM users").Query ``` ### Connection Cleanup ```vb ' Remove specified connection db.ConnInstRemove "log" ' Remove all connections db.ConnInstRemove "" ``` *** ## Batch Operation Optimization ### Batch Insert Optimization ```vb ' Method 1: Using BatchInsert (recommended) Sub BatchInsertUsers(colUsers As Collection) If db.BatchInsert("users", colUsers) Then Debug.Print "Batch insert successful" End If End Sub ' Method 2: Using transaction + loop Sub BatchInsertUsers2(colUsers As Collection) db.TransBegin Dim i As Long For i = 1 To colUsers.Count Dim dictUser As Dictionary Set dictUser = colUsers(i) Dim sSql As String sSql = "INSERT INTO users (name, age) VALUES ('" & _ db.Escape(dictUser("name")) & "', " & dictUser("age") & ")" If Not db.Sql(sSql).Exec Then db.TransRollback Exit Sub End If Next db.TransCommit End Sub ' Method 3: Using VALUES clause (SQL Server/MySQL) Sub BatchInsertUsers3(colUsers As Collection) Dim sSql As String sSql = "INSERT INTO users (name, age) VALUES " Dim i As Long For i = 1 To colUsers.Count Dim dictUser As Dictionary Set dictUser = colUsers(i) If i > 1 Then sSql = sSql & ", " sSql = sSql & "('" & db.Escape(dictUser("name")) & "', " & dictUser("age") & ")" Next db.Sql(sSql).Exec End Sub ``` ### Batch Update Optimization ```vb ' Use transaction for batch update Sub BatchUpdateUsers(colUpdates As Collection) db.TransBegin Dim i As Long For i = 1 To colUpdates.Count Dim dictUpdate As Dictionary Set dictUpdate = colUpdates(i) If Not db.Sql("UPDATE users SET name = ?, age = ? WHERE id = ?") _ .Param("name", dictUpdate("name"), VBMAN.adVarWChar) _ .Param("age", dictUpdate("age"), VBMAN.adInteger) _ .Param("id", dictUpdate("id"), VBMAN.adInteger) _ .ExecParam Then db.TransRollback Exit Sub End If Next db.TransCommit End Sub ``` *** ## Performance Optimization Tips ### 1. Use Indexed Fields ```vb ' Recommended: Use indexed fields as conditions db.Sql("SELECT * FROM users WHERE id = 1").Query ' Not recommended: Use non-indexed fields db.Sql("SELECT * FROM users WHERE name = 'John'").Query ``` ### 2. Only Query Needed Fields ```vb ' Recommended: Only query needed fields db.Sql("SELECT id, name FROM users").Query ' Not recommended: Query all fields db.Sql("SELECT * FROM users").Query ``` ### 3. Use Appropriate Cursor Types ```vb ' Recommended: Use ForwardOnly for read-only queries db.Sql("SELECT * FROM users").Query adOpenForwardOnly, adLockReadOnly ' Not recommended: Use default cursor (may be slower) db.Sql("SELECT * FROM users").Query ``` ### 4. Limit Result Set Size ```vb ' Recommended: Use TOP/LIMIT to limit results db.Sql("SELECT TOP 100 * FROM users").Query ' Not recommended: Query all data db.Sql("SELECT * FROM users").Query ``` ### 5. Use Pagination ```vb ' Recommended: Use pagination db.Sql("SELECT * FROM users").Page(1, 20).Query ' Not recommended: Query all data at once db.Sql("SELECT * FROM users").Query ``` ### 6. Cache Query Results ```vb ' Cache query results Private m_colCachedUsers As Collection Private m_dtCacheTime As Date Function GetUsers() As Collection ' Cache for 5 minutes If DateDiff("s", m_dtCacheTime, Now) > 300 Or m_colCachedUsers Is Nothing Then If db.Sql("SELECT * FROM users").Fetch Then Set m_colCachedUsers = db.Rows m_dtCacheTime = Now End If End If Set GetUsers = m_colCachedUsers End Function ``` *** ## Error Handling Strategy ### Unified Error Handling ```vb ' Unified error handling function Function ExecuteSQL(sSql As String) As Boolean On Error GoTo ErrHandler If db.Sql(sSql).Exec Then ExecuteSQL = True Else LogError "SQL execution failed", db.LastErr ExecuteSQL = False End If Exit Function ErrHandler: LogError "Exception occurred", Err.Description ExecuteSQL = False End Function ' Error logging Sub LogError(sOperation As String, sError As String) ' Log to file or database Debug.Print Now & " - " & sOperation & ": " & sError End Sub ``` ### Retry Mechanism ```vb ' Query with retry Function QueryWithRetry(sSql As String, Optional lMaxRetries As Long = 3) As Boolean Dim lRetry As Long For lRetry = 1 To lMaxRetries If db.Sql(sSql).Query Then QueryWithRetry = True Exit Function End If ' Check connection If Not db.CheckConnection Then db.Connect VBMAN.enumDbType_MsSql, "127.0.0.1,1433", "sa", "pwd", "mydb" End If ' Wait and retry Sleep 1000 Next QueryWithRetry = False End Function ``` *** ## Design Pattern Applications ### Singleton Pattern ```vb ' Database singleton Private m_DB As VBMAN.cDataBase Function GetDatabase() As VBMAN.cDataBase If m_DB Is Nothing Then Set m_DB = New VBMAN.cDataBase m_DB.Connect VBMAN.enumDbType_MsSql, "127.0.0.1,1433", "sa", "pwd", "mydb" End If Set GetDatabase = m_DB End Function ``` ### Factory Pattern ```vb ' Database factory Function CreateDatabase(sType As String) As VBMAN.cDataBase Dim db As New VBMAN.cDataBase Select Case sType Case "main" db.Connect VBMAN.enumDbType_MsSql, "127.0.0.1,1433", "sa", "pwd", "maindb" Case "log" db.Connect VBMAN.enumDbType_Mysql, "192.168.1.100:3306", "loguser", "pwd", "logdb" Case "cache" db.Connect VBMAN.enumDbType_MsSql, "127.0.0.1,1433", "sa", "pwd", "cachedb" End Select Set CreateDatabase = db End Function ``` ### Repository Pattern ```vb ' User repository Class cUserRepository Private m_DB As VBMAN.cDataBase Private Sub Class_Initialize() Set m_DB = New VBMAN.cDataBase m_DB.Connect VBMAN.enumDbType_MsSql, "127.0.0.1,1433", "sa", "pwd", "mydb" End Sub Function GetById(lId As Long) As Dictionary If m_DB.Sql("SELECT * FROM users WHERE id = ?") _ .Param("id", lId, VBMAN.adInteger) _ .QueryParam Then If m_DB.Rows.Count > 0 Then Set GetById = m_DB.Row End If End If End Function Function GetAll() As Collection If m_DB.Sql("SELECT * FROM users").Fetch Then Set GetAll = m_DB.Rows End If End Function Function Save(dictUser As Dictionary) As Boolean If m_DB.Sql("INSERT INTO users (name, age) VALUES (?, ?)") _ .Param("name", dictUser("name"), VBMAN.adVarWChar) _ .Param("age", dictUser("age"), VBMAN.adInteger) _ .ExecParam Then Save = True Else Save = False End If End Function End Class ``` *** ## Common Problem Solutions ### Q1: Connection Timeout **Problem**: Connection to database times out. **Solution**: ```vb ' Set connection timeout db.Conn.ConnectionTimeout = 30 ' 30 seconds db.Connect VBMAN.enumDbType_MsSql, "127.0.0.1,1433", "sa", "pwd", "mydb" ``` ### Q2: Query Timeout **Problem**: Query execution takes too long. **Solution**: ```vb ' Set command timeout db.Conn.CommandTimeout = 60 ' 60 seconds db.Sql("SELECT * FROM large_table").Query ``` ### Q3: Out of Memory **Problem**: Querying large amounts of data causes memory exhaustion. **Solution**: ```vb ' Use pagination query db.Sql("SELECT * FROM large_table").Page(1, 1000).Query ' Or use streaming If db.Sql("SELECT * FROM large_table").Query Then Do Until db.Rs.EOF ' Process single record ProcessRecord db.Rs db.Rs.MoveNext Loop End If ``` ### Q4: Concurrency Conflicts **Problem**: Multiple operations execute simultaneously causing conflicts. **Solution**: ```vb ' Use transaction and locking db.TransBegin db.Sql("SELECT * FROM users WHERE id = 1").Query adOpenKeyset, adLockPessimistic ' Process data db.Sql("UPDATE users SET ...").Exec db.TransCommit ``` *** ## Best Practices Summary ### 1. Connection Management * Connect when needed, disconnect when done * For frequent operations, keep the connection alive * Use connection pool to manage multiple connections ### 2. Query Optimization * Use indexed fields as conditions * Only query needed fields * Use pagination to limit result sets * Use appropriate cursor types ### 3. Security Protection * Always use parameterized queries * Validate user input * Use transactions to ensure consistency ### 4. Error Handling * Always check return values * Log errors * Implement retry mechanism ### 5. Code Organization * Use design patterns * Encapsulate common operations * Keep code clean *** **Last Updated**: 2026-01-21 --- --- url: /en/vbman/websocket/advanced.md --- # Advanced Usage Guide This guide covers advanced features and best practices for the WebSocket library. *** ## 📡 Message Fragmentation ### Concept WebSocket allows splitting large messages into multiple frames: ``` First frame: FIN=0, OpCode=TEXT/BINARY (Message start) Following frames: FIN=0, OpCode=CONTINUATION Last frame: FIN=1, OpCode=CONTINUATION ``` ### Server Fragmentation Handling ```vb Private Sub ProcessDataFrame(ByVal Client As cWebSocketServerClient, _ ByRef Payload() As Byte, _ ByVal OpCode As WsOpCode, _ ByVal IsFinal As Boolean) If IsFinal And Not Client.IsFragmented Then ' Complete single-frame message DeliverClientMessage Client, Payload, OpCode Else ' Start or continue fragmented message Client.IsFragmented = True Client.FragmentOpCode = OpCode Client.FragmentBuffer.Clear On Error Resume Next If UBound(Payload) >= 0 Then Client.FragmentBuffer.Append Payload End If On Error GoTo 0 If IsFinal Then DeliverFragmentedMessage Client End If End If End Sub Private Sub DeliverFragmentedMessage(ByVal Client As cWebSocketServerClient) Dim baData() As Byte baData = Client.GetFragmentedData DeliverClientMessage Client, baData, Client.FragmentOpCode Client.ClearFragmentBuffer End Sub ``` ### Client Fragmentation Sending ```vb ' Fragment sending of large messages Public Sub SendLargeMessage(ByVal sMessage As String) Dim baPayload() As Byte baPayload = StringToUTF8(sMessage) Dim lChunkSize As Long lChunkSize = 4096 ' 4KB per frame Dim lTotal As Long lTotal = UBound(baPayload) + 1 Dim oFrame As New cWebSocketFrame Dim i As Long Dim lOffset As Long Do While lOffset < lTotal Dim lSize As Long lSize = lChunkSize If lOffset + lSize > lTotal Then lSize = lTotal - lOffset End If Dim baChunk() As Byte ReDim baChunk(lSize - 1) As Byte CopyMemory baChunk(0), baPayload(lOffset), lSize Dim baFrame() As Byte Dim bIsFinal As Boolean bIsFinal = (lOffset + lSize >= lTotal) If lOffset = 0 Then ' First frame baFrame = oFrame.BuildFrame(baChunk, WS_OPCODE_TEXT, True, bIsFinal) Else ' Subsequent frames baFrame = oFrame.BuildFrame(baChunk, WS_OPCODE_CONTINUATION, True, bIsFinal) End If m_Socket.SendData baFrame lOffset = lOffset + lSize Loop End Sub ``` *** ## 🔄 Auto-Reconnect Mechanism ### Client Auto-Reconnect ```vb Option Explicit Private WithEvents m_Client As cWebSocketClient Private WithEvents tmrReconnect As Timer Private m_bAutoReconnect As Boolean Private m_sServerURL As String Private m_lMaxRetries As Long Private m_lRetryCount As Long Private Sub Form_Load() Set m_Client = New cWebSocketClient Set tmrReconnect = New Timer m_bAutoReconnect = True m_sServerURL = "ws://127.0.0.1:8080" m_lMaxRetries = 5 m_lRetryCount = 0 tmrReconnect.Interval = 5000 ' 5 seconds ConnectToServer End Sub Private Sub ConnectToServer() If m_Client.State = WS_STATE_CLOSED Then Debug.Print "Connecting... (" & (m_lRetryCount + 1) & "/" & m_lMaxRetries & ")" On Error Resume Next m_Client.Connect m_sServerURL On Error GoTo 0 End If End Sub Private Sub m_Client_OnOpen() Debug.Print "Connected" m_lRetryCount = 0 tmrReconnect.Enabled = False End Sub Private Sub m_Client_OnClose(ByVal Code As WsCloseCode, ByVal Reason As String) Debug.Print "Connection closed: " & Reason If m_bAutoReconnect And Code <> WS_CLOSE_NORMAL Then m_lRetryCount = m_lRetryCount + 1 If m_lRetryCount < m_lMaxRetries Then Debug.Print "Reconnecting in 5 seconds..." tmrReconnect.Enabled = True Else Debug.Print "Maximum retry attempts reached" MsgBox "Cannot connect to server, please try again later", vbExclamation End If End If End Sub Private Sub tmrReconnect_Timer() tmrReconnect.Enabled = False ConnectToServer End Sub ``` *** ## 📡 Heartbeat Keepalive ### Client Auto Ping ```vb Option Explicit Private WithEvents m_Client As cWebSocketClient Private WithEvents tmrPing As Timer Private m_bAutoPing As Boolean Private m_lPingInterval As Long Private Sub Form_Load() Set m_Client = New cWebSocketClient Set tmrPing = New Timer m_bAutoPing = True m_lPingInterval = 30000 ' 30 seconds tmrPing.Interval = m_lPingInterval End Sub Private Sub m_Client_OnOpen() If m_bAutoPing Then tmrPing.Enabled = True Debug.Print "Heartbeat enabled, interval: " & m_lPingInterval & " ms" End If End Sub Private Sub tmrPing_Timer() If m_Client.State = WS_STATE_OPEN Then ' Send Ping (with timestamp for latency measurement) Dim lTimestamp As Long lTimestamp = GetTickCount() Dim baData(3) As Byte baData(0) = (lTimestamp And &HFF000000) \ &H1000000 baData(1) = (lTimestamp And &HFF0000) \ &H10000 baData(2) = (lTimestamp And &HFF00&) \ &H100& baData(3) = lTimestamp And &HFF& m_Client.SendPing baData Debug.Print "Ping sent" End If End Sub Private Sub m_Client_OnPong(Data() As Byte) If UBound(Data) >= 3 Then Dim lSendTime As Long lSendTime = CLng(Data(0)) * 256& ^ 3 + CLng(Data(1)) * 256& ^ 2 + _ CLng(Data(2)) * 256& + CLng(Data(3)) Dim lLatency As Long lLatency = GetTickCount() - lSendTime Debug.Print "Pong received, latency: " & lLatency & " ms" End If End Sub ``` *** ## 🔐 Authentication and Authorization ### Client Token Authentication ```vb Public Sub ConnectWithToken(ByVal ServerURL As String, ByVal Token As String) ' Add Token to URL Dim sURL As String sURL = ServerURL & "?token=" & Token m_Client.Connect sURL End Sub ' Or send after handshake Private Sub m_Client_OnOpen() ' Send authentication info Dim sAuth As String sAuth = "{""type"":""auth"", ""token"":""abc123""}" m_Client.SendText sAuth End Sub ``` ### Server Authentication Verification ```vb Private Sub m_Server_OnClientConnect(ByVal ClientID As String, ByVal RemoteAddress As String, ByVal RemotePort As Long) ' Get Token (assume in URL query parameters) ' Note: Need to extend handshake logic to get query parameters Dim sToken As String sToken = GetTokenFromHandshake(m_Server, ClientID) If Not ValidateToken(sToken) Then Debug.Print "Authentication failed: " & ClientID m_Server.DisconnectClient ClientID, WS_CLOSE_POLICY_VIOLATION, "Invalid Token" Exit Sub End If ' Authentication successful Debug.Print "Authentication successful: " & ClientID End Sub Private Function ValidateToken(ByVal Token As String) As Boolean ' Verify Token (example) If LenB(Token) = 0 Then ValidateToken = False Exit Function End If ' Check database or config ' ... ValidateToken = True End Function ``` *** ## 📦 Custom Protocol ### Protocol Definition ```vb ' Custom message types Private Const MSG_TYPE_CHAT As Long = 1 Private Const MSG_TYPE_JOIN As Long = 2 Private Const MSG_TYPE_LEAVE As Long = 3 Private Const MSG_TYPE_SYSTEM As Long = 4 ' Message header structure Private Type tMessageHeader Type As Long ' Message type Length As Long ' Message length SenderID As String ' Sender ID End Type ``` ### Build Custom Message ```vb Public Function BuildCustomMessage(ByVal MsgType As Long, ByVal SenderID As String, ByVal Content As String) As Byte() Dim baContent() As Byte baContent = StringToUTF8(Content) ' Build header Dim oBuffer As New cByteBuffer oBuffer.AppendByte (MsgType And &HFF000000) \ &H1000000 oBuffer.AppendByte (MsgType And &HFF0000) \ &H10000 oBuffer.AppendByte (MsgType And &HFF00&) \ &H100& oBuffer.AppendByte (MsgType And &HFF&) Dim lLen As Long lLen = UBound(baContent) + 1 oBuffer.AppendByte (lLen And &HFF000000) \ &H1000000 oBuffer.AppendByte (lLen And &HFF0000) \ &H10000 oBuffer.AppendByte (lLen And &HFF00&) \ &H100& oBuffer.AppendByte (lLen And &HFF&) ' Add SenderID length and content Dim baSenderID() As Byte baSenderID = StringToUTF8(SenderID) oBuffer.AppendByte (UBound(baSenderID) + 1) If UBound(baSenderID) >= 0 Then oBuffer.Append baSenderID End If ' Add content If UBound(baContent) >= 0 Then oBuffer.Append baContent End If BuildCustomMessage = oBuffer.ToArray End Function ``` ### Parse Custom Message ```vb Public Sub ParseCustomMessage(ByVal Data() As Byte) Dim oBuffer As New cByteBuffer oBuffer.Append Data ' Read type Dim lType As Long lType = CLng(oBuffer.PeekByte(0)) * 256& ^ 3 + _ CLng(oBuffer.PeekByte(1)) * 256& ^ 2 + _ CLng(oBuffer.PeekByte(2)) * 256& + _ CLng(oBuffer.PeekByte(3)) oBuffer.Consume 4 ' Read length Dim lLength As Long lLength = CLng(oBuffer.PeekByte(0)) * 256& ^ 3 + _ CLng(oBuffer.PeekByte(1)) * 256& ^ 2 + _ CLng(oBuffer.PeekByte(2)) * 256& + _ CLng(oBuffer.PeekByte(3)) oBuffer.Consume 4 ' Read SenderID Dim lSenderLen As Byte lSenderLen = oBuffer.PeekByte(0) oBuffer.Consume 1 Dim baSenderID() As Byte ReDim baSenderID(lSenderLen - 1) As Byte If lSenderLen > 0 Then Dim i As Long For i = 0 To lSenderLen - 1 baSenderID(i) = oBuffer.PeekByte(i) Next i oBuffer.Consume lSenderLen End If Dim sSenderID As String sSenderID = UTF8ToString(baSenderID) ' Read content Dim baContent() As Byte If lLength > 0 Then ReDim baContent(lLength - 1) As Byte For i = 0 To lLength - 1 baContent(i) = oBuffer.PeekByte(i) Next i End If Dim sContent As String sContent = UTF8ToString(baContent) ' Process message Select Case lType Case MSG_TYPE_CHAT HandleChatMessage sSenderID, sContent Case MSG_TYPE_JOIN HandleJoinMessage sSenderID Case MSG_TYPE_LEAVE HandleLeaveMessage sSenderID Case MSG_TYPE_SYSTEM HandleSystemMessage sContent End Select End Sub ``` *** ## 📊 Performance Optimization ### 1. Batch Sending ```vb ' ❌ Bad: Multiple SendText calls For i = 0 To 100 m_Client.SendText "Message " & i Next i ' ✅ Good: Single send after concatenation Dim sMessages As String For i = 0 To 100 sMessages = sMessages & "Message " & i & vbLf Next i m_Client.SendText sMessages ``` ### 2. Use Events Instead of Polling ```vb ' ✅ Good: Use events Private Sub m_Client_OnTextMessage(ByVal Message As String) ProcessMessage Message End Sub ' ❌ Bad: Polling check Private Sub Timer1_Timer() If m_Client.State = WS_STATE_OPEN Then ' Poll data (not recommended) End If End Sub ``` ### 3. Limit Broadcast Frequency ```vb Private WithEvents tmrBroadcast As Timer Private m_sBroadcastQueue As String Private Sub QueueBroadcast(ByVal Message As String) m_sBroadcastQueue = m_sBroadcastQueue & Message & vbLf End Sub Private Sub tmrBroadcast_Timer() If LenB(m_sBroadcastQueue) > 0 Then m_Server.BroadcastText m_sBroadcastQueue m_sBroadcastQueue = "" End If End Sub ``` *** ## 🐛 Error Handling Best Practices ### Unified Error Handling ```vb ' Logging module Public Sub LogError(ByVal ModuleName As String, ByVal Procedure As String, ByVal Description As String) Dim sLog As String sLog = "[" & Format$(Now, "yyyy-mm-dd hh:nn:ss") & "] " sLog = sLog & ModuleName & "." & Procedure & ": " & Description Debug.Print sLog ' Write to file Dim iFile As Integer iFile = FreeFile Open "error.log" For Append As #iFile Print #iFile, sLog Close #iFile End Sub ' Usage example Private Sub m_Client_OnError(ByVal Description As String) LogError "frmClient", "OnError", Description End Sub ``` ### Connection State Check ```vb Public Sub SendMessageSafe(ByVal Message As String) If m_Client Is Nothing Then Debug.Print "Client not initialized" Exit Sub End If Select Case m_Client.State Case WS_STATE_OPEN ' Can send m_Client.SendText Message Case WS_STATE_CONNECTING Debug.Print "Connecting, please wait" Case WS_STATE_CLOSING Debug.Print "Connection closing" Case WS_STATE_CLOSED Debug.Print "Connection closed" End Select End Sub ``` *** ## 🔍 Debugging Tips ### Log Output ```vb Private Sub DebugFrame(oFrame As cWebSocketFrame) Debug.Print "=== WebSocket Frame ===" Debug.Print "FIN: " & oFrame.FIN Debug.Print "OpCode: " & oFrame.OpCode Debug.Print "HasMask: " & oFrame.HasMask Debug.Print "PayloadLength: " & oFrame.PayloadLength Debug.Print "HeaderLength: " & oFrame.HeaderLength Debug.Print "TotalFrameLength: " & oFrame.TotalFrameLength Debug.Print "IsValid: " & oFrame.IsValid Debug.Print "===================" End Sub ``` ### Message Tracking ```vb Private Sub LogMessage(ByVal ClientID As String, ByVal Direction As String, ByVal Message As String) Dim sLog As String sLog = Format$(Now, "hh:nn:ss") & " [" & Direction & "] " & ClientID & ": " & Message txtLog.Text = txtLog.Text & sLog & vbCrLf txtLog.SelStart = Len(txtLog.Text) ' Save to file Dim iFile As Integer iFile = FreeFile Open "messages.log" For Append As #iFile Print #iFile, sLog Close #iFile End Sub ' Usage LogMessage ClientID, "OUT", Message LogMessage ClientID, "IN", Message ``` *** ## 📚 References * [RFC 6455 - WebSocket Protocol](https://tools.ietf.org/html/rfc6455) * [MDN WebSockets API](https://developer.mozilla.org/en-US/docs/Web/API/WebSocket) * [WebSocket Online Testing Tool](https://www.piesocket.com/websocket-tester) *** **Last Updated**: 2026-01-10 --- --- url: /zh/vbman/crypt/aes/methods.md --- # AES 加密方法参考 ## 📋 方法列表 | 类 | 方法 | 说明 | |----|------|------| | `cAes` | `CBC` | 访问 CBC 加密实例 | | `cAesCBC` | `Encode` | 加密字符串数据 | *** ## 🔌 cAes.CBC 属性 ### 说明 访问 `cAesCBC` 实例，这是 AES CBC 加密的主要入口。 ### 语法 ```vb Public CBC As New cAesCBC ``` ### 使用示例 ```vb Dim Aes As New cAes ' 通过 CBC 属性访问加密功能 Dim result As String result = Aes.CBC.Encode("Hello World") ``` *** ## 🔐 cAesCBC.Encode 方法 ### 说明 使用 AES CBC 模式加密字符串数据。 ### 语法 ```vb Public Function Encode(Data As Variant, Optional ByVal Password As String = "nzgi2g9gi7odbvxw") As String ``` ### 参数 | 参数 | 类型 | 说明 | |------|------|------| | `Data` | Variant | 要加密的数据（会被转换为字符串） | | `Password` | String | 可选，加密密码（默认使用内置密钥） | ### 返回值 String - 加密后的字符串（格式取决于 JavaScript 实现，通常是 Base64 或 Hex） ### 使用示例 #### 使用默认密码 ```vb Dim Aes As New cAes Dim encrypted As String ' 使用默认内置密码加密 encrypted = Aes.CBC.Encode("Hello World") Debug.Print "加密结果: " & encrypted ``` #### 使用自定义密码 ```vb Dim Aes As New cAes Dim encrypted As String ' 使用自定义密码加密 encrypted = Aes.CBC.Encode("敏感数据", "my-secret-key-123") Debug.Print "加密结果: " & encrypted ``` #### 加密变量数据 ```vb Dim Aes As New cAes Dim userInput As String Dim encrypted As String userInput = InputBox("请输入要加密的内容:") encrypted = Aes.CBC.Encode(userInput, "password") ' 保存或传输加密后的数据 SaveToFile encrypted ``` ### ⚠️ 注意事项 1. **默认密码**：如果不提供密码，将使用内置默认密码 `"nzgi2g9gi7odbvxw"` 2. **资源依赖**：此方法依赖资源文件中的 `AES.CBC` JavaScript 代码 3. **线程安全**：MSHTML 实例在类初始化时创建，每个 `cAesCBC` 实例独立 *** ## 📌 使用场景总结 ### 敏感数据加密 ```vb Private Sub EncryptSensitiveData() Dim Aes As New cAes Dim sensitiveData As String Dim encrypted As String ' 获取敏感数据 sensitiveData = txtPassword.Text ' 加密 encrypted = Aes.CBC.Encode(sensitiveData, "my-app-secret") ' 保存加密后的数据 SaveEncryptedData encrypted End Sub ``` ### 配置文件加密 ```vb Private Sub SaveConfigEncrypted() Dim Aes As New cAes Dim config As String Dim encryptedConfig As String ' 构建配置字符串 config = "API_KEY=xxx|SECRET=yyy" ' 加密配置 encryptedConfig = Aes.CBC.Encode(config, "config-password") ' 写入配置文件 WriteConfigFile encryptedConfig End Sub ``` *** **最后更新**: 2026-05-17 --- --- url: /zh/vbman/crypt/aes/overview.md --- # AES 加密组件概述 ## 📖 简介 AES 加密组件提供了基于 JavaScript AES-CBC 实现的对称加密功能。通过 MSHTML 控件调用 JavaScript 加密函数实现。 ## 🏗️ 架构 ``` cAes (主入口) └── cAesCBC (CBC 模式实现) └── MSHTML.HTMLDocument └── JavaScript AES 加密函数 ``` ## ⚙️ 工作原理 组件通过加载资源文件中的 JavaScript 代码（`AES.CBC` 资源），在 MSHTML 环境中执行加密操作。 **依赖要求**： * 需要包含 AES JavaScript 代码的资源文件 * 依赖 MSHTML 控件 ## ✨ 特性 | 特性 | 说明 | |------|------| | **CBC 模式** | 使用 CBC 模式进行加密 | | **密码派生** | 从密码字符串派生加密密钥 | | **字符串加密** | 直接对字符串进行加密 | ## 🚀 快速开始 ### 基本使用 ```vb Dim Aes As New cAes ' 加密文本（使用默认密码） Dim encrypted As String encrypted = Aes.CBC.Encode("Hello World") ' 使用自定义密码加密 encrypted = Aes.CBC.Encode("Hello World", "my-secret-password") ``` ### 完整示例 ```vb Private Sub TestAes() Dim Aes As New cAes Dim plainText As String Dim cipherText As String plainText = "需要加密的敏感数据" ' 加密 cipherText = Aes.CBC.Encode(plainText, "my-password-1234") Debug.Print "加密结果: " & cipherText ' 注意：解密需要通过对应的 JavaScript decryptFn 函数实现 End Sub ``` ## ⚠️ 注意事项 1. **资源依赖**：组件依赖 `AES.CBC` JavaScript 资源，需要正确配置资源文件 2. **密码长度**：建议使用 16 字节长度的密码 3. **解密实现**：当前组件仅提供加密功能，解密需要在 JavaScript 端实现 ## 🔗 相关文档 * [methods.md](./methods.md) - 方法详细参考 *** **最后更新**: 2026-05-17 --- --- url: /en/vbman/crypt/aes/overview.md --- # AES Encryption Component Overview ## 📖 Introduction The AES encryption component provides symmetric encryption functionality based on JavaScript AES-CBC implementation. Encryption is performed via MSHTML control calling JavaScript encryption functions. ## 🏗️ Architecture ``` cAes (main entry) └── cAesCBC (CBC mode implementation) └── MSHTML.HTMLDocument └── JavaScript AES encryption functions ``` ## ⚙️ How It Works The component loads JavaScript code from resource files (`AES.CBC` resource) and executes encryption operations in the MSHTML environment. **Dependencies:** * Requires AES JavaScript code resource file * Depends on MSHTML control ## ✨ Features | Feature | Description | |---------|-------------| | **CBC Mode** | Uses CBC mode for encryption | | **Key Derivation** | Derives encryption key from password string | | **String Encryption** | Directly encrypts strings | ## 🚀 Quick Start ### Basic Usage ```vb Dim Aes As New cAes ' Encrypt text (using default password) Dim encrypted As String encrypted = Aes.CBC.Encode("Hello World") ' Encrypt with custom password encrypted = Aes.CBC.Encode("Hello World", "my-secret-password") ``` ### Complete Example ```vb Private Sub TestAes() Dim Aes As New cAes Dim plainText As String Dim cipherText As String plainText = "Sensitive data to encrypt" ' Encrypt cipherText = Aes.CBC.Encode(plainText, "my-password-1234") Debug.Print "Encrypted: " & cipherText ' Note: Decryption needs to be implemented via JavaScript decryptFn function End Sub ``` ## ⚠️ Notes 1. **Resource Dependency**: Component depends on `AES.CBC` JavaScript resource, resource files must be properly configured 2. **Password Length**: 16-byte password is recommended 3. **Decryption**: Current component only provides encryption; decryption needs to be implemented on the JavaScript side ## 🔗 Related Documentation * [methods.md](./methods.md) - Methods detailed reference *** **Last Updated**: 2026-05-17 --- --- url: /en/vbman/crypt/aes/methods.md --- # AES Encryption Methods Reference ## 📋 Method List | Class | Method | Description | |-------|--------|-------------| | `cAes` | `CBC` | Access CBC encryption instance | | `cAesCBC` | `Encode` | Encrypt string data | *** ## 🔌 cAes.CBC Property ### Description Accesses the `cAesCBC` instance, which is the main entry point for AES CBC encryption. ### Syntax ```vb Public CBC As New cAesCBC ``` ### Example ```vb Dim Aes As New cAes ' Access encryption functionality through CBC property Dim result As String result = Aes.CBC.Encode("Hello World") ``` *** ## 🔐 cAesCBC.Encode Method ### Description Encrypts string data using AES CBC mode. ### Syntax ```vb Public Function Encode(Data As Variant, Optional ByVal Password As String = "nzgi2g9gi7odbvxw") As String ``` ### Parameters | Parameter | Type | Description | |-----------|------|-------------| | `Data` | Variant | Data to encrypt (will be converted to string) | | `Password` | String | Optional, encryption password (default uses built-in key) | ### Return Value String - Encrypted string (format depends on JavaScript implementation, usually Base64 or Hex) ### Example #### Using Default Password ```vb Dim Aes As New cAes Dim encrypted As String ' Encrypt using default built-in password encrypted = Aes.CBC.Encode("Hello World") Debug.Print "Encrypted: " & encrypted ``` #### Using Custom Password ```vb Dim Aes As New cAes Dim encrypted As String ' Encrypt with custom password encrypted = Aes.CBC.Encode("Sensitive data", "my-secret-key-123") Debug.Print "Encrypted: " & encrypted ``` #### Encrypting Variable Data ```vb Dim Aes As New cAes Dim userInput As String Dim encrypted As String userInput = InputBox("Enter content to encrypt:") encrypted = Aes.CBC.Encode(userInput, "password") ' Save or transmit encrypted data SaveToFile encrypted ``` ### ⚠️ Notes 1. **Default Password**: If no password is provided, the built-in default password `"nzgi2g9gi7odbvxw"` is used 2. **Resource Dependency**: This method depends on `AES.CBC` JavaScript code in resource files 3. **Thread Safety**: MSHTML instance is created during class initialization, each `cAesCBC` instance is independent *** ## 📌 Usage Scenarios Summary ### Sensitive Data Encryption ```vb Private Sub EncryptSensitiveData() Dim Aes As New cAes Dim sensitiveData As String Dim encrypted As String ' Get sensitive data sensitiveData = txtPassword.Text ' Encrypt encrypted = Aes.CBC.Encode(sensitiveData, "my-app-secret") ' Save encrypted data SaveEncryptedData encrypted End Sub ``` ### Configuration File Encryption ```vb Private Sub SaveConfigEncrypted() Dim Aes As New cAes Dim config As String Dim encryptedConfig As String ' Build configuration string config = "API_KEY=xxx|SECRET=yyy" ' Encrypt configuration encryptedConfig = Aes.CBC.Encode(config, "config-password") ' Write to configuration file WriteConfigFile encryptedConfig End Sub ``` *** **Last Updated**: 2026-05-17 --- --- url: /en/packages/vbccr/ranges/animation.md description: >- Animation Control - VBCCR Development Manual, complete API reference based on source code --- # Animation Control Wraps the SysAnimate32 system animation control for playing silent AVI animations. ## Enumerations ### CCBackStyleConstants See common enumerations. ## Properties ### AutoPlay ```vb Property Get AutoPlay() As Boolean Property Let AutoPlay(ByVal Value As Boolean) ``` Auto play; starts playing immediately after the control is created. ### BackStyle ```vb Property Get BackStyle() As CCBackStyleConstants Property Let BackStyle(ByVal Value As CCBackStyleConstants) ``` Background style, transparent or opaque. ### Center ```vb Property Get Center() As Boolean Property Let Center(ByVal Value As Boolean) ``` Whether to center the AVI animation display. ### RightToLeft ```vb Property Get RightToLeft() As Boolean Property Let RightToLeft(ByVal Value As Boolean) ``` Right-to-left display direction. ### RightToLeftLayout ```vb Property Get RightToLeftLayout() As Boolean Property Let RightToLeftLayout(ByVal Value As Boolean) ``` Right-to-left mirrored layout. ### RightToLeftMode ```vb Property Get RightToLeftMode() As CCRightToLeftModeConstants Property Let RightToLeftMode(ByVal Value As CCRightToLeftModeConstants) ``` Right-to-left mode. See common enumerations. ### hWnd ```vb Property Get hWnd() As LongPtr ``` Window handle of the animation control. ### hWndUserControl ```vb Property Get hWndUserControl() As LongPtr ``` Window handle of the user control. ### Font ```vb Property Get Font() As StdFont Property Let Font(ByVal NewFont As StdFont) Property Set Font(ByVal NewFont As StdFont) ``` Font. ### Enabled ```vb Property Get Enabled() As Boolean Property Let Enabled(ByVal Value As Boolean) ``` Whether the control is enabled. ### MousePointer ```vb Property Get MousePointer() As CCMousePointerConstants Property Let MousePointer(ByVal Value As CCMousePointerConstants) ``` Mouse pointer style. See common enumerations. ### MouseIcon ```vb Property Get MouseIcon() As IPictureDisp Property Let MouseIcon(ByVal Value As IPictureDisp) Property Set MouseIcon(ByVal Value As IPictureDisp) ``` Custom mouse icon. ### MouseTrack ```vb Property Get MouseTrack() As Boolean Property Let MouseTrack(ByVal Value As Boolean) ``` Whether to enable mouse enter/leave tracking. ### Playing ```vb Property Get Playing() As Boolean ``` Whether the animation is currently playing. Read-only. ### Name ```vb Property Get Name() As String ``` Control name. Read-only. ### Tag ```vb Property Get Tag() As String Property Let Tag(ByVal Value As String) ``` Custom data. ### Parent ```vb Property Get Parent() As Object ``` Parent object. Read-only. ### Container ```vb Property Get Container() As Object Property Set Container(ByVal Value As Object) ``` Container object. ### Left ```vb Property Get Left() As Single Property Let Left(ByVal Value As Single) ``` Left position. ### Top ```vb Property Get Top() As Single Property Let Top(ByVal Value As Single) ``` Top position. ### Width ```vb Property Get Width() As Single Property Let Width(ByVal Value As Single) ``` Width. ### Height ```vb Property Get Height() As Single Property Let Height(ByVal Value As Single) ``` Height. ### Visible ```vb Property Get Visible() As Boolean Property Let Visible(ByVal Value As Boolean) ``` Whether the control is visible. ### ToolTipText ```vb Property Get ToolTipText() As String Property Let ToolTipText(ByVal Value As String) ``` Tooltip text. ### HelpContextID ```vb Property Get HelpContextID() As Long Property Let HelpContextID(ByVal Value As Long) ``` Help context ID. ### WhatsThisHelpID ```vb Property Get WhatsThisHelpID() As Long Property Let WhatsThisHelpID(ByVal Value As Long) ``` "What's This" help ID. ### DragIcon ```vb Property Get DragIcon() As IPictureDisp Property Let DragIcon(ByVal Value As IPictureDisp) Property Set DragIcon(ByVal Value As IPictureDisp) ``` Drag icon. ### DragMode ```vb Property Get DragMode() As Integer Property Let DragMode(ByVal Value As Integer) ``` Drag mode. ## Methods ### Play ```vb Public Sub Play(Optional ByVal FromFrame As Variant, Optional ByVal ToFrame As Variant, Optional ByVal RepeatCount As Variant) ``` Plays the animation. Can specify the start frame, end frame, and repeat count. ### StopPlay ```vb Public Sub StopPlay() ``` Stops playing the animation. ### LoadFile ```vb Public Sub LoadFile(ByVal PathName As String) ``` Loads an AVI animation from a file. ### LoadRes ```vb Public Sub LoadRes(ByVal ResourceID As Variant) ``` Loads an AVI animation from a resource. Supports string or numeric resource IDs. ### Unload ```vb Public Sub Unload() ``` Unloads the current animation. ### Refresh ```vb Public Sub Refresh() ``` Forces the control to repaint. ### OLEDrag ```vb Public Sub OLEDrag() ``` Initiates an OLE drag-and-drop operation. ### Drag ```vb Public Sub Drag(Optional ByRef Action As Variant) ``` Starts, ends, or cancels a drag operation. ### ZOrder ```vb Public Sub ZOrder(Optional ByRef Position As Variant) ``` Adjusts the Z-order. ### SetFocus ```vb Public Sub SetFocus() ``` Sets focus. ### Move ```vb Public Sub Move(ByVal Left As Single, Optional ByVal Top As Variant, Optional ByVal Width As Variant, Optional ByVal Height As Variant) ``` Moves and resizes the control. ## Events ### Click ```vb Public Event Click() ``` Click. ### DblClick ```vb Public Event DblClick() ``` Double-click. ### Change ```vb Public Event Change() ``` Fired when the animation state changes. ### PreviewKeyDown ```vb Public Event PreviewKeyDown(KeyCode As Integer, Shift As Integer) ``` Preview key event, fired before KeyDown. ### PreviewKeyUp ```vb Public Event PreviewKeyUp(KeyCode As Integer, Shift As Integer) ``` Preview key up event, fired before KeyUp. ### KeyDown ```vb Public Event KeyDown(KeyCode As Integer, Shift As Integer) ``` Key pressed. ### KeyUp ```vb Public Event KeyUp(KeyCode As Integer, Shift As Integer) ``` Key released. ### KeyPress ```vb Public Event KeyPress(KeyAscii As Integer) ``` Key character. ### MouseDown ```vb Public Event MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` Mouse button pressed. ### MouseMove ```vb Public Event MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` Mouse moved. ### MouseUp ```vb Public Event MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` Mouse button released. ### MouseEnter ```vb Public Event MouseEnter() ``` Mouse entered the control. ### MouseLeave ```vb Public Event MouseLeave() ``` Mouse left the control. ### OLECompleteDrag ```vb Public Event OLECompleteDrag(Effect As Long) ``` OLE drag-and-drop completed. ### OLEDragDrop ```vb Public Event OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single) ``` OLE drag-and-drop drop. ### OLEDragOver ```vb Public Event OLEDragOver(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single, State As Integer) ``` OLE drag-and-drop hover. ### OLEGiveFeedback ```vb Public Event OLEGiveFeedback(Effect As Long, DefaultCursors As Boolean) ``` OLE give feedback. ### OLESetData ```vb Public Event OLESetData(Data As DataObject, DataFormat As Integer) ``` OLE set data. ### OLEStartDrag ```vb Public Event OLEStartDrag(Data As DataObject, AllowedEffects As Long) ``` OLE start drag. ## Code Examples ### Basic Usage ```vb ' Load and play an AVI animation Animation1.LoadFile "C:\Icons\filecopy.avi" Animation1.AutoPlay = True ' Play from frame 5 to frame 20, repeat 3 times Animation1.Play 5, 20, 3 ' Stop playing Animation1.StopPlay ' Load from resource Animation1.LoadRes 101 ' Unload animation Animation1.Unload ``` --- --- url: /zh/vbman/Toast/api.md --- # API 参考 本文档详细说明 cToast 类的所有公共方法、属性和事件。 ## 目录 * [枚举定义](#枚举定义) * [公共方法](#公共方法) * [链式调用方法](#链式调用方法) * [管理方法](#管理方法) * [属性](#属性) * [事件](#事件) *** ## 枚举定义 ### EnumPos - 显示位置枚举 ```vb Public Enum EnumPos LeftTop = 10 ' 左上（堆叠） LeftCenter = 12 ' 左中（覆盖） LeftBottom = 14 ' 左下（堆叠） CenterTop = 20 ' 居上（顺序堆叠） Center = 22 ' 居中（覆盖） CenterBottom = 24 ' 居下（倒序堆叠） RightTop = 30 ' 右上（堆叠） RightCenter = 32 ' 右中（覆盖） RightBottom = 34 ' 右下（堆叠） End Enum ``` **说明：** * **堆叠位置**：支持多个弹窗依次堆叠显示（LeftTop/LeftBottom/CenterTop/CenterBottom/RightTop/RightBottom） * **覆盖位置**：新弹窗会覆盖旧弹窗（Center/LeftCenter/RightCenter） *** ### EnumTheme - 颜色主题枚举 ```vb Public Enum EnumTheme Light = 1 ' 浅色主题（默认） Dark = 2 ' 深色主题 End Enum ``` **说明：** * **Light**：系统背景色 + 深色文字 * **Dark**：深灰色背景（RGB(45, 45, 48)） + 浅色文字 *** ### EnumState - 状态主题枚举 ```vb Public Enum EnumState Info = 1 ' 信息（蓝色） Success = 2 ' 成功（绿色） Warning = 3 ' 警告（黄色） Danger = 4 ' 危险（红色） End Enum ``` **颜色值：** * **Info**：\&HC58B36（蓝色） * **Success**：\&HC000&（绿色） * **Warning**：\&HC0C0&（黄色） * **Danger**：\&HC0&（红色） *** ## 公共方法 ### 链式调用方法 #### Pos(p As EnumPos) As cToast 设置弹窗显示位置。 **参数：** * `p` - 显示位置枚举值 **返回：** `cToast` 对象本身，支持链式调用 **示例：** ```vb Toast.Pos(RightTop).Show "右上角显示" ``` **注意事项：** * 必须在 `Show` 之前调用 * 默认值为 `Center` *** #### State(s As EnumState) As cToast 设置弹窗状态主题。 **参数：** * `s` - 状态枚举值（Info/Success/Warning/Danger） **返回：** `cToast` 对象本身，支持链式调用 **示例：** ```vb Toast.State(Success).Show "操作成功！" ``` **注意事项：** * 必须在 `Show` 之前调用 * 默认值为 `Info` *** #### Theme(t As EnumTheme) As cToast 设置弹窗颜色主题。 **参数：** * `t` - 主题枚举值（Light/Dark） **返回：** `cToast` 对象本身，支持链式调用 **示例：** ```vb Toast.Theme(Dark).Show "深色主题提示" ``` **注意事项：** * 必须在 `Show` 之前调用 * 默认值为 `Light` *** #### InstIndex(i As Long) As cToast 设置堆叠索引，用于手动控制堆叠顺序。 **参数：** * `i` - 堆叠索引（从0开始） **返回：** `cToast` 对象本身，支持链式调用 **堆叠规则：** | 位置类型 | 堆叠规则 | 说明 | |---------|---------|------| | 顶部位置（LeftTop/RightTop/CenterTop） | 顺序堆叠 | i=0 在最上方，依次向下 | | 底部位置（LeftBottom/RightBottom/CenterBottom） | 倒序堆叠 | i=1 在最下方，依次向上 | | 居中/覆盖位置（Center/LeftCenter/RightCenter） | 不支持 | 调用无效，直接返回 | **示例：** ```vb ' 手动指定堆叠位置 Toast.Pos(RightTop).InstIndex(2).Show "第3条消息", 0 ' 倒序堆叠（底部） Toast.Pos(RightBottom).InstIndex(1).Show "最底部消息", 0 Toast.Pos(RightBottom).InstIndex(2).Show "倒数第二条", 0 ``` **注意事项：** * 必须在 `Pos` 之后、`Show` 之前调用 * 居中/覆盖位置调用无效 * 如果用户未手动调用此方法，系统会自动堆叠 *** #### Tag(Name As String) As cToast 为弹窗指定标识名称，用于后续管理。 **参数：** * `Name` - 标识名称字符串 **返回：** `cToast` 对象本身，支持链式调用 **说明：** * 如果不调用此方法，显示时将自动生成8位随机名称 * 相同名称的弹窗不会重复创建，第二次调用会直接退出 * 名称用于 `CloseMe`、`Exists` 等方法的参数 **示例：** ```vb Toast.Tag("msg1").Pos(RightTop).Show "第一条消息", 0 Toast.Tag("msg2").Pos(RightTop).Show "第二条消息", 0 ' 单独关闭 Toast.CloseMe "msg1" ``` **注意事项：** * 必须在 `Show` 之前调用 * 建议使用有意义的名称便于管理 *** #### Show(Content As String, \[Delay As Long = 3000], \[Title As String = "提示"]) As cToast 显示弹窗，这是核心方法。 **参数：** * `Content` - 弹窗内容（必填） * `Delay` - 延时自动关闭时间，毫秒（可选，默认3000ms，设为0表示持久显示） * `Title` - 弹窗标题（可选，默认"提示"） **返回：** `cToast` 对象本身，支持链式调用 **自动堆叠管理：** * 如果用户未手动调用 `InstIndex`，且当前方位集合已有实例，则自动调用 `InstIndex(CollX.Count)` 实现自动堆叠 **示例：** ```vb ' 基础用法 Toast.Show "操作成功", 3000, "提示" ' 链式调用 Toast.Pos(Center).State(Success).Show "保存成功", 2000 ' 持久显示（不自动关闭） Toast.Tag("notification").Pos(RightBottom).Show "重要通知", 0 ' 空标题（不显示标题） Toast.Show "无标题提示", 3000, "" ``` **注意事项：** * `Delay` 参数在 FToastCenter 中是必填的，在 cToast 中有默认值3000 * `Delay = 0` 表示持久显示，不会自动关闭 * 每次调用 `Show` 后，`m_State`、`m_Theme`、`m_Index`、`m_Tag` 会重置为默认值，但 `m_Pos` 会保留 *** ### 管理方法 #### CloseMe(Name As String) As Boolean 关闭指定名称的弹窗。 **参数：** * `Name` - 要关闭的弹窗名称 **返回：** 成功返回 `True`，失败返回 `False` **说明：** * 遍历所有9个方位集合查找指定名称的弹窗 * 找到后调用窗体的 `CloseMe` 方法并从集合中移除 * 触发 `OnToastCountChange` 事件 **示例：** ```vb Dim result As Boolean result = Toast.CloseMe("msg1") If result Then Debug.Print "弹窗已关闭" Else Debug.Print "弹窗不存在或已关闭" End If ``` **注意事项：** * 如果弹窗已经自动关闭（Timer到期），返回 `False` * 如果弹窗不存在，返回 `False` *** #### CloseAll() As Boolean 关闭所有当前弹窗。 **返回：** 成功返回 `True` **说明：** * 遍历所有9个方位集合，逐个关闭所有弹窗 * 清空所有集合 * 触发一次 `OnCloseAll` 事件（而不是多次 `OnToastCountChange`） **示例：** ```vb ' 关闭所有弹窗 Toast.CloseAll ' 检查关闭数量 If Toast.CloseAll Then Debug.Print "所有弹窗已关闭" End If ``` **注意事项：** * 如果没有弹窗，也会返回 `True` * 会触发 `OnCloseAll` 事件，参数为关闭前的弹窗数量 *** #### Exists(Name As String) As Boolean 检查指定名称的弹窗是否存在。 **参数：** * `Name` - 要检查的弹窗名称 **返回：** 存在返回 `True`，否则返回 `False` **说明：** * 遍历所有9个方位集合查找指定名称的弹窗 * 用于判断弹窗是否还在显示 **示例：** ```vb If Toast.Exists("msg1") Then Debug.Print "弹窗正在显示" Else Debug.Print "弹窗不存在或已关闭" End If ' 重复创建检查 If Not Toast.Exists("msg1") Then Toast.Tag("msg1").Pos(RightTop).Show "新消息", 0 End If ``` **注意事项：** * 如果弹窗自动关闭（Timer到期），返回 `False` * 此方法不会触发任何事件 *** ## 属性 #### Count As Long（只读属性） 返回所有活动弹窗的总数（9个方位集合的合计）。 **返回值：** 当前活动弹窗数量 **说明：** * 统计所有9个方位集合的实例数量总和 * 实时反映当前显示的弹窗数量 **示例：** ```vb Debug.Print "当前活动弹窗数量: " & Toast.Count ' 检查是否还有弹窗 If Toast.Count > 0 Then Debug.Print "还有 " & Toast.Count & " 个弹窗未关闭" End If ``` *** #### ActiveKeys As Collection（只读属性） 返回包含所有活动弹窗名称（TagName）的集合。 **返回值：** 包含所有 TagName 的 Collection 对象 **说明：** * 返回的集合可用于遍历或显示列表 * 集合中的元素类型为 String，即每个弹窗的 TagName * 集合内容是只读的，不应直接修改 **示例：** ```vb Dim Keys As Collection Dim Key As Variant Set Keys = Toast.ActiveKeys ' 遍历所有弹窗 For Each Key In Keys Debug.Print "活动弹窗: " & Key Next Key ' 获取弹窗数量 Debug.Print "活动弹窗数: " & Keys.Count ' 添加到列表框 lstToasts.Clear For Each Key In Keys lstToasts.AddItem CStr(Key) Next Key ``` **注意事项：** * 集合元素是 TagName，不是弹窗对象本身 * 如果弹窗被关闭，集合会自动更新 *** ## 事件 ### OnToastCountChange 事件 当单个弹窗数量发生变化时触发（新增或删除）。 **事件签名：** ```vb Public Event OnToastCountChange(ByVal TagName As String, ByVal IsDelete As Boolean, ByVal CurrentCount As Long) ``` **参数：** * `TagName` - 变化的弹窗名称 * `IsDelete` - `True` 表示弹窗被删除，`False` 表示新增 * `CurrentCount` - 当前活动弹窗总数 **触发时机：** * 调用 `Show` 创建新弹窗时 * 调用 `CloseMe` 关闭弹窗时 * 窗体自然关闭（Timer到期）时 * 窗体卸载时 **不触发时机：** * 调用 `CloseAll` 时（触发 `OnCloseAll` 事件） **使用示例：** ```vb Private WithEvents Toast As cToast Private Sub Form_Load() Set Toast = New cToast End Sub Private Sub Toast_OnToastCountChange(ByVal TagName As String, ByVal IsDelete As Boolean, ByVal CurrentCount As Long) ' 更新UI显示 lblCount.Caption = "当前活动弹窗: " & CurrentCount ' 记录日志 If IsDelete Then Debug.Print "弹窗 [" & TagName & "] 已关闭" Else Debug.Print "弹窗 [" & TagName & "] 已创建" End If ' 刷新列表 RefreshList End Sub ``` **注意事项：** * 需要使用 `WithEvents` 声明变量 * 每次单个弹窗创建或关闭都会触发 * 不适用于批量操作（如 CloseAll） *** ### OnCloseAll 事件 当调用 `CloseAll()` 批量关闭所有弹窗后触发（只触发一次）。 **事件签名：** ```vb Public Event OnCloseAll(ByVal ClosedCount As Long) ``` **参数：** * `ClosedCount` - 本次批量关闭的弹窗数量 **触发时机：** * 调用 `CloseAll()` 方法后 * 类的 `Class_Terminate` 时调用 `CloseAll` **不触发时机：** * 调用 `CloseMe` 单独关闭弹窗时 * 窗体自然关闭时 **使用示例：** ```vb Private WithEvents Toast As cToast Private Sub Form_Load() Set Toast = New cToast End Sub Private Sub btnCloseAll_Click() Toast.CloseAll End Sub Private Sub Toast_OnCloseAll(ByVal ClosedCount As Long) ' 批量关闭完成后刷新UI（只触发一次） RefreshList ' 显示提示 MsgBox "已关闭 " & ClosedCount & " 个弹窗", vbInformation ' 记录日志 Debug.Print "批量关闭了 " & ClosedCount & " 个弹窗" End Sub ``` **注意事项：** * 需要使用 `WithEvents` 声明变量 * 只触发一次，不会为每个弹窗触发 `OnToastCountChange` * 如果没有弹窗，也会触发，参数为0 *** ## 事件对比 | 事件 | 触发时机 | 触发频率 | 使用场景 | |------|----------|----------|----------| | `OnToastCountChange` | 单个弹窗新增/删除 | 每次变化一次 | 实时更新UI状态 | | `OnCloseAll` | `CloseAll()` 完成后 | 批量操作一次 | 批量操作后一次性刷新 | *** ## 方法调用顺序建议 ### 创建弹窗的推荐顺序 ```vb 1. 创建 cToast 实例 Set Toast = New cToast 2. 设置位置（可选，默认 Center） Toast.Pos(RightTop) 3. 设置状态（可选，默认 Info） Toast.State(Success) 4. 设置主题（可选，默认 Light） Toast.Theme(Dark) 5. 设置标签（可选，自动生成随机名） Toast.Tag("msg1") 6. 设置堆叠索引（可选，自动堆叠） Toast.InstIndex(0) 7. 显示弹窗 Toast.Show "消息内容", 3000, "标题" ``` ### 简化写法（链式调用） ```vb With New cToast .Pos(RightTop).State(Success).Theme(Dark).Tag("msg1").InstIndex(0).Show "消息", 3000 End With ``` ### 更简洁的写法（使用默认值） ```vb With New cToast .Show "消息" End With ``` *** ## 错误处理 cToast 类本身不会抛出异常，但以下情况需要注意： 1. **重复的 TagName**：不会报错，但第二次调用不会创建新弹窗 2. **不存在的弹窗**：`CloseMe` 和 `Exists` 返回 `False`，不会报错 3. **无效的 InstIndex**：居中/覆盖位置调用无效，但不会报错 4. **空的 Content**：允许，但显示为空提示 *** ## 相关方法索引 ### 按功能分类 **显示控制：** * `Show` - 显示弹窗 * `CloseMe` - 关闭指定弹窗 * `CloseAll` - 关闭所有弹窗 **外观设置：** * `Pos` - 设置位置 * `State` - 设置状态 * `Theme` - 设置主题 **高级设置：** * `InstIndex` - 设置堆叠索引 * `Tag` - 设置标签 **查询统计：** * `Exists` - 检查弹窗是否存在 * `Count` - 获取弹窗总数 * `ActiveKeys` - 获取所有弹窗名称 **事件：** * `OnToastCountChange` - 数量变化事件 * `OnCloseAll` - 批量关闭事件 --- --- url: /en/vbman/Toast/api.md --- # API Reference Complete API documentation for cToast class. ## Table of Contents * [Enumerations](#enumerations) * [Chain Call Methods](#chain-call-methods) * [Management Methods](#management-methods) * [Properties](#properties) * [Events](#events) * [Method Call Order](#method-call-order) * [Error Handling](#error-handling) ## Enumerations ### EnumPos - Display Positions ```vb Public Enum EnumPos LeftTop = 0 ' Top-left (stacking) LeftCenter = 1 ' Left-center (overlay) LeftBottom = 2 ' Bottom-left (stacking) CenterTop = 3 ' Top-center (sequential stacking) Center = 4 ' Center (overlay) CenterBottom = 5 ' Bottom-center (reverse stacking) RightTop = 6 ' Top-right (stacking) RightCenter = 7 ' Right-center (overlay) RightBottom = 8 ' Bottom-right (stacking) End Enum ``` **Description**: Defines 9 display positions for the popup. **Stacking Behavior**: * **Center positions (Center, LeftCenter, RightCenter)**: Only one popup can exist, new ones overlay old ones * **Top positions (CenterTop, LeftTop, RightTop)**: Sequential stacking, newest at the bottom * **Bottom positions (CenterBottom, LeftBottom, RightBottom)**: Reverse stacking, newest at the top ### EnumTheme - Color Themes ```vb Public Enum EnumTheme Light = 0 ' Light theme (default) Dark = 1 ' Dark theme End Enum ``` **Description**: Defines color themes for the popup. **Features**: * Light theme: White background, suitable for light interface * Dark theme: Dark background, suitable for dark interface ### EnumState - State Themes ```vb Public Enum EnumState Info = 0 ' Information (blue) Success = 1 ' Success (green) Warning = 2 ' Warning (yellow) Danger = 3 ' Danger (red) End Enum ``` **Description**: Defines state themes that control color and icon. **State Colors**: * Info: Blue (#007BFF), information prompts * Success: Green (#28A745), success messages * Warning: Yellow (#FFC107), warning messages * Danger: Red (#DC3545), error messages ## Chain Call Methods All chain call methods return `Me` to support chained calling. ### Pos ```vb Public Function Pos(ByVal ePos As EnumPos) As cToast ``` **Parameters**: * `ePos`: Display position enumeration value **Return Value**: Returns `Me` to support chained calling **Description**: Sets the display position of the popup. Must be called before `Show`. **Example**: ```vb With New cToast .Pos(RightTop).Show "Message", 2000, "Title" End With ``` ### State ```vb Public Function State(ByVal eState As EnumState) As cToast ``` **Parameters**: * `eState`: State enumeration value **Return Value**: Returns `Me` to support chained calling **Description**: Sets the state theme of the popup, controlling color and icon. **Example**: ```vb With New cToast .State(Success).Show "Success", 2000 End With ``` ### Theme ```vb Public Function Theme(ByVal eTheme As EnumTheme) As cToast ``` **Parameters**: * `eTheme`: Theme enumeration value **Return Value**: Returns `Me` to support chained calling **Description**: Sets the color theme of the popup. **Example**: ```vb With New cToast .Theme(Dark).Show "Dark theme message", 2000 End With ``` ### InstIndex ```vb Public Function InstIndex(ByVal Index As Long) As cToast ``` **Parameters**: * `Index`: Stack index, starting from 0 **Return Value**: Returns `Me` to support chained calling **Description**: Manually sets the stacking index of the popup. **Note**: * Center positions (Center, LeftCenter, RightCenter) do not support stacking, calling this method has no effect * If not called, the system will automatically calculate and assign an index **Example**: ```vb With New cToast .Pos(RightTop).InstIndex(0).Show "First message", 0 End With ``` ### Tag ```vb Public Function Tag(ByVal TagName As String) As cToast ``` **Parameters**: * `TagName`: Unique identifier string **Return Value**: Returns `Me` to support chained calling **Description**: Sets a unique identifier for the popup, used for management and closing. **Note**: * Popups with the same TagName will not be created repeatedly * Used in conjunction with `CloseMe` to close specific popups **Example**: ```vb With New cToast .Tag("msg1").Show "Message 1", 0 End With ' Close by name Toast.CloseMe "msg1" ``` ### Show ```vb Public Sub Show(Optional ByVal Content As String = "", _ Optional ByVal DelayMs As Long = 3000, _ Optional ByVal Title As String = "") ``` **Parameters**: * `Content`: Popup content text * `DelayMs`: Display duration in milliseconds, 0 means no auto-close * `Title`: Popup title text **Description**: Displays the popup. **Example**: ```vb With New cToast .Pos(RightTop).State(Success).Show "Operation successful", 2000, "Notification" End With ``` ## Management Methods ### CloseMe ```vb Public Function CloseMe(ByVal TagName As String) As Boolean ``` **Parameters**: * `TagName`: The unique identifier of the popup to close **Return Value**: * `True`: Successfully closed * `False`: Popup does not exist or failed to close **Description**: Closes the popup with the specified TagName. **Example**: ```vb Dim Toast As New cToast Toast.Tag("warning1").Show "Warning", 0 ' Later close Toast.CloseMe "warning1" ``` ### CloseAll ```vb Public Sub CloseAll() ``` **Description**: Closes all currently displayed popups. **Example**: ```vb Dim Toast As New cToast ' Display multiple popups Toast.State(Info).Show "Message 1", 0 Toast.State(Warning).Show "Message 2", 0 ' Close all at once Toast.CloseAll ``` ### Exists ```vb Public Function Exists(ByVal TagName As String) As Boolean ``` **Parameters**: * `TagName`: Unique identifier string **Return Value**: * `True`: Popup exists * `False`: Popup does not exist **Description**: Checks if a popup with the specified TagName exists. **Example**: ```vb If Toast.Exists("warning1") Then Toast.CloseMe "warning1" End If ``` ## Properties ### Count ```vb Public Property Get Count() As Long ``` **Return Value**: Current number of active popups **Description**: Gets the total number of currently displayed popups. **Example**: ```vb Debug.Print "Current popups: " & Toast.Count ``` ### ActiveKeys ```vb Public Property Get ActiveKeys() As Collection ``` **Return Value**: Collection containing all active popup TagNames **Description**: Gets a collection of all currently active popup TagNames. **Example**: ```vb Dim Keys As Collection Dim Key As Variant Set Keys = Toast.ActiveKeys For Each Key In Keys Debug.Print "Active popup: " & CStr(Key) Next Key ``` ## Events ### OnToastCountChange ```vb Public Event OnToastCountChange(ByVal TagName As String, _ ByVal IsDelete As Boolean, _ ByVal CurrentCount As Long) ``` **Parameters**: * `TagName`: The TagName of the popup that changed * `IsDelete`: Whether it was a delete operation (True=deleted, False=added) * `CurrentCount`: Current total number of popups **Description**: Triggered when the number of popups changes (add or delete). **Usage Scenario**: * Update UI list * Display current count statistics * Trigger other business logic **Example**: ```vb Private WithEvents Toast As cToast Private Sub Toast_OnToastCountChange(ByVal TagName As String, _ ByVal IsDelete As Boolean, _ ByVal CurrentCount As Long) If IsDelete Then Debug.Print "Popup " & TagName & " was closed" Else Debug.Print "Popup " & TagName & " was created, total: " & CurrentCount End If End Sub ``` ### OnCloseAll ```vb Public Event OnCloseAll(ByVal ClosedCount As Long) ``` **Parameters**: * `ClosedCount`: Number of popups closed **Description**: Triggered when `CloseAll` is called to batch close popups. **Usage Scenario**: * Perform batch cleanup operations * Update UI after all popups close * Trigger logging or statistics **Example**: ```vb Private WithEvents Toast As cToast Private Sub Toast_OnCloseAll(ByVal ClosedCount As Long) Debug.Print "Batch closed " & ClosedCount & " popups" RefreshUI End Sub ``` ## Method Call Order ### Recommended Call Sequence ```vb With New cToast ' 1. Set position (recommended to set first) .Pos(RightTop) ' 2. Set state .State(Success) ' 3. Set theme (optional, defaults to Light) .Theme(Dark) ' 4. Set Tag (optional, for management) .Tag("msg1") ' 5. Set stack index (optional, auto-calculated if not set) .InstIndex(0) ' 6. Display (must be last) .Show "Content", 2000, "Title" End With ``` ### Chain Call Version ```vb With New cToast .Pos(RightTop).State(Success).Theme(Dark).Tag("msg1").Show "Content", 2000, "Title" End With ``` ### Minimal Call ```vb With New cToast .Show "Simple message" End With ``` ## Error Handling ### Common Error Scenarios 1. **TagName Not Unique** * **Issue**: Popups with the same TagName will not be created * **Solution**: Ensure TagName uniqueness or use auto-generated Tags 2. **Center Position Stacking Invalid** * **Issue**: InstIndex called on Center, LeftCenter, RightCenter has no effect * **Solution**: Avoid calling InstIndex on these positions 3. **Show Not Called** * **Issue**: Popup won't display without calling Show * **Solution**: Ensure Show method is called as the last step 4. **Object Not Released** * **Issue**: Not releasing object reference may cause memory issues * **Solution**: Use `Set Toast = Nothing` when done ### Error Handling Example ```vb Private Sub ShowToastSafely() On Error GoTo ErrorHandler Dim Toast As New cToast ' Try to display Toast.Pos(RightTop).State(Success).Show "Operation successful", 2000, "Notification" Exit Sub ErrorHandler: Debug.Print "Error displaying popup: " & Err.Description ' Perform cleanup Set Toast = Nothing End Sub ``` ## Best Practices 1. **Always check TagName uniqueness** 2. **Use appropriate positions for different scenarios** 3. **Set reasonable display duration** 4. **Use persistent display for important messages (DelayMs=0)** 5. **Release object references promptly** 6. **Handle events appropriately in multi-popup scenarios** --- --- url: /en/vbman/redis/basic-operations.md --- # Basic Commands ## Auth - Authentication Authenticate with Redis server using password: ```vb ' Authenticate with password If oRedis.Auth("mypassword") Then Debug.Print "Authentication successful" Else Debug.Print "Authentication failed: " & oRedis.LastError End If ``` ## SelectDb - Select Database Redis supports multiple databases (default 0-15): ```vb ' Switch to database 1 If oRedis.SelectDb(1) Then Debug.Print "Switched to database 1" End If ' Or set property directly oRedis.DbIndex = 2 ' Switch to database 2 ``` **Example: Using Multiple Databases** ```vb ' Store user data in database 0 oRedis.SelectDb 0 oRedis.Set_ "user:1", "Zhang San" oRedis.Set_ "user:2", "Li Si" ' Store configuration data in database 1 oRedis.SelectDb 1 oRedis.Set_ "config:appname", "MyApp" oRedis.Set_ "config:version", "1.0.0" ' Switch back to database 0 oRedis.SelectDb 0 ``` ## Ping - Test Connection Test connection with Redis server: ```vb Dim sResult As String sResult = oRedis.Ping() Debug.Print sResult ' Output: PONG ``` **Usage:** * Check if connection is still active * Monitor server response time * Heartbeat detection ## Info - Get Server Information ### Get All Information ```vb Dim sInfo As String sInfo = oRedis.Info() Debug.Print sInfo ``` ### Get Specific Section Information ```vb ' Get server information sInfo = oRedis.Info("server") Debug.Print sInfo ' Get memory information sInfo = oRedis.Info("memory") ' Get persistence information sInfo = oRedis.Info("persistence") ' Get statistics information sInfo = oRedis.Info("stats") ' Get replication information sInfo = oRedis.Info("replication") ``` ## FlushDb - Clear Current Database Clear all keys in the current database: ```vb If oRedis.FlushDb() Then Debug.Print "Database cleared" Else Debug.Print "Clear failed: " & oRedis.LastError End If ``` **Warning: This operation is irreversible, use with caution!** ## Basic Key Operations ### Del - Delete Keys ```vb ' Delete single key oRedis.Del "name" ' Delete multiple keys oRedis.Del "key1", "key2", "key3" ``` ### Exists - Check if Key Exists ```vb ' Check single key If oRedis.Exists("name") > 0 Then Debug.Print "Key exists" End If ' Check multiple keys Dim lCount As Long lCount = oRedis.Exists("key1", "key2", "key3") Debug.Print lCount & " keys exist" ``` ### Keys - Find Keys ```vb ' Find all keys Dim vKeys As Variant vKeys = oRedis.Keys("*") ' Find keys starting with "user:" vKeys = oRedis.Keys("user:*") ' Find keys ending with "session" vKeys = oRedis.Keys("*session") ' Output all keys Dim i As Long If IsArray(vKeys) Then For i = 0 To UBound(vKeys) Debug.Print vKeys(i) Next End If ``` **Note:** Use `KEYS` command with caution in production environments as it scans the entire database and may affect performance. ## Expiration Management ### Expire - Set Expiration Time ```vb ' Set key expiration time (seconds) oRedis.Expire "name", 300 ' Expire in 5 minutes ' Set session expiration time to 1 hour oRedis.Expire "session:123", 3600 ``` ### TTL - Get Remaining Time to Live ```vb Dim lTTL As Long lTTL = oRedis.TTL("name") If lTTL = -1 Then Debug.Print "Key never expires" ElseIf lTTL = -2 Then Debug.Print "Key does not exist" Else Debug.Print "Remaining time: " & lTTL & " seconds" End If ``` **TTL Return Value Explanation:** * `-2`: Key does not exist * `-1`: Key exists but has no expiration time * `>= 0`: Remaining time to live for the key (seconds) ## Example: Complete Key Management ```vb Sub Example_KeyManagement() Dim oRedis As New cRedisClient If Not oRedis.Connect() Then Debug.Print "Connection failed: " & oRedis.LastError Exit Sub End If ' Set key values oRedis.Set_ "user:1001", "Zhang San" oRedis.Set_ "user:1002", "Li Si" oRedis.Set_ "config:timeout", "30" ' Set expiration times oRedis.Expire "user:1001", 3600 ' 1 hour oRedis.Expire "user:1002", 7200 ' 2 hours ' Find all user keys Dim vKeys As Variant vKeys = oRedis.Keys("user:*") Debug.Print "User keys count: " & (UBound(vKeys) + 1) ' Check if key exists If oRedis.Exists("user:1001") > 0 Then Debug.Print "User 1001 exists, remaining time: " & oRedis.TTL("user:1001") & " seconds" End If ' Delete config key oRedis.Del "config:timeout" ' Disconnect oRedis.DisConnect End Sub ``` --- --- url: /zh/emoji/0000-007F.md --- # C0控制符及基本拉丁文 本文档包含了Unicode基本多文种平面中的C0控制符及基本拉丁文字符，范围为U+0000至U+007F。这个范围包括了ASCII字符集的所有字符，包括控制字符、标点符号、数字、大小写英文字母等。 | 字符 | Unicode | VB函数值 | 名称 | |:---:|:---:|:---:|:---| | NUL | U+0000 | ChrW(\&H0000) | 空字符 | | SOH | U+0001 | ChrW(\&H0001) | 标题开始 | | STX | U+0002 | ChrW(\&H0002) | 正文开始 | | ETX | U+0003 | ChrW(\&H0003) | 正文结束 | | EOT | U+0004 | ChrW(\&H0004) | 传输结束 | | ENQ | U+0005 | ChrW(\&H0005) | 询问 | | ACK | U+0006 | ChrW(\&H0006) | 确认回应 | | BEL | U+0007 | ChrW(\&H0007) | 响铃 | | BS | U+0008 | ChrW(\&H0008) | 退格 | | HT | U+0009 | ChrW(\&H0009) | 水平制表符 | | LF | U+000A | ChrW(\&H000A) | 换行符 | | VT | U+000B | ChrW(\&H000B) | 垂直制表符 | | FF | U+000C | ChrW(\&H000C) | 换页符 | | CR | U+000D | ChrW(\&H000D) | 回车符 | | SO | U+000E | ChrW(\&H000E) | 移出 | | SI | U+000F | ChrW(\&H000F) | 移入 | | DLE | U+0010 | ChrW(\&H0010) | 数据链路转义 | | DC1 | U+0011 | ChrW(\&H0011) | 设备控制1 | | DC2 | U+0012 | ChrW(\&H0012) | 设备控制2 | | DC3 | U+0013 | ChrW(\&H0013) | 设备控制3 | | DC4 | U+0014 | ChrW(\&H0014) | 设备控制4 | | NAK | U+0015 | ChrW(\&H0015) | 否定确认 | | SYN | U+0016 | ChrW(\&H0016) | 同步空闲 | | ETB | U+0017 | ChrW(\&H0017) | 传输块结束 | | CAN | U+0018 | ChrW(\&H0018) | 取消 | | EM | U+0019 | ChrW(\&H0019) | 媒介结束 | | SUB | U+001A | ChrW(\&H001A) | 替换 | | ESC | U+001B | ChrW(\&H001B) | 转义 | | FS | U+001C | ChrW(\&H001C) | 文件分隔符 | | GS | U+001D | ChrW(\&H001D) | 组分隔符 | | RS | U+001E | ChrW(\&H001E) | 记录分隔符 | | US | U+001F | ChrW(\&H001F) | 单元分隔符 | | (空格) | U+0020 | ChrW(\&H0020) | 空格 | | ! | U+0021 | ChrW(\&H0021) | 感叹号 | | " | U+0022 | ChrW(\&H0022) | 双引号 | | # | U+0023 | ChrW(\&H0023) | 井号 | | $ | U+0024 | ChrW(\&H0024) | 美元符号 | | % | U+0025 | ChrW(\&H0025) | 百分号 | | & | U+0026 | ChrW(\&H0026) | 和号 | | ' | U+0027 | ChrW(\&H0027) | 单引号 | | ( | U+0028 | ChrW(\&H0028) | 左圆括号 | | ) | U+0029 | ChrW(\&H0029) | 右圆括号 | | \* | U+002A | ChrW(\&H002A) | 星号 | | + | U+002B | ChrW(\&H002B) | 加号 | | , | U+002C | ChrW(\&H002C) | 逗号 | | - | U+002D | ChrW(\&H002D) | 连字号 | | . | U+002E | ChrW(\&H002E) | 句号 | | / | U+002F | ChrW(\&H002F) | 斜杠 | | 0 | U+0030 | ChrW(\&H0030) | 数字零 | | 1 | U+0031 | ChrW(\&H0031) | 数字一 | | 2 | U+0032 | ChrW(\&H0032) | 数字二 | | 3 | U+0033 | ChrW(\&H0033) | 数字三 | | 4 | U+0034 | ChrW(\&H0034) | 数字四 | | 5 | U+0035 | ChrW(\&H0035) | 数字五 | | 6 | U+0036 | ChrW(\&H0036) | 数字六 | | 7 | U+0037 | ChrW(\&H0037) | 数字七 | | 8 | U+0038 | ChrW(\&H0038) | 数字八 | | 9 | U+0039 | ChrW(\&H0039) | 数字九 | | : | U+003A | ChrW(\&H003A) | 冒号 | | ; | U+003B | ChrW(\&H003B) | 分号 | | < | U+003C | ChrW(\&H003C) | 小于号 | | = | U+003D | ChrW(\&H003D) | 等于号 | | > | U+003E | ChrW(\&H003E) | 大于号 | | ? | U+003F | ChrW(\&H003F) | 问号 | | @ | U+0040 | ChrW(\&H0040) | 电子邮件符号 | | A | U+0041 | ChrW(\&H0041) | 大写字母A | | B | U+0042 | ChrW(\&H0042) | 大写字母B | | C | U+0043 | ChrW(\&H0043) | 大写字母C | | D | U+0044 | ChrW(\&H0044) | 大写字母D | | E | U+0045 | ChrW(\&H0045) | 大写字母E | | F | U+0046 | ChrW(\&H0046) | 大写字母F | | G | U+0047 | ChrW(\&H0047) | 大写字母G | | H | U+0048 | ChrW(\&H0048) | 大写字母H | | I | U+0049 | ChrW(\&H0049) | 大写字母I | | J | U+004A | ChrW(\&H004A) | 大写字母J | | K | U+004B | ChrW(\&H004B) | 大写字母K | | L | U+004C | ChrW(\&H004C) | 大写字母L | | M | U+004D | ChrW(\&H004D) | 大写字母M | | N | U+004E | ChrW(\&H004E) | 大写字母N | | O | U+004F | ChrW(\&H004F) | 大写字母O | | P | U+0050 | ChrW(\&H0050) | 大写字母P | | Q | U+0051 | ChrW(\&H0051) | 大写字母Q | | R | U+0052 | ChrW(\&H0052) | 大写字母R | | S | U+0053 | ChrW(\&H0053) | 大写字母S | | T | U+0054 | ChrW(\&H0054) | 大写字母T | | U | U+0055 | ChrW(\&H0055) | 大写字母U | | V | U+0056 | ChrW(\&H0056) | 大写字母V | | W | U+0057 | ChrW(\&H0057) | 大写字母W | | X | U+0058 | ChrW(\&H0058) | 大写字母X | | Y | U+0059 | ChrW(\&H0059) | 大写字母Y | | Z | U+005A | ChrW(\&H005A) | 大写字母Z | | \[ | U+005B | ChrW(\&H005B) | 左方括号 | | \ | U+005C | ChrW(\&H005C) | 反斜杠 | | ] | U+005D | ChrW(\&H005D) | 右方括号 | | ^ | U+005E | ChrW(\&H005E) | 脱字符 | | \_ | U+005F | ChrW(\&H005F) | 下划线 | | \` | U+0060 | ChrW(\&H0060) | 反引号 | | a | U+0061 | ChrW(\&H0061) | 小写字母a | | b | U+0062 | ChrW(\&H0062) | 小写字母b | | c | U+0063 | ChrW(\&H0063) | 小写字母c | | d | U+0064 | ChrW(\&H0064) | 小写字母d | | e | U+0065 | ChrW(\&H0065) | 小写字母e | | f | U+0066 | ChrW(\&H0066) | 小写字母f | | g | U+0067 | ChrW(\&H0067) | 小写字母g | | h | U+0068 | ChrW(\&H0068) | 小写字母h | | i | U+0069 | ChrW(\&H0069) | 小写字母i | | j | U+006A | ChrW(\&H006A) | 小写字母j | | k | U+006B | ChrW(\&H006B) | 小写字母k | | l | U+006C | ChrW(\&H006C) | 小写字母l | | m | U+006D | ChrW(\&H006D) | 小写字母m | | n | U+006E | ChrW(\&H006E) | 小写字母n | | o | U+006F | ChrW(\&H006F) | 小写字母o | | p | U+0070 | ChrW(\&H0070) | 小写字母p | | q | U+0071 | ChrW(\&H0071) | 小写字母q | | r | U+0072 | ChrW(\&H0072) | 小写字母r | | s | U+0073 | ChrW(\&H0073) | 小写字母s | | t | U+0074 | ChrW(\&H0074) | 小写字母t | | u | U+0075 | ChrW(\&H0075) | 小写字母u | | v | U+0076 | ChrW(\&H0076) | 小写字母v | | w | U+0077 | ChrW(\&H0077) | 小写字母w | | x | U+0078 | ChrW(\&H0078) | 小写字母x | | y | U+0079 | ChrW(\&H0079) | 小写字母y | | z | U+007A | ChrW(\&H007A) | 小写字母z | | { | U+007B | ChrW(\&H007B) | 左花括号 | | | | U+007C | ChrW(\&H007C) | 竖线 | | } | U+007D | ChrW(\&H007D) | 右花括号 | | ~ | U+007E | ChrW(\&H007E) | 波浪号 | | DEL | U+007F | ChrW(\&H007F) | 删除 | --- --- url: /zh/emoji/0080-00FF.md --- # C1控制符及拉丁文补充-1 本文档包含了Unicode基本多文种平面中的C1控制符及拉丁文补充-1字符，范围为U+0080至U+00FF。这个范围包括了扩展ASCII字符集，包括一些控制字符、重音字母、特殊符号等。 | 字符 | Unicode | VB函数值 | 名称 | |:---:|:---:|:---:|:---| | PAD | U+0080 | ChrW(\&H0080) | 填充字符 | | HOP | U+0081 | ChrW(\&H0081) | 高位八位组首位置 | | BPH | U+0082 | ChrW(\&H0082) | 中断允许此处 | | NBH | U+0083 | ChrW(\&H0083) | 不中断此处 | | IND | U+0084 | ChrW(\&H0084) | 索引 | | NEL | U+0085 | ChrW(\&H0085) | 下一行 | | SSA | U+0086 | ChrW(\&H0086) | 起始选定区 | | ESA | U+0087 | ChrW(\&H0087) | 结束选定区 | | HTS | U+0088 | ChrW(\&H0088) | 水平制表设置 | | HTJ | U+0089 | ChrW(\&H0089) | 水平制表附加 | | VTS | U+008A | ChrW(\&H008A) | 垂直制表设置 | | PLD | U+008B | ChrW(\&H008B) | 部分行下移 | | PLU | U+008C | ChrW(\&H008C) | 部分行上移 | | RI | U+008D | ChrW(\&H008D) | 反向索引 | | SS2 | U+008E | ChrW(\&H008E) | 单字转移2 | | SS3 | U+008F | ChrW(\&H008F) | 单字转移3 | | DCS | U+0090 | ChrW(\&H0090) | 设备控制串 | | PU1 | U+0091 | ChrW(\&H0091) | 专用1 | | PU2 | U+0092 | ChrW(\&H0092) | 专用2 | | STS | U+0093 | ChrW(\&H0093) | 设置传输状态 | | CCH | U+0094 | ChrW(\&H0094) | 取消字符 | | MW | U+0095 | ChrW(\&H0095) | 消息等待 | | SPA | U+0096 | ChrW(\&H0096) | 起始保护区 | | EPA | U+0097 | ChrW(\&H0097) | 结束保护区 | | SOS | U+0098 | ChrW(\&H0098) | 字符串起始 | | SGCI | U+0099 | ChrW(\&H0099) | 单图形字符引入 | | SCI | U+009A | ChrW(\&H009A) | 单字符引入 | | CSI | U+009B | ChrW(\&H009B) | 控制序列引入 | | ST | U+009C | ChrW(\&H009C) | 字符串终止 | | OSC | U+009D | ChrW(\&H009D) | 操作系统命令 | | PM | U+009E | ChrW(\&H009E) | 专用消息 | | APC | U+009F | ChrW(\&H009F) | 应用程序命令 | | NBSP | U+00A0 | ChrW(\&H00A0) | 不间断空格 | | ¡ | U+00A1 | ChrW(\&H00A1) | 倒置感叹号 | | ¢ | U+00A2 | ChrW(\&H00A2) | 分币符号 | | £ | U+00A3 | ChrW(\&H00A3) | 英镑符号 | | ¤ | U+00A4 | ChrW(\&H00A4) | 货币符号 | | ¥ | U+00A5 | ChrW(\&H00A5) | 日元符号 | | ¦ | U+00A6 | ChrW(\&H00A6) | 断竖线 | | § | U+00A7 | ChrW(\&H00A7) | 节符号 | | ¨ | U+00A8 | ChrW(\&H00A8) | 分音符号 | | © | U+00A9 | ChrW(\&H00A9) | 版权符号 | | ª | U+00AA | ChrW(\&H00AA) | 阴性序数记号 | | « | U+00AB | ChrW(\&H00AB) | 左双尖引号 | | ¬ | U+00AC | ChrW(\&H00AC) | 否定符号 | | ­ | U+00AD | ChrW(\&H00AD) | 软连字符 | | ® | U+00AE | ChrW(\&H00AE) | 注册商标 | | ¯ | U+00AF | ChrW(\&H00AF) | 长音符号 | | ° | U+00B0 | ChrW(\&H00B0) | 度数符号 | | ± | U+00B1 | ChrW(\&H00B1) | 加减号 | | ² | U+00B2 | ChrW(\&H00B2) | 上标2 | | ³ | U+00B3 | ChrW(\&H00B3) | 上标3 | | ´ | U+00B4 | ChrW(\&H00B4) | 锐音符 | | µ | U+00B5 | ChrW(\&H00B5) | 微符号 | | ¶ | U+00B6 | ChrW(\&H00B6) | 段落符号 | | · | U+00B7 | ChrW(\&H00B7) | 中点 | | ¸ | U+00B8 | ChrW(\&H00B8) | 下加符 | | ¹ | U+00B9 | ChrW(\&H00B9) | 上标1 | | º | U+00BA | ChrW(\&H00BA) | 阳性序数记号 | | » | U+00BB | ChrW(\&H00BB) | 右双尖引号 | | ¼ | U+00BC | ChrW(\&H00BC) | 四分之一 | | ½ | U+00BD | ChrW(\&H00BD) | 二分之一 | | ¾ | U+00BE | ChrW(\&H00BE) | 四分之三 | | ¿ | U+00BF | ChrW(\&H00BF) | 倒置问号 | | À | U+00C0 | ChrW(\&H00C0) | 带重音符的大写字母A | | Á | U+00C1 | ChrW(\&H00C1) | 带锐音符的大写字母A | | Â | U+00C2 | ChrW(\&H00C2) | 带扬抑符的大写字母A | | Ã | U+00C3 | ChrW(\&H00C3) | 带波浪符的大写字母A | | Ä | U+00C4 | ChrW(\&H00C4) | 带分音符的大写字母A | | Å | U+00C5 | ChrW(\&H00C5) | 带圆圈的大写字母A | | Æ | U+00C6 | ChrW(\&H00C6) | 大写字母AE连字 | | Ç | U+00C7 | ChrW(\&H00C7) | 带下加符的大写字母C | | È | U+00C8 | ChrW(\&H00C8) | 带重音符的大写字母E | | É | U+00C9 | ChrW(\&H00C9) | 带锐音符的大写字母E | | Ê | U+00CA | ChrW(\&H00CA) | 带扬抑符的大写字母E | | Ë | U+00CB | ChrW(\&H00CB) | 带分音符的大写字母E | | Ì | U+00CC | ChrW(\&H00CC) | 带重音符的大写字母I | | Í | U+00CD | ChrW(\&H00CD) | 带锐音符的大写字母I | | Î | U+00CE | ChrW(\&H00CE) | 带扬抑符的大写字母I | | Ï | U+00CF | ChrW(\&H00CF) | 带分音符的大写字母I | | Ð | U+00D0 | ChrW(\&H00D0) | 大写字母ETH | | Ñ | U+00D1 | ChrW(\&H00D1) | 带波浪符的大写字母N | | Ò | U+00D2 | ChrW(\&H00D2) | 带重音符的大写字母O | | Ó | U+00D3 | ChrW(\&H00D3) | 带锐音符的大写字母O | | Ô | U+00D4 | ChrW(\&H00D4) | 带扬抑符的大写字母O | | Õ | U+00D5 | ChrW(\&H00D5) | 带波浪符的大写字母O | | Ö | U+00D6 | ChrW(\&H00D6) | 带分音符的大写字母O | | × | U+00D7 | ChrW(\&H00D7) | 乘号 | | Ø | U+00D8 | ChrW(\&H00D8) | 带斜线的大写字母O | | Ù | U+00D9 | ChrW(\&H00D9) | 带重音符的大写字母U | | Ú | U+00DA | ChrW(\&H00DA) | 带锐音符的大写字母U | | Û | U+00DB | ChrW(\&H00DB) | 带扬抑符的大写字母U | | Ü | U+00DC | ChrW(\&H00DC) | 带分音符的大写字母U | | Ý | U+00DD | ChrW(\&H00DD) | 带锐音符的大写字母Y | | Þ | U+00DE | ChrW(\&H00DE) | 大写字母THORN | | ß | U+00DF | ChrW(\&H00DF) | 德语大写字母锐音 | | à | U+00E0 | ChrW(\&H00E0) | 带重音符的小写字母a | | á | U+00E1 | ChrW(\&H00E1) | 带锐音符的小写字母a | | â | U+00E2 | ChrW(\&H00E2) | 带扬抑符的小写字母a | | ã | U+00E3 | ChrW(\&H00E3) | 带波浪符的小写字母a | | ä | U+00E4 | ChrW(\&H00E4) | 带分音符的小写字母a | | å | U+00E5 | ChrW(\&H00E5) | 带圆圈的小写字母a | | æ | U+00E6 | ChrW(\&H00E6) | 小写字母ae连字 | | ç | U+00E7 | ChrW(\&H00E7) | 带下加符的小写字母c | | è | U+00E8 | ChrW(\&H00E8) | 带重音符的小写字母e | | é | U+00E9 | ChrW(\&H00E9) | 带锐音符的小写字母e | | ê | U+00EA | ChrW(\&H00EA) | 带扬抑符的小写字母e | | ë | U+00EB | ChrW(\&H00EB) | 带分音符的小写字母e | | ì | U+00EC | ChrW(\&H00EC) | 带重音符的小写字母i | | í | U+00ED | ChrW(\&H00ED) | 带锐音符的小写字母i | | î | U+00EE | ChrW(\&H00EE) | 带扬抑符的小写字母i | | ï | U+00EF | ChrW(\&H00EF) | 带分音符的小写字母i | | ð | U+00F0 | ChrW(\&H00F0) | 小写字母eth | | ñ | U+00F1 | ChrW(\&H00F1) | 带波浪符的小写字母n | | ò | U+00F2 | ChrW(\&H00F2) | 带重音符的小写字母o | | ó | U+00F3 | ChrW(\&H00F3) | 带锐音符的小写字母o | | ô | U+00F4 | ChrW(\&H00F4) | 带扬抑符的小写字母o | | õ | U+00F5 | ChrW(\&H00F5) | 带波浪符的小写字母o | | ö | U+00F6 | ChrW(\&H00F6) | 带分音符的小写字母o | | ÷ | U+00F7 | ChrW(\&H00F7) | 除号 | | ø | U+00F8 | ChrW(\&H00F8) | 带斜线的小写字母o | | ù | U+00F9 | ChrW(\&H00F9) | 带重音符的小写字母u | | ú | U+00FA | ChrW(\&H00FA) | 带锐音符的小写字母u | | û | U+00FB | ChrW(\&H00FB) | 带扬抑符的小写字母u | | ü | U+00FC | ChrW(\&H00FC) | 带分音符的小写字母u | | ý | U+00FD | ChrW(\&H00FD) | 带锐音符的小写字母y | | þ | U+00FE | ChrW(\&H00FE) | 小写字母thorn | | ÿ | U+00FF | ChrW(\&H00FF) | 带分音符的小写字母y | --- --- url: /zh/vbman/ai/methods.md --- # cAI 方法参考 ## 基础配置方法 ### ApiKey 设置 API 密钥。 ```vb Public Function ApiKey(Key As String) As cAI ``` **示例**: ```vb AI.ApiKey("sk-xxx") ``` *** ### BaseUrl 设置 API 基础 URL（用于适配不同服务商）。 ```vb Public Function BaseUrl(Url As String) As cAI ``` **示例**: ```vb AI.BaseUrl("https://api.deepseek.com/v1") ``` *** ### ApiPath 设置 API 路径（用于适配不同 API 版本）。 ```vb Public Function ApiPath(Path As String) As cAI ``` **默认值**: `/chat/completions` **示例**: ```vb AI.ApiPath("/v1/chat/completions") ``` *** ### Model 设置模型名称。 ```vb Public Function Model(ModelName As String) As cAI ``` **默认值**: `gpt-3.5-turbo` **示例**: ```vb AI.Model("gpt-4") AI.Model("deepseek-chat") AI.Model("ep-xxx") ' 豆包端点ID ``` *** ### Timeout 设置请求超时时间（秒）。 ```vb Public Function Timeout(Seconds As Long) As cAI ``` **默认值**: 60 **示例**: ```vb AI.Timeout(120) ``` *** ## 参数配置方法 ### Temperature 设置温度参数（0-2），值越低输出越确定性。 ```vb Public Function Temperature(Value As Double) As cAI ``` **默认值**: 1.0 **示例**: ```vb AI.Temperature(0.7) ' 更确定的输出 AI.Temperature(1.5) ' 更随机的输出 ``` *** ### MaxTokens 设置最大生成 token 数。 ```vb Public Function MaxTokens(Value As Long) As cAI ``` **默认值**: 0（自动，由模型决定） **示例**: ```vb AI.MaxTokens(1000) ``` *** ### TopP 设置 Top-P 核采样参数。 ```vb Public Function TopP(Value As Double) As cAI ``` **默认值**: 1.0 *** ### FrequencyPenalty 设置频率惩罚（-2 到 2），降低重复用词。 ```vb Public Function FrequencyPenalty(Value As Double) As cAI ``` **默认值**: 0 *** ### PresencePenalty 设置存在惩罚（-2 到 2），鼓励谈论新话题。 ```vb Public Function PresencePenalty(Value As Double) As cAI ``` **默认值**: 0 *** ### Stream 启用/禁用流式响应。 ```vb Public Function Stream(Enable As Boolean) As cAI ``` **默认值**: False **说明**: * `Stream(False)` — 同步请求，Chat 返回完整结果 * `Stream(True)` — 流式请求，通过 SSE 实时接收，Chat 阻塞等待直到完成后返回完整结果 **示例**: ```vb AI.Stream(True).Chat("写一首诗", Me, "OnChunk") ``` *** ### Stop 设置停止序列。 ```vb Public Function Stop(Value As Variant) As cAI ``` **参数**: String 或 Array **示例**: ```vb AI.Stop("。") AI.Stop(Array("\n", "。")) ``` *** ## 消息管理方法 ### System 设置系统提示词。 ```vb Public Function System(Prompt As String) As cAI ``` **说明**: 系统提示词不会在多轮对话中重复添加，每次请求时自动构建到消息列表开头。 **示例**: ```vb AI.System("你是一个专业的翻译助手，只翻译不解释") ``` *** ### User 添加用户消息。 ```vb Public Function User(Content As String) As cAI ``` **示例**: ```vb AI.User("帮我翻译这句话") ``` *** ### Assistant 添加助手消息（用于预设对话历史）。 ```vb Public Function Assistant(Content As String) As cAI ``` **示例**: ```vb AI.User("什么是OOP?").Assistant("OOP是面向对象编程...").User("举例说明") ``` *** ### ClearMessages 清空消息历史和系统提示词。 ```vb Public Function ClearMessages() As cAI ``` **示例**: ```vb AI.ClearMessages().User("新话题").Chat() ``` *** ### Messages 设置消息列表（高级用法，直接替换内部消息集合）。 ```vb Public Function Messages(MsgList As Collection) As cAI ``` *** ## 高级配置方法 ### Header 添加自定义请求头。 ```vb Public Function Header(Name As String, Value As String) As cAI ``` **示例**: ```vb AI.Header("X-Custom-Header", "custom-value") ``` *** ### Proxy 设置代理地址。 ```vb Public Function Proxy(ProxyUrl As String) As cAI ``` *** ### Organization 设置 OpenAI 组织 ID。 ```vb Public Function Organization(OrgId As String) As cAI ``` **示例**: ```vb AI.Organization("org-xxx") ``` *** ## 预设配置方法 ### Doubao 快速配置为豆包 API。 ```vb Public Function Doubao(ApiKey As String) As cAI ``` | 配置项 | 值 | |--------|-----| | BaseUrl | `https://ark.cn-beijing.volces.com/api/v3` | | ApiPath | `/chat/completions` | **示例**: ```vb AI.Doubao("your-key").Model("ep-xxx").Chat("你好") ``` *** ### DeepSeek 快速配置为 DeepSeek API。 ```vb Public Function DeepSeek(ApiKey As String) As cAI ``` | 配置项 | 值 | |--------|-----| | BaseUrl | `https://api.deepseek.com/v1` | | ApiPath | `/chat/completions` | **示例**: ```vb AI.DeepSeek("your-key").Model("deepseek-chat").Chat("你好") ``` *** ### OpenAI 快速配置为 OpenAI API。 ```vb Public Function OpenAI(ApiKey As String) As cAI ``` | 配置项 | 值 | |--------|-----| | BaseUrl | `https://api.openai.com/v1` | | ApiPath | `/chat/completions` | *** ### Qwen 快速配置为通义千问 API。 ```vb Public Function Qwen(ApiKey As String) As cAI ``` | 配置项 | 值 | |--------|-----| | BaseUrl | `https://dashscope.aliyuncs.com/api/v1` | | ApiPath | `/chat/completions` | *** ## 执行方法 ### Chat 发送聊天请求。 ```vb Public Function Chat(Optional UserMessage As String, Optional Callback As Object, Optional CallbackMethod As String) As String ``` **参数**: * `UserMessage` — 可选，用户消息（等同于先调用 `.User()` 再 Chat） * `Callback` — 可选，流式响应回调对象 * `CallbackMethod` — 可选，回调方法名，签名为 `Sub MethodName(Chunk As String, IsComplete As Boolean)` **返回**: 完整响应文本 **说明**: * `Stream=False`（默认）— 同步请求，直接返回 * `Stream=True` — 通过 SSE 流式接收，阻塞等待直到完成后返回完整结果 * 流式模式下，如果提供了 `Callback`，优先使用回调；否则触发 `OnStreamChunk` 事件 * 已有流式请求在执行时会抛出错误（防重入） **示例**: ```vb ' 同步 Response = AI.ApiKey("sk-xxx").Chat("你好") ' 流式 + 回调 AI.ApiKey("sk-xxx").Stream(True).Chat("写一首诗", Me, "OnChunk") ' 流式 + 事件 Dim WithEvents AI As cAI AI.Stream(True).Chat("写一首诗") ``` *** ### ChatJson 发送聊天请求并返回 JSON 对象。 ```vb Public Function ChatJson(Optional UserMessage As String) As cJson ``` **返回**: `cJson` 对象，可直接访问 `choices`、`usage` 等字段 **示例**: ```vb Dim Json As cJson Set Json = AI.ApiKey("sk-xxx").ChatJson("你好") Debug.Print Json.Item("choices")(1)("message")("content") Debug.Print Json.Item("usage")("total_tokens") ``` *** ### Reset 重置所有配置为默认值，清空消息和自定义头。 ```vb Public Sub Reset() ``` *** **最后更新**: 2025-05-25 --- --- url: /zh/vbman/ai/events.md --- # cAI 事件参考 ## 事件概览 | 事件 | 说明 | |------|------| | `OnStreamChunk(Chunk, IsComplete)` | 流式响应数据块 | | `OnComplete(Response)` | 请求完成 | | `OnError(ErrorMsg, ErrorCode)` | 错误事件 | *** ## OnStreamChunk 流式响应数据到达时触发。 ```vb Public Event OnStreamChunk(Chunk As String, IsComplete As Boolean) ``` **参数**: * `Chunk` — 本次收到的文本片段（完成时为空字符串） * `IsComplete` — 是否为最后一次触发（流式结束） **说明**: * 仅在 `Stream=True` 且未提供回调函数时触发 * 如果 Chat 提供了 `Callback` 和 `CallbackMethod` 参数，则使用回调而不触发此事件 * `IsComplete=True` 时，`Chunk` 为空，完整内容通过 `OnComplete` 事件获取 **示例**: ```vb Dim WithEvents AI As cAI Private Sub Form_Load() Set AI = New cAI AI.ApiKey("sk-xxx").Stream(True).Chat("写一首诗") End Sub Private Sub AI_OnStreamChunk(Chunk As String, IsComplete As Boolean) If Not IsComplete Then TextResponse.Text = TextResponse.Text & Chunk TextResponse.SelStart = Len(TextResponse.Text) End If End Sub ``` *** ## OnComplete 请求完成时触发（同步和流式均触发）。 ```vb Public Event OnComplete(Response As String) ``` **参数**: * `Response` — 完整的响应文本 **示例**: ```vb Private Sub AI_OnComplete(Response As String) Debug.Print "请求完成，完整响应: " & Left(Response, 100) End Sub ``` *** ## OnError 请求出错时触发。 ```vb Public Event OnError(ErrorMsg As String, ErrorCode As Long) ``` **参数**: * `ErrorMsg` — 错误描述 * `ErrorCode` — 错误代码（HTTP 状态码或系统错误码） **说明**: 错误来源包括： * API Key 未设置（500） * 网络/超时错误 * HTTP 4xx/5xx（如 401 认证失败、429 限速） * SSE 连接错误 **示例**: ```vb Private Sub AI_OnError(ErrorMsg As String, ErrorCode As Long) MsgBox "请求失败 [" & ErrorCode & "]: " & ErrorMsg, vbExclamation End Sub ``` *** ## 流式响应工作原理 ``` 用户调用 Chat() (Stream=True) ↓ cSSEClient.ConnectPost() — POST 请求到 AI API ↓ SSE 逐条返回 data: {"choices":[{"delta":{"content":"..."}}]} ↓ cAI 解析 JSON，提取 delta.content ↓ 触发 OnStreamChunk(Chunk, False) — 每个 chunk ↓ 收到 data: [DONE] ↓ 触发 OnStreamChunk("", True) + OnComplete(完整文本) ``` *** **最后更新**: 2025-05-25 --- --- url: /zh/vbman/ai/properties.md --- # cAI 属性参考 ## 只读属性 ### LastError 获取最后一次错误信息。 ```vb Public Property Get LastError() As String ``` **说明**: 当 Chat 调用出错时，此属性记录错误描述。同步请求也可通过 `On Error` 捕获。 **示例**: ```vb On Error Resume Next Response = AI.ApiKey("invalid").Chat("测试") If Err.Number <> 0 Then Debug.Print "错误: " & AI.LastError End If On Error GoTo 0 ``` *** ### IsStreaming 获取当前是否正在流式请求中。 ```vb Public Property Get IsStreaming() As Boolean ``` **说明**: 流式请求进行中返回 `True`。可用于防止重入或显示状态。 **示例**: ```vb If AI.IsStreaming Then MsgBox "请等待上一次请求完成" Exit Sub End If ``` *** ## 配置参数默认值 | 参数 | 默认值 | 说明 | |------|--------|------| | BaseUrl | `https://api.openai.com/v1` | 未设置时的默认值 | | ApiPath | `/chat/completions` | 未设置时的默认值 | | Model | `gpt-3.5-turbo` | 未设置时的默认值 | | Timeout | 60 | 秒 | | Temperature | 1.0 | | | MaxTokens | 0 | 自动 | | TopP | 1.0 | | | FrequencyPenalty | 0 | | | PresencePenalty | 0 | | | Stream | False | | *** **最后更新**: 2025-05-25 --- --- url: /zh/vbman/ai/overview.md --- # cAI 组件概述 ## 简介 `cAI` 是一个通用的 OpenAI 兼容 API 客户端，支持豆包、DeepSeek、OpenAI、通义千问等任何兼容 OpenAI API 格式的服务。采用链式调用设计，提供简洁优雅的 API。 **让你的VB项目轻松嵌入各大AI平台能力** ## 特性 | 特性 | 说明 | | ------------ | ------------------------------------- | | **链式调用** | 流畅的 API 设计，支持连续配置 | | **多服务商** | 内置豆包/DeepSeek/OpenAI/通义千问预设 | | **流式响应** | 支持 SSE 实时流式输出（回调或事件） | | **多轮对话** | 自动维护对话上下文 | | **全局对象** | 通过 `VBMAN.AI` 直接使用 | | **灵活配置** | 支持完全自定义 API 参数和请求头 | ## 快速开始 ### 最简单的使用 ```vb Dim Response As String Response = VBMAN.AI.ApiKey("sk-xxx").Chat("你好") ``` ### 使用预设配置 ```vb ' DeepSeek Response = VBMAN.AI.DeepSeek("your-key").Chat("你好") ' 豆包 Response = VBMAN.AI.Doubao("your-key").Model("ep-xxx").Chat("你好") ``` ### 完整配置 ```vb Response = VBMAN.AI.ApiKey("sk-xxx") _ .Model("gpt-4") _ .Temperature(0.7) _ .MaxTokens(1000) _ .System("你是一个专业的编程助手") _ .Chat("如何实现单例模式？") ``` ### 流式响应 ```vb ' 回调方式 VBMAN.AI.ApiKey("sk-xxx") _ .Stream(True) _ .Chat("写一首诗", Me, "OnStreamChunk") Private Sub OnStreamChunk(Chunk As String, IsComplete As Boolean) If IsComplete Then Debug.Print "完成" Else Debug.Print Chunk; End If End Sub ``` ```vb ' 事件方式（窗体/类中使用） Dim WithEvents AI As cAI Private Sub CommandSend_Click() Set AI = New cAI AI.ApiKey("sk-xxx").Stream(True).Chat("写一首诗") End Sub Private Sub AI_OnStreamChunk(Chunk As String, IsComplete As Boolean) TextResponse.Text = TextResponse.Text & Chunk End Sub ``` ### 多轮对话 ```vb Dim AI As New cAI AI.ApiKey("sk-xxx") ' 第一轮 AI.User("我喜欢编程").Chat() ' 第二轮（自动保留上下文） AI.User("推荐学习资源").Chat() ' 清空历史重新开始 AI.ClearMessages().User("新话题").Chat() ``` ## 引用组件 * `cHttpClient.cls` * `cJson.cls` * `cSSEClient.cls` * `Microsoft Scripting Runtime` ## 文件结构 | 文件 | 说明 | | ------------- | --------------- | | `cAI.cls` | AI 客户端核心类 | | `mAIDemo.bas` | 完整使用示例 | | `mAITest.bas` | 测试工具 | *** **最后更新**: 2025-05-25 --- --- url: /zh/vbman/websocket/buffer.md --- # cByteBuffer 类参考 ## 📋 类概述 `cByteBuffer` 是高效的字节缓冲区类，用于管理二进制数据流。 ### 设计特点 * **预分配** - 初始分配 4KB，避免频繁内存分配 * **智能增长** - 按 1.5 倍增长，平衡空间和性能 * **最小化拷贝** - 使用 CopyMemory API 提高效率 * **Peek/Consume** - 支持查看数据而不消费 *** ## 🔧 属性参考 ### Size - 当前数据大小 **类型**: `Long`\ **读写**: 只读 **说明**: 缓冲区中当前存储的数据字节数。 ```vb Debug.Print "缓冲区大小: " & oBuffer.Size & " 字节" If oBuffer.Size > 0 Then ProcessData oBuffer End If ``` *** ### Capacity - 缓冲区容量 **类型**: `Long`\ **读写**: 只读 **说明**: 缓冲区当前分配的总容量（字节）。 ```vb Debug.Print "容量: " & oBuffer.Capacity & " 字节" Debug.Print "使用率: " & (oBuffer.Size / oBuffer.Capacity * 100) & "%" ``` *** ### IsEmpty - 是否为空 **类型**: `Boolean`\ **读写**: 只读 **说明**: 缓冲区是否为空（Size = 0）。 ```vb If oBuffer.IsEmpty Then Debug.Print "缓冲区为空" Else Debug.Print "缓冲区有 " & oBuffer.Size & " 字节数据" End If ``` *** ## 🚀 方法参考 ### Append - 追加数据 **语法**: ```vb Public Sub Append(ByRef Data() As Byte) ``` **参数**: | 参数 | 类型 | 说明 | |------|------|------| | `Data()` | Byte() | 要追加的字节数组 | **说明**: * 如果需要，自动扩容 * 数据追加到缓冲区末尾 **示例**: ```vb ' 追加字节数组 Dim baData() As Byte baData = StringToUTF8("Hello") oBuffer.Append baData ' 追加接收到的网络数据 Private Sub Socket_DataArrival(Client As cWinsock, ByVal bytesTotal As Long) Dim baData() As Byte Client.GetData baData, vbByte + vbArray oBuffer.Append baData ' 处理缓冲区 ProcessBuffer End Sub ``` *** ### AppendByte - 追加单个字节 **语法**: ```vb Public Sub AppendByte(ByVal Value As Byte) ``` **参数**: | 参数 | 类型 | 说明 | |------|------|------| | `Value` | Byte | 要追加的字节值 | **示例**: ```vb ' 构建协议头 oBuffer.AppendByte &H01 ' 版本 oBuffer.AppendByte &H02 ' 类型 oBuffer.AppendByte &H03 ' 标志 ``` *** ### Peek - 查看数据（不消费） **语法**: ```vb Public Function Peek(ByVal Offset As Long, ByVal Length As Long, ByRef OutData() As Byte) As Boolean ``` **参数**: | 参数 | 类型 | 说明 | |------|------|------| | `Offset` | Long | 偏移位置（从 0 开始） | | `Length` | Long | 要查看的字节数 | | `OutData()` | Byte() | 输出字节数组 | **返回值**: `Boolean` - 成功返回 `True`，否则返回 `False` **说明**: * 只读操作，不修改缓冲区 * 适合用于预检查数据 **示例**: ```vb ' 检查前 4 字节是否为特定值 Dim baHeader() As Byte If oBuffer.Peek(0, 4, baHeader) Then If baHeader(0) = &HDE And baHeader(1) = &HAD Then Debug.Print "检测到魔数" End If End If ``` *** ### PeekByte - 查看单个字节 **语法**: ```vb Public Function PeekByte(ByVal Offset As Long) As Byte ``` **参数**: | 参数 | 类型 | 说明 | |------|------|------| | `Offset` | Long | 偏移位置 | **返回值**: 读取到的字节值 **示例**: ```vb ' 检查第一个字节 Dim bFirst As Byte bFirst = oBuffer.PeekByte(0) Debug.Print "第一个字节: " & Hex$(bFirst) ``` *** ### Consume - 消费数据 **语法**: ```vb Public Sub Consume(ByVal Length As Long) ``` **参数**: | 参数 | 类型 | 说明 | |------|------|------| | `Length` | Long | 要消费的字节数 | **说明**: * 从缓冲区前面移除指定字节数 * 剩余数据会向前移动 * 如果消费全部，缓冲区变空 **示例**: ```vb ' 消费前 4 字节 oBuffer.Consume 4 ' 消费已处理的数据 oBuffer.Consume lProcessedBytes ``` *** ### Extract - 提取并消费数据 **语法**: ```vb Public Function Extract(ByVal Length As Long) As Byte() ``` **参数**: | 参数 | 类型 | 说明 | |------|------|------| | `Length` | Long | 要提取的字节数 | **返回值**: 提取的字节数组 **说明**: * 返回指定长度的数据 * 自动从缓冲区中移除 **示例**: ```vb ' 提取并消费前 10 字节 Dim baData() As Byte baData = oBuffer.Extract(10) Debug.Print "提取了 " & (UBound(baData) + 1) & " 字节" ' WebSocket 帧提取示例 Private Sub ExtractFrame(oBuffer As cByteBuffer) Dim oFrame As New cWebSocketFrame If oFrame.ParseHeader(oBuffer) Then If oFrame.IsCompleteFrame(oBuffer) Then Dim baFrame() As Byte baFrame = oBuffer.Extract(oFrame.TotalFrameLength) ' 处理帧... End If End If End Sub ``` *** ### ToArray - 获取所有数据 **语法**: ```vb Public Function ToArray() As Byte() ``` **返回值**: 缓冲区所有数据的副本 **说明**: * 返回数据的副本，不影响缓冲区 * 空缓冲区返回空数组 **示例**: ```vb ' 获取所有数据 Dim baAll() As Byte baAll = oBuffer.ToArray Debug.Print "总数据: " & (UBound(baAll) + 1) & " 字节" ' 保存到文件 SaveToFile "data.bin", baAll ``` *** ### Clear - 清空缓冲区 **语法**: ```vb Public Sub Clear() ``` **说明**: 清除所有数据，但保留容量。 **示例**: ```vb ' 清空缓冲区 oBuffer.Clear Debug.Print "缓冲区已清空，大小: " & oBuffer.Size ``` *** ### Reset - 重置缓冲区 **语法**: ```vb Public Sub Reset() ``` **说明**: * 清除所有数据 * 重置容量为初始值（4KB） **示例**: ```vb ' 完全重置 oBuffer.Reset Debug.Print "缓冲区已重置，容量: " & oBuffer.Capacity ``` *** ### GetBufferPtr - 获取缓冲区指针 **语法**: ```vb Public Function GetBufferPtr() As Long ``` **返回值**: 内部缓冲区的内存地址 **说明**: * 用于高性能场景 * ⚠️ 危险操作，不要超出 Size 范围写入 **示例**: ```vb ' 高性能填充（仅高级用法） Dim pBuffer As Long pBuffer = oBuffer.GetBufferPtr If pBuffer <> 0 Then ' 使用 CopyMemory API 直接写入 CopyMemory ByVal pBuffer, baData(0), UBound(baData) + 1 oBuffer.Size = oBuffer.Size + UBound(baData) + 1 End If ``` *** ## 📝 使用示例 ### WebSocket 帧解析 ```vb Private Sub ProcessWebSocketData(oBuffer As cByteBuffer) Dim oFrame As New cWebSocketFrame Do While oBuffer.Size >= 2 ' 解析头部 If Not oFrame.ParseHeader(oBuffer) Then Exit Do ' 需要更多数据 End If ' 检查完整性 If Not oFrame.IsCompleteFrame(oBuffer) Then Exit Do ' 需要更多数据 End If ' 提取帧 Dim baFrame() As Byte baFrame = oBuffer.Extract(oFrame.TotalFrameLength) ' 处理帧 ProcessFrame baFrame, oFrame Loop End Sub ``` ### 网络数据接收 ```vb Private WithEvents m_Socket As cWinsock Private m_RecvBuffer As cByteBuffer Private Sub Form_Load() Set m_RecvBuffer = New cByteBuffer End Sub Private Sub m_Socket_DataArrival(Client As cWinsock, ByVal bytesTotal As Long) Dim baData() As Byte Client.GetData baData, vbByte + vbArray ' 追加到缓冲区 m_RecvBuffer.Append baData ' 处理缓冲区中的完整消息 ProcessBuffer End Sub Private Sub ProcessBuffer() Do While m_RecvBuffer.Size >= 4 ' 读取消息长度（假设前 4 字节是长度） Dim lLen As Long lLen = CLng(m_RecvBuffer.PeekByte(0)) * 256& ^ 3 + _ CLng(m_RecvBuffer.PeekByte(1)) * 256& ^ 2 + _ CLng(m_RecvBuffer.PeekByte(2)) * 256& + _ CLng(m_RecvBuffer.PeekByte(3)) ' 检查是否有完整消息 If m_RecvBuffer.Size < 4 + lLen Then Exit Do ' 需要更多数据 End If ' 提取消息头 m_RecvBuffer.Consume 4 ' 提取消息体 Dim baMessage() As Byte baMessage = m_RecvBuffer.Extract(lLen) ' 处理消息 ProcessMessage baMessage Loop End Sub ``` ### 协议头构建 ```vb Private Function BuildProtocolHeader() As cByteBuffer Dim oBuffer As New cByteBuffer ' 构建协议头 oBuffer.AppendByte &H01 ' 版本 oBuffer.AppendByte &H00 ' 类型 oBuffer.AppendByte &H00 ' 标志 oBuffer.AppendByte &H00 ' 保留 ' 添加长度（4 字节） Dim lLen As Long lLen = 1234 oBuffer.AppendByte (lLen And &HFF000000) \ &H1000000 oBuffer.AppendByte (lLen And &HFF0000) \ &H10000 oBuffer.AppendByte (lLen And &HFF00&) \ &H100& oBuffer.AppendByte (lLen And &HFF&) Set BuildProtocolHeader = oBuffer End Function ``` ### 数据分片处理 ```vb Private m_FragmentBuffer As cByteBuffer Private Sub HandleFragmentedFrame(oFrame As cWebSocketFrame, oBuffer As cByteBuffer) ' 提取帧 Dim baPayload() As Byte baPayload = oBuffer.Extract(oFrame.TotalFrameLength) If m_FragmentBuffer.IsEmpty Then ' 第一个分片 If Not oFrame.FIN Then ' 开始分片消息 m_FragmentBuffer.Clear m_FragmentBuffer.Append baPayload Else ' 单一帧（无分片） ProcessCompleteMessage baPayload, oFrame.OpCode End If Else ' 后续分片 m_FragmentBuffer.Append baPayload If oFrame.FIN Then ' 最后一个分片 Dim baComplete() As Byte baComplete = m_FragmentBuffer.ToArray ProcessCompleteMessage baComplete, oFrame.OpCode m_FragmentBuffer.Clear End If End If End Sub ``` *** ## ⚠️ 注意事项 1. **容量自动增长** - Append 时如果超出容量，会自动扩容 2. **Peek 是只读** - Peek 操作不会修改缓冲区 3. **Consume 会移除** - Consume 后数据会被删除 4. **Extract 会消费** - Extract 相当于 Peek + Consume 5. **GetBufferPtr 危险** - 仅限高级使用，确保不越界 *** ## 🔍 性能优化 ### 批量 Append ```vb ' ✅ 好的做法：一次 Append Dim baData() As Byte baData = BuildLargeData() oBuffer.Append baData ' ❌ 不好的做法：多次 Append For i = 0 To 10000 oBuffer.AppendByte baData(i) Next i ``` ### 避免频繁 ToArray ```vb ' ✅ 好的做法：直接使用 Peek/Consume If oBuffer.Peek(0, 4, baHeader) Then ProcessHeader baHeader End If ' ❌ 不好的做法：频繁 ToArray Dim baAll() As Byte baAll = oBuffer.ToArray For i = 0 To 100 ProcessSegment baAll, i * 100, 100 Next i ``` *** **最后更新**: 2026-01-10 --- --- url: /en/vbman/websocket/buffer.md --- # cByteBuffer Class Reference ## 📋 Class Overview `cByteBuffer` is an efficient byte buffer class for managing binary data streams. ### Design Features * **Pre-allocated** - Initially allocates 4KB to avoid frequent memory allocation * **Smart growth** - Grows by 1.5x to balance space and performance * **Minimal copying** - Uses CopyMemory API for efficiency * **Peek/Consume** - Supports viewing data without consuming *** ## 🔧 Property Reference ### Size - Current Data Size **Type**: `Long`\ **Read/Write**: Read-only **Description**: The number of bytes of data currently stored in the buffer. ```vb Debug.Print "Buffer size: " & oBuffer.Size & " bytes" If oBuffer.Size > 0 Then ProcessData oBuffer End If ``` *** ### Capacity - Buffer Capacity **Type**: `Long`\ **Read/Write**: Read-only **Description**: The total allocated capacity of the buffer (bytes). ```vb Debug.Print "Capacity: " & oBuffer.Capacity & " bytes" Debug.Print "Usage: " & (oBuffer.Size / oBuffer.Capacity * 100) & "%" ``` *** ### IsEmpty - Is Empty **Type**: `Boolean`\ **Read/Write**: Read-only **Description**: Whether the buffer is empty (Size = 0). ```vb If oBuffer.IsEmpty Then Debug.Print "Buffer is empty" Else Debug.Print "Buffer has " & oBuffer.Size & " bytes of data" End If ``` *** ## 🚀 Method Reference ### Append - Append Data **Syntax**: ```vb Public Sub Append(ByRef Data() As Byte) ``` **Parameters**: | Parameter | Type | Description | |-----------|------|-------------| | `Data()` | Byte() | Byte array to append | **Description**: * Automatically expands capacity if needed * Data is appended to the end of the buffer **Example**: ```vb ' Append byte array Dim baData() As Byte baData = StringToUTF8("Hello") oBuffer.Append baData ' Append received network data Private Sub Socket_DataArrival(Client As cWinsock, ByVal bytesTotal As Long) Dim baData() As Byte Client.GetData baData, vbByte + vbArray oBuffer.Append baData ' Process buffer ProcessBuffer End Sub ``` *** ### AppendByte - Append Single Byte **Syntax**: ```vb Public Sub AppendByte(ByVal Value As Byte) ``` **Parameters**: | Parameter | Type | Description | |-----------|------|-------------| | `Value` | Byte | Byte value to append | **Example**: ```vb ' Build protocol header oBuffer.AppendByte &H01 ' Version oBuffer.AppendByte &H02 ' Type oBuffer.AppendByte &H03 ' Flags ``` *** ### Peek - View Data (No Consume) **Syntax**: ```vb Public Function Peek(ByVal Offset As Long, ByVal Length As Long, ByRef OutData() As Byte) As Boolean ``` **Parameters**: | Parameter | Type | Description | |-----------|------|-------------| | `Offset` | Long | Offset position (starting from 0) | | `Length` | Long | Number of bytes to view | | `OutData()` | Byte() | Output byte array | **Return Value**: `Boolean` - Returns `True` if successful, otherwise `False` **Description**: * Read-only operation, does not modify buffer * Suitable for pre-checking data **Example**: ```vb ' Check if first 4 bytes are specific value Dim baHeader() As Byte If oBuffer.Peek(0, 4, baHeader) Then If baHeader(0) = &HDE And baHeader(1) = &HAD Then Debug.Print "Magic number detected" End If End If ``` *** ### PeekByte - View Single Byte **Syntax**: ```vb Public Function PeekByte(ByVal Offset As Long) As Byte ``` **Parameters**: | Parameter | Type | Description | |-----------|------|-------------| | `Offset` | Long | Offset position | **Return Value**: Read byte value **Example**: ```vb ' Check first byte Dim bFirst As Byte bFirst = oBuffer.PeekByte(0) Debug.Print "First byte: " & Hex$(bFirst) ``` *** ### Consume - Consume Data **Syntax**: ```vb Public Sub Consume(ByVal Length As Long) ``` **Parameters**: | Parameter | Type | Description | |-----------|------|-------------| | `Length` | Long | Number of bytes to consume | **Description**: * Removes specified number of bytes from the front of the buffer * Remaining data moves forward * Buffer becomes empty if all data is consumed **Example**: ```vb ' Consume first 4 bytes oBuffer.Consume 4 ' Consume processed data oBuffer.Consume lProcessedBytes ``` *** ### Extract - Extract and Consume Data **Syntax**: ```vb Public Function Extract(ByVal Length As Long) As Byte() ``` **Parameters**: | Parameter | Type | Description | |-----------|------|-------------| | `Length` | Long | Number of bytes to extract | **Return Value**: Extracted byte array **Description**: * Returns data of specified length * Automatically removes from buffer **Example**: ```vb ' Extract and consume first 10 bytes Dim baData() As Byte baData = oBuffer.Extract(10) Debug.Print "Extracted " & (UBound(baData) + 1) & " bytes" ' WebSocket frame extraction example Private Sub ExtractFrame(oBuffer As cByteBuffer) Dim oFrame As New cWebSocketFrame If oFrame.ParseHeader(oBuffer) Then If oFrame.IsCompleteFrame(oBuffer) Then Dim baFrame() As Byte baFrame = oBuffer.Extract(oFrame.TotalFrameLength) ' Process frame... End If End If End Sub ``` *** ### ToArray - Get All Data **Syntax**: ```vb Public Function ToArray() As Byte() ``` **Return Value**: Copy of all buffer data **Description**: * Returns a copy of the data, does not affect the buffer * Returns empty array for empty buffer **Example**: ```vb ' Get all data Dim baAll() As Byte baAll = oBuffer.ToArray Debug.Print "Total data: " & (UBound(baAll) + 1) & " bytes" ' Save to file SaveToFile "data.bin", baAll ``` *** ### Clear - Clear Buffer **Syntax**: ```vb Public Sub Clear() ``` **Description**: Clears all data but retains capacity. **Example**: ```vb ' Clear buffer oBuffer.Clear Debug.Print "Buffer cleared, size: " & oBuffer.Size ``` *** ### Reset - Reset Buffer **Syntax**: ```vb Public Sub Reset() ``` **Description**: * Clears all data * Resets capacity to initial value (4KB) **Example**: ```vb ' Complete reset oBuffer.Reset Debug.Print "Buffer reset, capacity: " & oBuffer.Capacity ``` *** ### GetBufferPtr - Get Buffer Pointer **Syntax**: ```vb Public Function GetBufferPtr() As Long ``` **Return Value**: Memory address of internal buffer **Description**: * Used for high-performance scenarios * ⚠️ Dangerous operation, do not write beyond Size range **Example**: ```vb ' High-performance filling (advanced usage only) Dim pBuffer As Long pBuffer = oBuffer.GetBufferPtr If pBuffer <> 0 Then ' Use CopyMemory API to write directly CopyMemory ByVal pBuffer, baData(0), UBound(baData) + 1 oBuffer.Size = oBuffer.Size + UBound(baData) + 1 End If ``` *** ## 📝 Usage Examples ### WebSocket Frame Parsing ```vb Private Sub ProcessWebSocketData(oBuffer As cByteBuffer) Dim oFrame As New cWebSocketFrame Do While oBuffer.Size >= 2 ' Parse header If Not oFrame.ParseHeader(oBuffer) Then Exit Do ' Need more data End If ' Check completeness If Not oFrame.IsCompleteFrame(oBuffer) Then Exit Do ' Need more data End If ' Extract frame Dim baFrame() As Byte baFrame = oBuffer.Extract(oFrame.TotalFrameLength) ' Process frame ProcessFrame baFrame, oFrame Loop End Sub ``` ### Network Data Reception ```vb Private WithEvents m_Socket As cWinsock Private m_RecvBuffer As cByteBuffer Private Sub Form_Load() Set m_RecvBuffer = New cByteBuffer End Sub Private Sub m_Socket_DataArrival(Client As cWinsock, ByVal bytesTotal As Long) Dim baData() As Byte Client.GetData baData, vbByte + vbArray ' Append to buffer m_RecvBuffer.Append baData ' Process complete messages in buffer ProcessBuffer End Sub Private Sub ProcessBuffer() Do While m_RecvBuffer.Size >= 4 ' Read message length (assume first 4 bytes are length) Dim lLen As Long lLen = CLng(m_RecvBuffer.PeekByte(0)) * 256& ^ 3 + _ CLng(m_RecvBuffer.PeekByte(1)) * 256& ^ 2 + _ CLng(m_RecvBuffer.PeekByte(2)) * 256& + _ CLng(m_RecvBuffer.PeekByte(3)) ' Check if complete message exists If m_RecvBuffer.Size < 4 + lLen Then Exit Do ' Need more data End If ' Extract message header m_RecvBuffer.Consume 4 ' Extract message body Dim baMessage() As Byte baMessage = m_RecvBuffer.Extract(lLen) ' Process message ProcessMessage baMessage Loop End Sub ``` ### Protocol Header Building ```vb Private Function BuildProtocolHeader() As cByteBuffer Dim oBuffer As New cByteBuffer ' Build protocol header oBuffer.AppendByte &H01 ' Version oBuffer.AppendByte &H00 ' Type oBuffer.AppendByte &H00 ' Flags oBuffer.AppendByte &H00 ' Reserved ' Add length (4 bytes) Dim lLen As Long lLen = 1234 oBuffer.AppendByte (lLen And &HFF000000) \ &H1000000 oBuffer.AppendByte (lLen And &HFF0000) \ &H10000 oBuffer.AppendByte (lLen And &HFF00&) \ &H100& oBuffer.AppendByte (lLen And &HFF&) Set BuildProtocolHeader = oBuffer End Function ``` ### Data Fragmentation Handling ```vb Private m_FragmentBuffer As cByteBuffer Private Sub HandleFragmentedFrame(oFrame As cWebSocketFrame, oBuffer As cByteBuffer) ' Extract frame Dim baPayload() As Byte baPayload = oBuffer.Extract(oFrame.TotalFrameLength) If m_FragmentBuffer.IsEmpty Then ' First fragment If Not oFrame.FIN Then ' Start fragmented message m_FragmentBuffer.Clear m_FragmentBuffer.Append baPayload Else ' Single frame (no fragmentation) ProcessCompleteMessage baPayload, oFrame.OpCode End If Else ' Subsequent fragments m_FragmentBuffer.Append baPayload If oFrame.FIN Then ' Last fragment Dim baComplete() As Byte baComplete = m_FragmentBuffer.ToArray ProcessCompleteMessage baComplete, oFrame.OpCode m_FragmentBuffer.Clear End If End If End Sub ``` *** ## ⚠️ Notes 1. **Capacity auto-growth** - Append will automatically expand if exceeding capacity 2. **Peek is read-only** - Peek operations do not modify buffer 3. **Consume removes** - Data is deleted after Consume 4. **Extract consumes** - Extract is equivalent to Peek + Consume 5. **GetBufferPtr is dangerous** - For advanced use only, ensure no out-of-bounds access *** ## 🔍 Performance Optimization ### Batch Append ```vb ' ✅ Good: single Append Dim baData() As Byte baData = BuildLargeData() oBuffer.Append baData ' ❌ Bad: multiple Appends For i = 0 To 10000 oBuffer.AppendByte baData(i) Next i ``` ### Avoid Frequent ToArray ```vb ' ✅ Good: direct use of Peek/Consume If oBuffer.Peek(0, 4, baHeader) Then ProcessHeader baHeader End If ' ❌ Bad: frequent ToArray Dim baAll() As Byte baAll = oBuffer.ToArray For i = 0 To 100 ProcessSegment baAll, i * 100, 100 Next i ``` *** **Last Updated**: 2026-01-10 --- --- url: /zh/vbman/collection/methods.md --- # cCollection 方法参考 ## 📋 方法列表 | 方法 | 说明 | |------|------| | `Add` | 添加元素（自动覆盖重复 Key） | | `Remove` | 删除元素（通过 Key 或 Index） | | `RemoveAll` | 清空集合 | | `Update` | 更新已存在的元素 | | `Exists` | 检查 Key 是否存在 | | `Count` | 获取元素数量 | | `KeyByIndex` | 通过索引获取 Key | | `Keys` | 获取所有 Key 数组 | | `Items` | 获取所有 Value 数组 | | `RenameKey` | 重命名 Key | | `SortByKey` | 按 Key 排序集合 | | `SortByValue` | 按 Value 排序集合 | | `GetSortedKeys` | 获取排序后的 Key 数组（不修改集合） | | `GetSortedValuesByKey` | 获取排序后的 Value 数组（不修改集合） | *** ## ➕ Add 方法 ### 说明 添加元素到集合。如果提供了 Key 且已存在，则自动删除旧元素后添加新元素（覆盖更新）。 ### 语法 ```vb Public Sub Add(ByVal Item As Variant, Optional ByVal Key As String = "") ``` ### 参数 | 参数 | 类型 | 说明 | |------|------|------| | `Item` | Variant | 要添加的元素（可以是任意类型） | | `Key` | String | 可选，元素的键名 | ### 使用示例 ```vb Dim col As New cCollection ' 添加不带 Key 的元素 col.Add "普通元素" ' 添加带 Key 的字符串 col.Add "张三", "user1" ' 添加数字 col.Add 100, "count" ' 添加对象 Dim obj As New MyClass col.Add obj, "myObject" ' 覆盖已存在的 Key（自动删除旧值） col.Add "张三-更新", "user1" ' 自动覆盖 ``` *** ## ➖ Remove 方法 ### 说明 删除指定元素（通过 Key 或 Index）。 ### 语法 ```vb Public Sub Remove(ByVal KeyOrIndex As Variant) ``` ### 参数 | 参数 | 类型 | 说明 | |------|------|------| | `KeyOrIndex` | Variant | Key（字符串）或 Index（数字，从1开始） | ### 使用示例 ```vb ' 通过 Key 删除 col.Remove "user1" ' 通过 Index 删除（删除第一个元素） col.Remove 1 ``` *** ## 🧹 RemoveAll 方法 ### 说明 清空集合，删除所有元素。 ### 语法 ```vb Public Sub RemoveAll() ``` ### 使用示例 ```vb ' 清空集合 col.RemoveAll Debug.Print col.Count ' 输出: 0 ``` *** ## 🔄 Update 方法 ### 说明 更新已存在的元素。如果 Key 不存在，则返回 False。 ### 语法 ```vb Public Function Update(ByVal Item As Variant, ByVal Key As String) As Boolean ``` ### 参数 | 参数 | 类型 | 说明 | |------|------|------| | `Item` | Variant | 新的元素值 | | `Key` | String | 要更新的 Key | ### 返回值 Boolean - 更新成功返回 True，Key 不存在返回 False ### 使用示例 ```vb ' 更新已存在的元素 If col.Update("新值", "user1") Then Debug.Print "更新成功" Else Debug.Print "Key 不存在" End If ``` *** ## 🔍 Exists 方法 ### 说明 检查指定的 Key 是否存在于集合中。 ### 语法 ```vb Public Function Exists(ByVal Key As String, Optional CompareCase As Boolean) As Boolean ``` ### 参数 | 参数 | 类型 | 说明 | |------|------|------| | `Key` | String | 要检查的 Key | | `CompareCase` | Boolean | 可选，是否区分大小写（默认 False） | ### 使用示例 ```vb ' 默认不区分大小写 col.Add "Value", "Key" Debug.Print col.Exists("key") ' True Debug.Print col.Exists("KEY") ' True ' 区分大小写 col.Add "Value", "Key" Debug.Print col.Exists("key", True) ' False Debug.Print col.Exists("Key", True) ' True ``` *** ## 🔢 Count 方法 ### 说明 获取集合中元素的数量。 ### 语法 ```vb Public Function Count() As Long ``` ### 使用示例 ```vb Debug.Print "元素数量: " & col.Count ' 检查是否为空 If col.Count = 0 Then Debug.Print "集合为空" End If ``` *** ## 🔑 KeyByIndex 方法 ### 说明 通过索引获取对应的 Key。如果索引无效或该元素无 Key，返回空字符串。 ### 语法 ```vb Public Function KeyByIndex(ByVal Index As Long) As String ``` ### 参数 | 参数 | 类型 | 说明 | |------|------|------| | `Index` | Long | 索引（从1开始） | ### 使用示例 ```vb ' 获取第1个元素的 Key Dim key As String key = col.KeyByIndex(1) If key <> "" Then Debug.Print "第1个元素的 Key: " & key End If ``` *** ## 📋 Keys 方法 ### 说明 获取包含所有 Key 的字符串数组。无 Key 的元素对应空字符串。 ### 语法 ```vb Public Function Keys() As String() ``` ### 返回值 String() - Key 数组（基于0） ### 使用示例 ```vb Dim keyArray() As String keyArray = col.Keys() Dim i As Long For i = LBound(keyArray) To UBound(keyArray) Debug.Print "Key[" & i & "] = " & keyArray(i) Next i ``` *** ## 📦 Items 方法 ### 说明 获取包含所有 Value 的 Variant 数组。 ### 语法 ```vb Public Function Items() As Variant() ``` ### 返回值 Variant() - Value 数组（基于0） ### 使用示例 ```vb Dim itemArray() As Variant itemArray = col.Items() Dim i As Long For i = LBound(itemArray) To UBound(itemArray) Debug.Print "Value[" & i & "] = " & itemArray(i) Next i ``` *** ## ✏️ RenameKey 方法 ### 说明 修改指定 Key 的名称（Dictionary 兼容方法）。 ### 语法 ```vb Public Function RenameKey(ByVal OldKey As String, ByVal NewKey As String) As Boolean ``` ### 参数 | 参数 | 类型 | 说明 | |------|------|------| | `OldKey` | String | 原 Key 名称 | | `NewKey` | String | 新 Key 名称 | ### 返回值 Boolean - 成功返回 True，失败（原 Key 不存在或新 Key 已存在）返回 False ### 使用示例 ```vb ' 重命名 Key If col.RenameKey("oldName", "newName") Then Debug.Print "重命名成功" Else Debug.Print "重命名失败（Key 不存在或新 Key 已存在）" End If ``` *** ## 🔤 SortByKey 方法 ### 说明 按 Key 的字典序升序排序整个集合（会重新组织集合顺序）。 ### 语法 ```vb Public Sub SortByKey() ``` ### 使用示例 ```vb ' 添加元素（乱序） col.Add "Value-C", "Key-C" col.Add "Value-A", "Key-A" col.Add "Value-B", "Key-B" ' 按 Key 排序 col.SortByKey ' 现在遍历将按 Key-A, Key-B, Key-C 顺序 Dim key As Variant For Each key In col.Keys() Debug.Print key Next ``` *** ## 🔠 SortByValue 方法 ### 说明 按 Value 的字典序升序排序整个集合（Value 应为字符串类型）。 ### 语法 ```vb Public Sub SortByValue() ``` ### 使用示例 ```vb ' 添加元素 col.Add "Charlie", "C" col.Add "Alpha", "A" col.Add "Bravo", "B" ' 按 Value 排序 col.SortByValue ' 现在顺序为: Alpha, Bravo, Charlie ``` *** ## 📊 GetSortedKeys 方法 ### 说明 获取按 Key 排序后的 Key 数组（不修改原集合）。 ### 语法 ```vb Public Function GetSortedKeys() As String() ``` ### 返回值 String() - 排序后的 Key 数组 ### 使用示例 ```vb ' 获取排序后的 Keys（不改变原集合顺序） Dim sortedKeys() As String sortedKeys = col.GetSortedKeys() ' 使用排序后的 Keys 遍历 Dim i As Long For i = LBound(sortedKeys) To UBound(sortedKeys) Debug.Print sortedKeys(i) & " = " & col(sortedKeys(i)) Next i ``` *** ## 📈 GetSortedValuesByKey 方法 ### 说明 获取按 Key 排序后的 Value 数组（不修改原集合）。 ### 语法 ```vb Public Function GetSortedValuesByKey() As Variant() ``` ### 返回值 Variant() - 按 Key 排序后的 Value 数组 ### 使用示例 ```vb ' 获取按 Key 排序后的 Values Dim sortedValues() As Variant sortedValues = col.GetSortedValuesByKey() Dim i As Long For i = LBound(sortedValues) To UBound(sortedValues) Debug.Print "Value[" & i & "] = " & sortedValues(i) Next i ``` *** ## 📌 方法使用场景总结 ### 基础增删改查 ```vb Dim col As New cCollection ' 添加 col.Add "Value", "Key" ' 检查存在 If col.Exists("Key") Then ' 更新 col.Update("NewValue", "Key") End If ' 删除 col.Remove "Key" ``` ### 批量操作 ```vb ' 清空 col.RemoveAll ' 获取所有 Keys 和 Values Dim keys() As String Dim values() As Variant keys = col.Keys() values = col.Items() ``` ### 排序场景 ```vb ' 需要排序后遍历但不改变原集合 Dim sortedKeys() As String sortedKeys = col.GetSortedKeys() Dim i As Long For i = LBound(sortedKeys) To UBound(sortedKeys) ProcessItem sortedKeys(i), col(sortedKeys(i)) Next i ' 直接排序集合（后续遍历都是有序） col.SortByKey ``` *** **最后更新**: 2026-05-17 --- --- url: /zh/vbman/collection/overview.md --- # cCollection 概述 ## 📖 简介 `cCollection` 是一个增强版的 VB Collection 类，在标准 Collection 基础上增加了 Dictionary 兼容的方法，以及排序、键管理等功能。 ## ✨ 主要特性 | 特性 | 说明 | |------|------| | **字典兼容** | 提供 Keys/Items/RenameKey 等 Dictionary 风格方法 | | **键管理** | 支持通过 Key 或 Index 访问、修改元素 | | **排序功能** | 支持按 Key 或 Value 对集合进行排序 | | **安全更新** | Add 方法自动处理重复 Key（覆盖更新） | | **For Each 支持** | 支持 VB 标准遍历语法 | ## 🚀 快速开始 ### 创建集合并添加元素 ```vb Dim col As New cCollection ' 添加带 Key 的元素 col.Add "张三", "user1" col.Add "李四", "user2" ' 添加不带 Key 的元素 col.Add "普通元素" ``` ### 访问元素 ```vb ' 通过 Key 访问 Dim name As String name = col.Item("user1") ' 通过 Index 访问（从1开始） name = col.Item(1) ' 简写形式（默认属性） name = col("user1") ``` ### 遍历集合 ```vb ' For Each 遍历 Dim item As Variant For Each item In col Debug.Print item Next ' 通过索引遍历 Dim i As Long For i = 1 To col.Count Debug.Print col(i) Next ``` ### 检查键是否存在 ```vb If col.Exists("user1") Then Debug.Print "用户已存在" End If ' 不区分大小写（默认） If col.Exists("USER1") Then ' 返回 True ``` ## 📁 文档导航 | 文档 | 说明 | |------|------| | [methods.md](./methods.md) | 方法详细参考（Add、Remove、SortByKey 等） | | [properties.md](./properties.md) | 属性详细参考（Count、Item 等） | ## 🆚 与标准 Collection/Dictionary 对比 | 功能 | Collection | Dictionary | cCollection | |------|------------|------------|-------------| | Key 访问 | ✓ | ✓ | ✓ | | Index 访问 | ✓ | - | ✓ | | Exists 检查 | - | ✓ | ✓ | | Keys/Items 方法 | - | ✓ | ✓ | | 排序功能 | - | - | ✓ | | 重复 Key 处理 | 报错 | 覆盖 | 覆盖 | | For Each 支持 | ✓ | ✓ | ✓ | *** **最后更新**: 2026-05-17 --- --- url: /zh/vbman/collection/properties.md --- # cCollection 属性参考 ## 📋 属性列表 | 属性 | 类型 | 读写 | 说明 | | --------------- | ---------- | ---- | -------------------------- | | `Item` | Variant | 读写 | 获取或设置元素（默认属性） | | `RawCollection` | Collection | 只读 | 获取底层 Collection 对象 | *** ## 📦 Item 属性（默认属性） ### 说明 获取或设置集合中的元素。这是默认属性，可以直接使用 `col("key")` 语法。 支持通过 **Key**（字符串）或 **Index**（数字，从1开始）访问。 ### 语法 ```vb ' Get Property Get Item(ByVal KeyOrIndex As Variant) As Variant ' Let（值类型） Property Let Item(ByVal KeyOrIndex As Variant, ByVal Value As Variant) ' Set（对象类型） Property Set Item(ByVal KeyOrIndex As Variant, ByVal Value As Object) ``` ### 参数 | 参数 | 类型 | 说明 | | ------------ | -------------- | -------------------------------------- | | `KeyOrIndex` | Variant | Key（字符串）或 Index（数字，从1开始） | | `Value` | Variant/Object | 要设置的值 | ### 使用示例 #### 获取元素 ```vb Dim col As New cCollection col.Add "张三", "user1" col.Add "李四", "user2" ' 通过 Key 获取（显式写法） Dim name As String name = col.Item("user1") ' 简写形式（利用默认属性） name = col("user1") ' 通过 Index 获取（从1开始） name = col(1) ' 获取第一个元素 ``` #### 设置元素（值类型） ```vb ' 通过 Key 更新（如果 Key 不存在则添加） col.Item("user1") = "张三-更新" ' 简写形式 col("user1") = "张三-更新" ' 通过 Index 更新（需要对应位置已有元素） col(1) = "新值" ``` #### 设置元素（对象类型） ```vb Dim col As New cCollection ' 添加对象 col.Add New cCollection, "dict1" ' 使用 Set 更新对象 Dim newDict As Object Set newDict = New cCollection newDict.Add "key", "value" Set col("dict1") = newDict ``` #### 遍历集合 ```vb ' For Each 遍历（利用 NewEnum） Dim item As Variant For Each item In col Debug.Print item Next ' 通过索引遍历 Dim i As Long For i = 1 To col.Count Debug.Print col(i) Next ' 通过 Keys 遍历 Dim keys() As String keys = col.Keys() Dim key As Variant For Each key In keys Debug.Print key & " = " & col(CStr(key)) Next ``` ### ⚠️ 注意事项 1. **索引从1开始**：与 VB Collection 一致，索引从1开始 2. **Key 不存在时**：获取会返回 Empty，设置会添加新元素 3. **对象处理**：获取对象时需要使用 `Set` 关键字 *** ## 📦 RawCollection 属性 ### 说明 获取底层的原始 Collection 对象。用于需要直接操作 Collection 的高级场景。 ### 语法 ```vb Property Get RawCollection() As Collection ``` ### 返回值 Collection - 底层的 VB Collection 对象 ### 使用示例 ```vb ' 获取底层 Collection Dim rawCol As Collection Set rawCol = col.RawCollection ' 直接使用 Collection 的方法 ' 注意：直接操作 rawCol 不会同步 m_Keys，谨慎使用 Dim count As Long count = rawCol.Count ``` ### ⚠️ 注意事项 直接操作 RawCollection 可能导致 Keys 集合不同步，建议仅在读取场景使用。 *** ## 📌 属性使用场景总结 ### 常见访问模式 ```vb Dim col As New cCollection col.Add "张三", "user1" ' 推荐：通过 Key 访问 Debug.Print col("user1") ' 通过 Index 访问（知道位置时） Debug.Print col(1) ' 安全访问（先检查存在） If col.Exists("user1") Then Debug.Print col("user1") End If ``` ### 对象处理 ```vb ' 存储对象 col.Add SomeObject, "obj1" ' 读取对象（必须使用 Set） Dim obj As MyClass Set obj = col("obj1") ' 更新对象（必须使用 Set） Set col("obj1") = NewObject ``` *** **最后更新**: 2026-05-17 --- --- url: /en/vbman/collection/methods.md --- # cCollection Methods Reference ## 📋 Method List | Method | Description | |--------|-------------| | `Add` | Add element (auto-overwrite duplicate Key) | | `Remove` | Remove element (by Key or Index) | | `RemoveAll` | Clear all elements | | `Update` | Update existing element | | `Exists` | Check if Key exists | | `Count` | Get element count | | `KeyByIndex` | Get Key by Index | | `Keys` | Get all Key array | | `Items` | Get all Value array | | `RenameKey` | Rename a Key | | `SortByKey` | Sort collection by Key | | `SortByValue` | Sort collection by Value | | `GetSortedKeys` | Get sorted Key array (without modifying collection) | | `GetSortedValuesByKey` | Get sorted Value array (without modifying collection) | *** ## ➕ Add Method ### Description Adds an element to the collection. If a Key is provided and already exists, the old element is automatically removed before adding the new one (overwrite update). ### Syntax ```vb Public Sub Add(ByVal Item As Variant, Optional ByVal Key As String = "") ``` ### Parameters | Parameter | Type | Description | |-----------|------|-------------| | `Item` | Variant | Element to add (can be any type) | | `Key` | String | Optional, key name for the element | ### Example ```vb Dim col As New cCollection ' Add element without Key col.Add "Plain element" ' Add string with Key col.Add "John", "user1" ' Add number col.Add 100, "count" ' Add object Dim obj As New MyClass col.Add obj, "myObject" ' Overwrite existing Key (auto remove old value) col.Add "John-Updated", "user1" ' Auto overwrite ``` *** ## ➖ Remove Method ### Description Removes a specified element (by Key or Index). ### Syntax ```vb Public Sub Remove(ByVal KeyOrIndex As Variant) ``` ### Parameters | Parameter | Type | Description | |-----------|------|-------------| | `KeyOrIndex` | Variant | Key (string) or Index (number, starts from 1) | ### Example ```vb ' Remove by Key col.Remove "user1" ' Remove by Index (remove first element) col.Remove 1 ``` *** ## 🧹 RemoveAll Method ### Description Clears the collection, removing all elements. ### Syntax ```vb Public Sub RemoveAll() ``` ### Example ```vb ' Clear the collection col.RemoveAll Debug.Print col.Count ' Output: 0 ``` *** ## 🔄 Update Method ### Description Updates an existing element. Returns False if Key does not exist. ### Syntax ```vb Public Function Update(ByVal Item As Variant, ByVal Key As String) As Boolean ``` ### Parameters | Parameter | Type | Description | |-----------|------|-------------| | `Item` | Variant | New element value | | `Key` | String | Key to update | ### Return Value Boolean - Returns True on success, False if Key doesn't exist ### Example ```vb ' Update existing element If col.Update("New value", "user1") Then Debug.Print "Update successful" Else Debug.Print "Key not found" End If ``` *** ## 🔍 Exists Method ### Description Checks if the specified Key exists in the collection. ### Syntax ```vb Public Function Exists(ByVal Key As String, Optional CompareCase As Boolean) As Boolean ``` ### Parameters | Parameter | Type | Description | |-----------|------|-------------| | `Key` | String | Key to check | | `CompareCase` | Boolean | Optional, case-sensitive comparison (default False) | ### Example ```vb ' Default case-insensitive col.Add "Value", "Key" Debug.Print col.Exists("key") ' True Debug.Print col.Exists("KEY") ' True ' Case-sensitive col.Add "Value", "Key" Debug.Print col.Exists("key", True) ' False Debug.Print col.Exists("Key", True) ' True ``` *** ## 🔢 Count Method ### Description Gets the number of elements in the collection. ### Syntax ```vb Public Function Count() As Long ``` ### Example ```vb Debug.Print "Element count: " & col.Count ' Check if empty If col.Count = 0 Then Debug.Print "Collection is empty" End If ``` *** ## 🔑 KeyByIndex Method ### Description Gets the Key corresponding to an index. Returns empty string if index is invalid or element has no Key. ### Syntax ```vb Public Function KeyByIndex(ByVal Index As Long) As String ``` ### Parameters | Parameter | Type | Description | |-----------|------|-------------| | `Index` | Long | Index (starts from 1) | ### Example ```vb ' Get Key of first element Dim key As String key = col.KeyByIndex(1) If key <> "" Then Debug.Print "Key of first element: " & key End If ``` *** ## 📋 Keys Method ### Description Gets a string array containing all Keys. Elements without Key correspond to empty string. ### Syntax ```vb Public Function Keys() As String() ``` ### Return Value String() - Key array (0-based) ### Example ```vb Dim keyArray() As String keyArray = col.Keys() Dim i As Long For i = LBound(keyArray) To UBound(keyArray) Debug.Print "Key[" & i & "] = " & keyArray(i) Next i ``` *** ## 📦 Items Method ### Description Gets a Variant array containing all Values. ### Syntax ```vb Public Function Items() As Variant() ``` ### Return Value Variant() - Value array (0-based) ### Example ```vb Dim itemArray() As Variant itemArray = col.Items() Dim i As Long For i = LBound(itemArray) To UBound(itemArray) Debug.Print "Value[" & i & "] = " & itemArray(i) Next i ``` *** ## ✏️ RenameKey Method ### Description Renames a specified Key (Dictionary-compatible method). ### Syntax ```vb Public Function RenameKey(ByVal OldKey As String, ByVal NewKey As String) As Boolean ``` ### Parameters | Parameter | Type | Description | |-----------|------|-------------| | `OldKey` | String | Original Key name | | `NewKey` | String | New Key name | ### Return Value Boolean - Returns True on success, False on failure (original Key doesn't exist or new Key already exists) ### Example ```vb ' Rename Key If col.RenameKey("oldName", "newName") Then Debug.Print "Rename successful" Else Debug.Print "Rename failed (Key not found or new Key already exists)" End If ``` *** ## 🔤 SortByKey Method ### Description Sorts the entire collection in ascending alphabetical order by Key (reorganizes collection order). ### Syntax ```vb Public Sub SortByKey() ``` ### Example ```vb ' Add elements (unordered) col.Add "Value-C", "Key-C" col.Add "Value-A", "Key-A" col.Add "Value-B", "Key-B" ' Sort by Key col.SortByKey ' Now iteration will be in order: Key-A, Key-B, Key-C Dim key As Variant For Each key In col.Keys() Debug.Print key Next ``` *** ## 🔠 SortByValue Method ### Description Sorts the entire collection in ascending alphabetical order by Value (Value should be string type). ### Syntax ```vb Public Sub SortByValue() ``` ### Example ```vb ' Add elements col.Add "Charlie", "C" col.Add "Alpha", "A" col.Add "Bravo", "B" ' Sort by Value col.SortByValue ' Now order is: Alpha, Bravo, Charlie ``` *** ## 📊 GetSortedKeys Method ### Description Gets a Key array sorted by Key (does not modify the original collection). ### Syntax ```vb Public Function GetSortedKeys() As String() ``` ### Return Value String() - Sorted Key array ### Example ```vb ' Get sorted Keys (without changing original collection order) Dim sortedKeys() As String sortedKeys = col.GetSortedKeys() ' Iterate using sorted Keys Dim i As Long For i = LBound(sortedKeys) To UBound(sortedKeys) Debug.Print sortedKeys(i) & " = " & col(sortedKeys(i)) Next i ``` *** ## 📈 GetSortedValuesByKey Method ### Description Gets a Value array sorted by Key (does not modify the original collection). ### Syntax ```vb Public Function GetSortedValuesByKey() As Variant() ``` ### Return Value Variant() - Value array sorted by Key ### Example ```vb ' Get Values sorted by Key Dim sortedValues() As Variant sortedValues = col.GetSortedValuesByKey() Dim i As Long For i = LBound(sortedValues) To UBound(sortedValues) Debug.Print "Value[" & i & "] = " & sortedValues(i) Next i ``` *** ## 📌 Method Usage Scenarios Summary ### Basic CRUD Operations ```vb Dim col As New cCollection ' Add col.Add "Value", "Key" ' Check existence If col.Exists("Key") Then ' Update col.Update "NewValue", "Key" End If ' Delete col.Remove "Key" ``` ### Batch Operations ```vb ' Clear col.RemoveAll ' Get all Keys and Values Dim keys() As String Dim values() As Variant keys = col.Keys() values = col.Items() ``` ### Sorting Scenarios ```vb ' Need sorted iteration without modifying original collection Dim sortedKeys() As String sortedKeys = col.GetSortedKeys() Dim i As Long For i = LBound(sortedKeys) To UBound(sortedKeys) ProcessItem sortedKeys(i), col(sortedKeys(i)) Next i ' Directly sort collection (subsequent iterations are sorted) col.SortByKey ``` *** **Last Updated**: 2026-05-17 --- --- url: /en/vbman/collection/overview.md --- # cCollection Overview ## 📖 Introduction `cCollection` is an enhanced version of the VB Collection class that adds Dictionary-compatible methods, sorting, and key management features on top of the standard Collection. ## ✨ Key Features | Feature | Description | |---------|-------------| | **Dictionary Compatible** | Provides Keys/Items/RenameKey methods in Dictionary style | | **Key Management** | Access and modify elements via Key or Index | | **Sorting** | Sort the collection by Key or Value | | **Safe Updates** | Add method automatically handles duplicate Keys (overwrite update) | | **For Each Support** | Supports VB standard iteration syntax | ## 🚀 Quick Start ### Creating a Collection and Adding Elements ```vb Dim col As New cCollection ' Add elements with Key col.Add "John", "user1" col.Add "Jane", "user2" ' Add elements without Key col.Add "Plain element" ``` ### Accessing Elements ```vb ' Access by Key Dim name As String name = col.Item("user1") ' Access by Index (starts from 1) name = col.Item(1) ' Short form (default property) name = col("user1") ``` ### Iterating Through Collection ```vb ' For Each iteration Dim item As Variant For Each item In col Debug.Print item Next ' Iterate by index Dim i As Long For i = 1 To col.Count Debug.Print col(i) Next ``` ### Checking if Key Exists ```vb If col.Exists("user1") Then Debug.Print "User exists" End If ' Case-insensitive (default) If col.Exists("USER1") Then ' Returns True ``` ## 📁 Documentation Navigation | Document | Description | |----------|-------------| | [methods.md](./methods.md) | Method reference (Add, Remove, SortByKey, etc.) | | [properties.md](./properties.md) | Property reference (Count, Item, etc.) | ## 🆚 Comparison with Standard Collection/Dictionary | Feature | Collection | Dictionary | cCollection | |---------|------------|------------|-------------| | Key Access | ✓ | ✓ | ✓ | | Index Access | ✓ | - | ✓ | | Exists Check | - | ✓ | ✓ | | Keys/Items Methods | - | ✓ | ✓ | | Sorting | - | - | ✓ | | Duplicate Key Handling | Error | Overwrite | Overwrite | | For Each Support | ✓ | ✓ | ✓ | *** **Last Updated**: 2026-05-17 --- --- url: /en/vbman/collection/properties.md --- # cCollection Properties Reference ## 📋 Property List | Property | Type | Read/Write | Description | | --------------- | ---------- | ---------- | ------------------------------------- | | `Item` | Variant | Read/Write | Get or set element (default property) | | `RawCollection` | Collection | Read-only | Get underlying Collection object | *** ## 📦 Item Property (Default Property) ### Description Gets or sets an element in the collection. This is the default property, allowing direct use of `col("key")` syntax. Supports access via **Key** (string) or **Index** (number, starting from 1). ### Syntax ```vb ' Get Property Get Item(ByVal KeyOrIndex As Variant) As Variant ' Let (value type) Property Let Item(ByVal KeyOrIndex As Variant, ByVal Value As Variant) ' Set (object type) Property Set Item(ByVal KeyOrIndex As Variant, ByVal Value As Object) ``` ### Parameters | Parameter | Type | Description | | ------------ | -------------- | --------------------------------------------- | | `KeyOrIndex` | Variant | Key (string) or Index (number, starts from 1) | | `Value` | Variant/Object | Value to set | ### Example #### Getting Elements ```vb Dim col As New cCollection col.Add "John", "user1" col.Add "Jane", "user2" ' Get by Key (explicit syntax) Dim name As String name = col.Item("user1") ' Short form (using default property) name = col("user1") ' Get by Index (starts from 1) name = col(1) ' Get first element ``` #### Setting Elements (Value Type) ```vb ' Update by Key (adds if Key doesn't exist) col.Item("user1") = "John-Updated" ' Short form col("user1") = "John-Updated" ' Update by Index (requires element at that position) col(1) = "New value" ``` #### Setting Elements (Object Type) ```vb Dim col As New cCollection ' Add object col.Add New cCollection, "dict1" ' Update object using Set Dim newDict As Object Set newDict = New cCollection newDict.Add "key", "value" Set col("dict1") = newDict ``` #### Iterating Through Collection ```vb ' For Each iteration (using NewEnum) Dim item As Variant For Each item In col Debug.Print item Next ' Iterate by index Dim i As Long For i = 1 To col.Count Debug.Print col(i) Next ' Iterate by Keys Dim keys() As String keys = col.Keys() Dim key As Variant For Each key In keys Debug.Print key & " = " & col(CStr(key)) Next ``` ### ⚠️ Notes 1. **Index starts from 1**: Consistent with VB Collection, index starts from 1 2. **Key not found**: Getting returns Empty, setting adds new element 3. **Object handling**: Must use `Set` keyword when getting objects *** ## 📦 RawCollection Property ### Description Gets the underlying raw Collection object. Used for advanced scenarios requiring direct Collection manipulation. ### Syntax ```vb Property Get RawCollection() As Collection ``` ### Return Value Collection - The underlying VB Collection object ### Example ```vb ' Get underlying Collection Dim rawCol As Collection Set rawCol = col.RawCollection ' Directly use Collection methods ' Note: Direct manipulation of rawCol won't sync m_Keys, use with caution Dim count As Long count = rawCol.Count ``` ### ⚠️ Notes Directly manipulating RawCollection may cause Keys collection to become out of sync. It is recommended to use this only for read operations. *** ## 📌 Property Usage Scenarios Summary ### Common Access Patterns ```vb Dim col As New cCollection col.Add "John", "user1" ' Recommended: Access by Key Debug.Print col("user1") ' Access by Index (when position is known) Debug.Print col(1) ' Safe access (check existence first) If col.Exists("user1") Then Debug.Print col("user1") End If ``` ### Object Handling ```vb ' Store object col.Add SomeObject, "obj1" ' Read object (must use Set) Dim obj As MyClass Set obj = col("obj1") ' Update object (must use Set) Set col("obj1") = NewObject ``` *** **Last Updated**: 2026-05-17 --- --- url: /zh/vbman/database/testing.md --- # cDatabase 测试指南 ## 📖 简介 `Demo_Database.bas` 是 cDatabase 类的完整测试用例模块，提供了从基础连接到高级功能的全面测试。 ## 📁 文件位置 ``` src/Demos/database/Demo_Database.bas ``` ## ⚙️ 配置说明 在运行测试前，需要修改模块顶部的数据库配置参数： ```vb '数据库配置 - 请根据实际环境修改 Private Const TEST_DB_TYPE As Long = enumDbType.Mysql '1:Access, 2:Mysql, 3:MsSql, 4:Csv Private Const TEST_DB_ADDRESS As String = "172.18.131.71,3306" Private Const TEST_DB_USERNAME As String = "root" Private Const TEST_DB_PASSWORD As String = "root" Private Const TEST_DB_DATABASE As String = "testdb" ``` ### 数据库类型支持 | 值 | 常量 | 说明 | | --- | ------------------- | ----------------- | | 1 | `enumDbType.Access` | Access 数据库 | | 2 | `enumDbType.Mysql` | MySQL 数据库 | | 3 | `enumDbType.MsSql` | SQL Server 数据库 | | 4 | `enumDbType.Csv` | CSV 文件数据源 | | 5 | `enumDbType.Custom` | 自定义连接字符串 | ### 连接字符串示例 **MySQL 标准连接：** ```vb TEST_DB_ADDRESS = "172.18.131.71,3306" ``` **MySQL ODBC 自定义 DSN：** ```vb TEST_DB_ADDRESS = "DRIVER=VBMAN Mysql ODBC Driver;MULTI_HOST=1;SERVER=10.0.0.252,3306;DATABASE=mysql;UID=root;PWD=root" ``` ## 🚀 运行测试 ### 运行所有测试 ```vb '在立即窗口中执行 Demo_Database.RunAllTests ``` 运行后将依次执行以下测试： | 序号 | 测试名称 | 说明 | | ---- | ------------------ | ------------------ | | 0 | CreateDatabase | 创建测试数据库 | | 1 | ConnectDisconnect | 连接和断开数据库 | | 2 | CreateTestTable | 创建测试表 | | 3 | InsertData | 插入数据测试 | | 4 | QueryData | 查询数据测试 | | 5 | UpdateData | 更新数据测试 | | 6 | DeleteData | 删除数据测试 | | 7 | Transaction | 事务处理测试 | | 8 | ParameterizedQuery | 参数化查询测试 | | 9 | Pagination | 分页查询测试 | | 10 | LastInsertId | 获取最后插入ID测试 | | 11 | Count | 统计记录数测试 | | 12 | TableExists | 检查表是否存在测试 | | 13 | GetTableFields | 获取表字段列表测试 | | 14 | BatchInsert | 批量插入数据测试 | | 15 | GetDatabases | 获取数据库列表测试 | | 16 | GetTables | 获取表列表测试 | | 17 | Escape | SQL转义测试 | | 18 | CheckConnection | 检查连接状态测试 | | 19 | GetVersion | 获取版本信息测试 | | 20 | ConnectionPool | 连接池功能测试 | | 21 | AsyncExecute | 异步执行测试 | ### 运行单个测试 ```vb '运行特定测试用例 Demo_Database.TestSpecificCase "connect" Demo_Database.TestSpecificCase "query" Demo_Database.TestSpecificCase "transaction" ``` **支持的测试用例名称：** | 名称 | 测试内容 | | ------------- | ---------- | | `database` | 创建数据库 | | `connect` | 连接测试 | | `insert` | 插入测试 | | `query` | 查询测试 | | `transaction` | 事务测试 | | `pagination` | 分页测试 | ### 显示帮助信息 ```vb Demo_Database.ShowTestHelp ``` ## 📋 测试内容详解 ### 基础连接测试 ```vb '测试连接和断开 Private Sub Test_ConnectDisconnect() Dim bConnect As Boolean bConnect = TestDB.Connect(TEST_DB_TYPE, TEST_DB_ADDRESS, _ TEST_DB_USERNAME, TEST_DB_PASSWORD, TEST_DB_DATABASE) If bConnect Then Debug.Print "数据库连接成功" Debug.Print "连接状态: " & TestDB.IsConnect Debug.Print "连接版本: " & TestDB.GetVersion() End If End Sub ``` ### CRUD 操作测试 **插入数据：** ```vb '单条插入 sqlInsert = "INSERT INTO test_users (username, email, age, score) " & _ "VALUES ('张三', 'zhangsan@test.com', 25, 95.5)" bInsert = TestDB.Sql(sqlInsert).Exec(lAffected) '批量插入 For i = 1 To 10 sqlInsert = "INSERT INTO test_users (...) VALUES (...)" bInsert = TestDB.Sql(sqlInsert).Exec(lAffected) Next i ``` **查询数据：** ```vb '使用 Recordset 查询 sqlSelect = "SELECT * FROM test_users" bQuery = TestDB.Sql(sqlSelect).Query() If bQuery Then Debug.Print "记录总数: " & TestDB.Rs.RecordCount End If '使用 Rows 集合查询 bQuery = TestDB.Sql(sqlSelect).Fetch() If bQuery Then Debug.Print "Rows集合数量: " & TestDB.Rows.count End If ``` ### 事务测试 ```vb '测试事务提交 TestDB.TransBegin() TestDB.Sql("INSERT INTO ...").Exec TestDB.Sql("INSERT INTO ...").Exec TestDB.TransCommit() '测试事务回滚 TestDB.TransBegin() TestDB.Sql("INSERT INTO ...").Exec TestDB.TransRollback() ``` ### 参数化查询测试 ```vb '参数化插入 sqlInsert = "INSERT INTO test_users (username, email, age, score) VALUES (?, ?, ?, ?)" bExec = TestDB.Sql(sqlInsert) _ .Param("username", "参数用户1", adVarChar) _ .Param("email", "param1@test.com", adVarChar) _ .Param("age", 35, adInteger) _ .Param("score", 92.5, adDouble) _ .ExecParam() '参数化查询 sqlSelect = "SELECT * FROM test_users WHERE username = ? AND age > ?" bQuery = TestDB.Sql(sqlSelect) _ .Param("username", "参数用户1", adVarChar) _ .Param("age", 30, adInteger) _ .QueryParam() ``` ### 分页查询测试 ```vb '查询第1页，每页3条 sqlSelect = "SELECT * FROM test_users ORDER BY id" bQuery = TestDB.Sql(sqlSelect).Page(1, 3).Query() '查询第2页，使用 Fetch bQuery = TestDB.Sql(sqlSelect).Page(2, 3).Fetch() Debug.Print "Rows集合数量: " & TestDB.Rows.count ``` ### 批量插入测试 ```vb '准备批量数据 Dim Data As New Collection Dim Row As Dictionary For i = 1 To 5 Set Row = New Dictionary Row.Add "username", "批量用户" & i Row.Add "email", "batch" & i & "@test.com" Row.Add "age", 50 + i Row.Add "score", 90 + i Data.Add Row Next '执行批量插入 bBatch = TestDB.BatchInsert("test_users", Data) ``` ### 连接池测试 ```vb '创建连接池实例 Set dbPool1 = TestDB.ConnInst("Pool1") Set dbPool2 = TestDB.ConnInst("Pool2") '使用连接池实例查询 bQuery = dbPool1.Sql("SELECT COUNT(*) AS cnt FROM test_users").Query() '移除连接池实例 TestDB.ConnInstRemove "Pool1" TestDB.ConnInstRemove "Pool2" ``` ### 异步执行测试 ```vb '异步执行SQL sqlInsert = "INSERT INTO test_users (...) VALUES (...)" bExec = TestDB.Sql(sqlInsert).Async().Exec() ``` ## 📊 测试输出示例 ``` ====================================================== 开始执行 cDatabase 类完整测试 ====================================================== >>> 测试0: 创建测试数据库 [OK] 已连接到数据库服务器 数据库 'testdb' 已存在，跳过创建 >>> 测试1: 连接和断开数据库 [OK] 数据库连接成功 连接状态: True 连接版本: ADO 6.1 连接状态检查: 正常 >>> 测试2: 创建测试表 [OK] 测试表创建成功 表存在检查: 存在 >>> 测试3: 插入数据 [OK] 插入单条记录成功 影响行数: 1 插入ID: 1 开始批量插入记录... [OK] 批量插入完成 >>> 测试4: 查询数据 [OK] 查询成功 记录总数: 11 前3条记录: ID: 1, 用户名: 张三, 年龄: 25 ID: 2, 用户名: 用户1, 年龄: 21 ID: 3, 用户名: 用户2, 年龄: 22 [OK] Fetch 查询成功 Rows集合数量: 11 第一行数据: id: 1 username: 张三 email: zhangsan@test.com ... ====================================================== 所有测试完成！耗时: 2.35 秒 ====================================================== ``` ## ⚠️ 注意事项 1. **自动创建数据库**：测试会自动创建 `TEST_DB_DATABASE` 指定的数据库（如果不存在） 2. **测试表管理**：测试会创建 `test_users` 表，测试结束后自动删除 3. **连接配置**：确保数据库服务器可访问，用户名密码正确 4. **权限要求**：需要具有创建数据库、创建表、插入、更新、删除等权限 5. **ODBC 驱动**：使用 MySQL 时需要安装 MySQL ODBC 驱动 ## 🔧 故障排除 ### 连接失败 ``` [FAIL] 数据库连接失败 错误信息: [08001] [Microsoft][ODBC 驱动程序管理器] 未发现数据源名称... ``` **解决方案：** * 检查 `TEST_DB_ADDRESS` 是否正确 * 确认 MySQL ODBC 驱动已安装 * 尝试使用自定义 DSN 连接字符串 ### 创建数据库失败 ``` [FAIL] 创建数据库失败 错误信息: Access denied for user... ``` **解决方案：** * 确认用户具有创建数据库权限 * 检查用户名密码是否正确 *** ## 📎 完整源码 以下为 `Demo_Database.bas` 完整源码： ```vb '=============================================================== ' cDatabase 类完整测试用例模块 ' 作者：邓伟，215879458@qq.com ' 日期：2026-02-26 ' 说明：测试 cDatabase 类的所有功能，包括连接、查询、事务、分页等 '=============================================================== Option Explicit '数据库配置 - 请根据实际环境修改 Private Const TEST_DB_TYPE As Long = enumDbType.Mysql '1:Access, 2:Mysql, 3:MsSql, 4:Csv, 5:Custom Private Const TEST_DB_ADDRESS As String = "172.18.131.71,3306" '如果使用CUSTOM，这里参数2填写完整DSN，后面参数3+不用填写 Private Const TEST_DB_USERNAME As String = "root" Private Const TEST_DB_PASSWORD As String = "root" Private Const TEST_DB_DATABASE As String = "testdb" '测试数据库对象 Private TestDB As cDataBase Private TestResult As String '数据库配置 - 用于创建数据库的连接（不指定数据库） Private Const ADMIN_DB_DATABASE As String = "" ' 连接时不指定数据库，用于创建新数据库 '=============================================================== ' 主测试入口 '=============================================================== Public Sub RunAllTests() Dim StartTime As Double StartTime = Timer Debug.Print "======================================================" Debug.Print "开始执行 cDatabase 类完整测试" Debug.Print "======================================================" Debug.Print "" '初始化测试数据库 Set TestDB = New cDataBase '执行所有测试 Call Test_CreateDatabase Call Test_ConnectDisconnect Call Test_CreateTestTable Call Test_InsertData Call Test_QueryData Call Test_UpdateData Call Test_DeleteData Call Test_Transaction Call Test_ParameterizedQuery Call Test_Pagination Call Test_LastInsertId Call Test_Count Call Test_TableExists Call Test_GetTableFields Call Test_BatchInsert Call Test_GetDatabases Call Test_GetTables Call Test_Escape Call Test_CheckConnection Call Test_GetVersion Call Test_ConnectionPool Call Test_AsyncExecute '清理 Call Test_Cleanup Call Test_Disconnect Dim EndTime As Double EndTime = Timer Debug.Print "" Debug.Print "======================================================" Debug.Print "所有测试完成！耗时: " & Format(EndTime - StartTime, "0.00") & " 秒" Debug.Print "======================================================" End Sub '=============================================================== ' 测试0: 创建测试数据库 '=============================================================== Private Sub Test_CreateDatabase() Debug.Print ">>> 测试0: 创建测试数据库" On Error GoTo ErrHandler '先连接到服务器（不指定数据库） Dim AdminDB As New cDataBase Dim bConnect As Boolean bConnect = AdminDB.Connect(TEST_DB_TYPE, TEST_DB_ADDRESS, TEST_DB_USERNAME, TEST_DB_PASSWORD, ADMIN_DB_DATABASE) If bConnect Then Debug.Print " [OK] 已连接到数据库服务器" Else Debug.Print " [FAIL] 连接数据库服务器失败" Debug.Print " 错误信息: " & AdminDB.LastErr Exit Sub End If '检查数据库是否已存在 Dim bExists As Boolean bExists = DatabaseExists(AdminDB, TEST_DB_DATABASE) If bExists Then Debug.Print " 数据库 '" & TEST_DB_DATABASE & "' 已存在，跳过创建" Else '创建数据库 Dim sqlCreate As String sqlCreate = "CREATE DATABASE `" & TEST_DB_DATABASE & "` DEFAULT CHARACTER SET utf8mb4 COLLATE utf8mb4_unicode_ci" Dim bCreate As Boolean bCreate = AdminDB.Sql(sqlCreate).Exec() If bCreate Then Debug.Print " [OK] 数据库 '" & TEST_DB_DATABASE & "' 创建成功" Else Debug.Print " [FAIL] 创建数据库失败" Debug.Print " 错误信息: " & AdminDB.LastErr End If End If '断开管理连接 Call AdminDB.DisConnect Set AdminDB = Nothing Debug.Print "" Exit Sub ErrHandler: Debug.Print " [FAIL] 创建数据库时发生错误: " & ERR.Description Debug.Print "" End Sub '辅助函数：检查数据库是否存在 Private Function DatabaseExists(ByVal Db As cDataBase, ByVal DBName As String) As Boolean On Error GoTo ErrHandler Dim sqlCheck As String sqlCheck = "SELECT COUNT(*) AS cnt FROM INFORMATION_SCHEMA.SCHEMATA WHERE SCHEMA_NAME = '" & DBName & "'" Call Db.Sql(sqlCheck).Query If Db.Rs.RecordCount > 0 Then DatabaseExists = (Db.Rs("cnt") > 0) Else DatabaseExists = False End If Exit Function ErrHandler: DatabaseExists = False End Function '=============================================================== ' 测试1: 连接和断开数据库 '=============================================================== Private Sub Test_ConnectDisconnect() Debug.Print ">>> 测试1: 连接和断开数据库" On Error GoTo ErrHandler '测试连接 Dim bConnect As Boolean bConnect = TestDB.Connect(TEST_DB_TYPE, TEST_DB_ADDRESS, TEST_DB_USERNAME, TEST_DB_PASSWORD, TEST_DB_DATABASE) If bConnect Then Debug.Print " [OK] 数据库连接成功" Debug.Print " 连接状态: " & IIf(TestDB.IsConnect, "已连接", "未连接") Debug.Print " 连接版本: " & TestDB.GetVersion() Else Debug.Print " [FAIL] 数据库连接失败" Debug.Print " 错误信息: " & TestDB.LastErr End If '测试连接状态检查 Dim bCheck As Boolean bCheck = TestDB.CheckConnection() Debug.Print " 连接状态检查: " & IIf(bCheck, "正常", "异常") Debug.Print "" Exit Sub ErrHandler: Debug.Print " [FAIL] 测试连接时发生错误: " & ERR.Description Debug.Print "" End Sub '=============================================================== ' 测试2: 创建测试表 '=============================================================== Private Sub Test_CreateTestTable() Debug.Print ">>> 测试2: 创建测试表" On Error GoTo ErrHandler '先删除表（如果存在） Dim sqlDrop As String sqlDrop = "DROP TABLE IF EXISTS test_users" Call TestDB.Sql(sqlDrop).Exec '创建测试表 Dim sqlCreate As String sqlCreate = "CREATE TABLE test_users (" & _ "id INT PRIMARY KEY AUTO_INCREMENT," & _ "username VARCHAR(50) NOT NULL," & _ "email VARCHAR(100)," & _ "age INT," & _ "score DECIMAL(10,2)," & _ "is_active BOOLEAN DEFAULT TRUE," & _ "create_time DATETIME DEFAULT CURRENT_TIMESTAMP" & _ ")" Dim bCreate As Boolean bCreate = TestDB.Sql(sqlCreate).Exec() If bCreate Then Debug.Print " [OK] 测试表创建成功" Else Debug.Print " [FAIL] 测试表创建失败" Debug.Print " 错误信息: " & TestDB.LastErr End If '验证表是否存在 Dim bExists As Boolean bExists = TestDB.TableExists("test_users") Debug.Print " 表存在检查: " & IIf(bExists, "存在", "不存在") Debug.Print "" Exit Sub ErrHandler: Debug.Print " [FAIL] 创建测试表时发生错误: " & ERR.Description Debug.Print "" End Sub '=============================================================== ' 测试3: 插入数据 '=============================================================== Private Sub Test_InsertData() Debug.Print ">>> 测试3: 插入数据" On Error GoTo ErrHandler Dim i As Long Dim sqlInsert As String Dim bInsert As Boolean Dim lAffected As Long '插入单条记录 sqlInsert = "INSERT INTO test_users (username, email, age, score) VALUES ('张三', 'zhangsan@test.com', 25, 95.5)" bInsert = TestDB.Sql(sqlInsert).Exec(lAffected) If bInsert Then Debug.Print " [OK] 插入单条记录成功" Debug.Print " 影响行数: " & lAffected Debug.Print " 插入ID: " & TestDB.LastInsertId() Else Debug.Print " [FAIL] 插入单条记录失败" Debug.Print " 错误信息: " & TestDB.LastErr End If '批量插入记录 Debug.Print "" Debug.Print " 开始批量插入记录..." For i = 1 To 10 sqlInsert = "INSERT INTO test_users (username, email, age, score) VALUES " & _ "('用户" & i & "', 'user" & i & "@test.com', " & (20 + i) & ", " & (80 + i) & ".5)" bInsert = TestDB.Sql(sqlInsert).Exec(lAffected) If Not bInsert Then Debug.Print " [FAIL] 批量插入第 " & i & " 条记录失败: " & TestDB.LastErr Exit For End If Next i Debug.Print " [OK] 批量插入完成" Debug.Print "" Exit Sub ErrHandler: Debug.Print " [FAIL] 插入数据时发生错误: " & ERR.Description Debug.Print "" End Sub '=============================================================== ' 测试4: 查询数据 '=============================================================== Private Sub Test_QueryData() Debug.Print ">>> 测试4: 查询数据" On Error GoTo ErrHandler '查询所有记录 Dim sqlSelect As String sqlSelect = "SELECT * FROM test_users" Dim bQuery As Boolean bQuery = TestDB.Sql(sqlSelect).Query() If bQuery Then Debug.Print " [OK] 查询成功" Debug.Print " 记录总数: " & TestDB.Rs.RecordCount '遍历记录 Dim i As Long If TestDB.Rs.RecordCount > 0 Then TestDB.Rs.MoveFirst Debug.Print "" Debug.Print " 前3条记录:" For i = 1 To 3 If TestDB.Rs.EOF Then Exit For Debug.Print " ID: " & TestDB.Rs("id") & ", 用户名: " & TestDB.Rs("username") & ", 年龄: " & TestDB.Rs("age") TestDB.Rs.MoveNext Next i End If '关闭记录集 If TestDB.Rs.State <> adStateClosed Then TestDB.Rs.Close End If Else Debug.Print " [FAIL] 查询失败" Debug.Print " 错误信息: " & TestDB.LastErr End If '使用 Fetch 方法查询 Debug.Print "" bQuery = TestDB.Sql(sqlSelect).Fetch() If bQuery Then Debug.Print " [OK] Fetch 查询成功" Debug.Print " Rows集合数量: " & TestDB.Rows.count If TestDB.Rows.count > 0 Then Debug.Print " 第一行数据:" Dim key As Variant Dim Row As Dictionary Set Row = TestDB.Rows(1) For Each key In Row.Keys Debug.Print " " & key & ": " & Row(key) Next End If Else Debug.Print " [FAIL] Fetch 查询失败" End If Debug.Print "" Exit Sub ErrHandler: Debug.Print " [FAIL] 查询数据时发生错误: " & ERR.Description Debug.Print "" End Sub '=============================================================== ' 测试5: 更新数据 '=============================================================== Private Sub Test_UpdateData() Debug.Print ">>> 测试5: 更新数据" On Error GoTo ErrHandler '更新单条记录 Dim sqlUpdate As String sqlUpdate = "UPDATE test_users SET score = 99.9 WHERE username = '张三'" Dim bUpdate As Boolean Dim lAffected As Long bUpdate = TestDB.Sql(sqlUpdate).Exec(lAffected) If bUpdate Then Debug.Print " [OK] 更新成功" Debug.Print " 影响行数: " & lAffected '验证更新 Dim sqlCheck As String sqlCheck = "SELECT score FROM test_users WHERE username = '张三'" Call TestDB.Sql(sqlCheck).Fetch If TestDB.Rows.count > 0 Then Debug.Print " 更新后的分数: " & TestDB.Rows(1)("score") End If Else Debug.Print " [FAIL] 更新失败" Debug.Print " 错误信息: " & TestDB.LastErr End If Debug.Print "" Exit Sub ErrHandler: Debug.Print " [FAIL] 更新数据时发生错误: " & ERR.Description Debug.Print "" End Sub '=============================================================== ' 测试6: 删除数据 '=============================================================== Private Sub Test_DeleteData() Debug.Print ">>> 测试6: 删除数据" On Error GoTo ErrHandler '先查询总记录数 Dim lCountBefore As Long lCountBefore = TestDB.count("test_users") Debug.Print " 删除前记录数: " & lCountBefore '删除指定记录 Dim sqlDelete As String sqlDelete = "DELETE FROM test_users WHERE username = '张三'" Dim bDelete As Boolean Dim lAffected As Long bDelete = TestDB.Sql(sqlDelete).Exec(lAffected) If bDelete Then Debug.Print " [OK] 删除成功" Debug.Print " 影响行数: " & lAffected '验证删除 Dim lCountAfter As Long lCountAfter = TestDB.count("test_users") Debug.Print " 删除后记录数: " & lCountAfter Else Debug.Print " [FAIL] 删除失败" Debug.Print " 错误信息: " & TestDB.LastErr End If Debug.Print "" Exit Sub ErrHandler: Debug.Print " [FAIL] 删除数据时发生错误: " & ERR.Description Debug.Print "" End Sub '=============================================================== ' 测试7: 事务处理 '=============================================================== Private Sub Test_Transaction() Debug.Print ">>> 测试7: 事务处理" On Error GoTo ErrHandler '测试事务提交 Debug.Print " 测试事务提交:" Dim bBegin As Boolean bBegin = TestDB.TransBegin() Debug.Print " 开始事务: " & IIf(bBegin, "成功", "失败") If bBegin Then Dim sqlInsert As String sqlInsert = "INSERT INTO test_users (username, email, age, score) VALUES ('事务用户1', 'trans1@test.com', 30, 88)" Call TestDB.Sql(sqlInsert).Exec sqlInsert = "INSERT INTO test_users (username, email, age, score) VALUES ('事务用户2', 'trans2@test.com', 31, 89)" Call TestDB.Sql(sqlInsert).Exec Dim bCommit As Boolean bCommit = TestDB.TransCommit() Debug.Print " 提交事务: " & IIf(bCommit, "成功", "失败") If bCommit Then Dim lCount As Long lCount = TestDB.count("test_users") Debug.Print " 当前记录数: " & lCount End If End If '测试事务回滚 Debug.Print "" Debug.Print " 测试事务回滚:" bBegin = TestDB.TransBegin() Debug.Print " 开始事务: " & IIf(bBegin, "成功", "失败") If bBegin Then lCount = TestDB.count("test_users") sqlInsert = "INSERT INTO test_users (username, email, age, score) VALUES ('回滚用户', 'rollback@test.com', 32, 90)" Call TestDB.Sql(sqlInsert).Exec Dim bRollback As Boolean bRollback = TestDB.TransRollback() Debug.Print " 回滚事务: " & IIf(bRollback, "成功", "失败") Dim lCount2 As Long lCount2 = TestDB.count("test_users") Debug.Print " 记录数变化: " & lCount & " -> " & lCount2 & " (应保持不变)" End If Debug.Print "" Exit Sub ErrHandler: Debug.Print " [FAIL] 事务处理时发生错误: " & ERR.Description Debug.Print "" End Sub '=============================================================== ' 测试8: 参数化查询 '=============================================================== Private Sub Test_ParameterizedQuery() Debug.Print ">>> 测试8: 参数化查询" On Error GoTo ErrHandler '测试参数化插入 Dim sqlInsert As String sqlInsert = "INSERT INTO test_users (username, email, age, score) VALUES (?, ?, ?, ?)" Dim bExec As Boolean bExec = TestDB.Sql(sqlInsert) _ .Param("username", "参数用户1", adVarChar) _ .Param("email", "param1@test.com", adVarChar) _ .Param("age", 35, adInteger) _ .Param("score", 92.5, adDouble) _ .ExecParam() If bExec Then Debug.Print " [OK] 参数化插入成功" Debug.Print " 插入ID: " & TestDB.LastInsertId() Else Debug.Print " [FAIL] 参数化插入失败" Debug.Print " 错误信息: " & TestDB.LastErr End If '测试参数化查询 Dim sqlSelect As String sqlSelect = "SELECT * FROM test_users WHERE username = ? AND age > ?" Dim bQuery As Boolean bQuery = TestDB.Sql(sqlSelect) _ .Param("username", "参数用户1", adVarChar) _ .Param("age", 30, adInteger) _ .QueryParam() If bQuery Then Debug.Print " [OK] 参数化查询成功" Debug.Print " 查询结果数量: " & TestDB.Rs.RecordCount Else Debug.Print " [FAIL] 参数化查询失败" Debug.Print " 错误信息: " & TestDB.LastErr End If Debug.Print "" Exit Sub ErrHandler: Debug.Print " [FAIL] 参数化查询时发生错误: " & ERR.Description Debug.Print "" End Sub '=============================================================== ' 测试9: 分页查询 '=============================================================== Private Sub Test_Pagination() Debug.Print ">>> 测试9: 分页查询" '获取总记录数 Dim lTotalCount As Long lTotalCount = TestDB.count("test_users") Debug.Print " 总记录数: " & lTotalCount '查询第1页，每页3条 Dim lPageSize As Long lPageSize = 3 Dim sqlSelect As String sqlSelect = "SELECT * FROM test_users ORDER BY id" Dim bQuery As Boolean bQuery = TestDB.Sql(sqlSelect).Page(1, lPageSize).Query() If bQuery Then Debug.Print " [OK] 第1页查询成功" Debug.Print " 记录数: " & TestDB.Rs.RecordCount '显示第1页数据 If TestDB.Rs.RecordCount > 0 Then TestDB.Rs.MoveFirst Debug.Print " 第1页数据:" Do While Not TestDB.Rs.EOF Debug.Print " ID: " & TestDB.Rs("id") & ", 用户名: " & TestDB.Rs("username") TestDB.Rs.MoveNext Loop End If '关闭记录集以释放资源 If TestDB.Rs.State <> adStateClosed Then TestDB.Rs.Close End If Else Debug.Print " [FAIL] 第1页查询失败" Debug.Print " 错误信息: " & TestDB.LastErr End If '查询第2页 bQuery = TestDB.Sql(sqlSelect).Page(2, lPageSize).Fetch() If bQuery Then Debug.Print "" Debug.Print " [OK] 第2页查询成功" Debug.Print " 记录数: " & TestDB.Rows.count '显示第2页数据 If TestDB.Rows.count > 0 Then Debug.Print " 第2页数据:" Dim i As Long For i = 1 To TestDB.Rows.count Dim Row As Dictionary Set Row = TestDB.Rows(i) Debug.Print " ID: " & Row("id") & ", 用户名: " & Row("username") Next End If Else Debug.Print "" Debug.Print " [FAIL] 第2页查询失败" End If Debug.Print "" Exit Sub ErrHandler: Debug.Print " [FAIL] 分页查询时发生错误: " & ERR.Description Debug.Print "" End Sub '=============================================================== ' 单独测试函数 '=============================================================== Public Sub TestSpecificCase(ByVal TestCase As String) Select Case LCase(TestCase) Case "database" Set TestDB = New cDataBase Call Test_CreateDatabase Call Test_ConnectDisconnect Call Test_Disconnect Case "connect" Set TestDB = New cDataBase Call Test_CreateDatabase Call Test_ConnectDisconnect Call Test_Disconnect Case "insert" Set TestDB = New cDataBase Call Test_CreateDatabase Call Test_ConnectDisconnect Call Test_CreateTestTable Call Test_InsertData Call Test_Cleanup Call Test_Disconnect Case "query" Set TestDB = New cDataBase Call Test_CreateDatabase Call Test_ConnectDisconnect Call Test_CreateTestTable Call Test_InsertData Call Test_QueryData Call Test_Cleanup Call Test_Disconnect Case "transaction" Set TestDB = New cDataBase Call Test_CreateDatabase Call Test_ConnectDisconnect Call Test_CreateTestTable Call Test_Transaction Call Test_Cleanup Call Test_Disconnect Case "pagination" Set TestDB = New cDataBase Call Test_CreateDatabase Call Test_ConnectDisconnect Call Test_CreateTestTable Call Test_InsertData Call Test_Pagination Call Test_Cleanup Call Test_Disconnect Case Else Debug.Print "未知测试用例: " & TestCase Debug.Print "可用测试用例: database, connect, insert, query, transaction, pagination" End Select End Sub '=============================================================== ' 测试说明文档 '=============================================================== Public Sub ShowTestHelp() Debug.Print "======================================================" Debug.Print "cDatabase 类测试用例说明" Debug.Print "======================================================" Debug.Print "" Debug.Print "使用方法:" Debug.Print "1. 运行所有测试: RunAllTests" Debug.Print "2. 运行单个测试: TestSpecificCase ""测试名称""" Debug.Print "" Debug.Print "可用测试名称:" Debug.Print " - database : 测试创建数据库" Debug.Print " - connect : 测试连接" Debug.Print " - insert : 测试插入" Debug.Print " - query : 测试查询" Debug.Print " - transaction: 测试事务" Debug.Print " - pagination : 测试分页" Debug.Print "" Debug.Print "注意: 详细测试代码请参考 src/Demos/database/Demo_Database.bas 源文件" Debug.Print "======================================================" End Sub ``` **注意**: 以上为简化版核心代码展示，完整代码请参考源码文件 `src/Demos/database/Demo_Database.bas` *** **最后更新**: 2026-05-17 --- --- url: /en/vbman/database.md --- # cDataBase Class Library Development Documentation > **cDataBase Class Library** - VB6 database operation wrapper based on ADO, developed by 215879458@qq.com ## Table of Contents * [Overview](#overview) * [Key Features](#key-features) * [Architecture Design](#architecture-design) * [Documentation Index](#documentation-index) *** ## Overview cDataBase is a lightweight database operation wrapper designed for VB6, fully based on ADO (ActiveX Data Objects), providing a simple and easy-to-use API with complete feature support. ### Key Features * **Multi-database Support** - Supports Access, MySQL, SQL Server, CSV, Custom (custom DSN) and other databases * **Connection Pool Management** - Supports multi-database connection instance pool, dynamic database object management * **Chained Query Builder** - ORM-like chained API, supports Where/OrderBy/GroupBy/Join/Limit/Page, zero handwritten SQL * **Pagination Support** - Built-in pagination based on ADO native pagination properties, supports all database types * **Parameterized Queries** - Supports parameterized queries, effectively preventing SQL injection attacks * **Transaction Processing** - Complete transaction support with automatic rollback mechanism * **Asynchronous Execution** - Supports asynchronous SQL execution for improved performance * **Result Set Conversion** - Automatically converts Recordset to cCollection (Dictionary nested) * **Utility Methods** - Rich utility methods to simplify common operations *** ## Key Features ### 1. Simple API Design The library uses chained call design with clean, readable code: ```vb ' Use after referencing VBMAN.dll in VB6 project Dim db As New VBMAN.cDataBase ' Connect to database db.Connect VBMAN.enumDbType_MsSql, "127.0.0.1,1433", "sa", "password", "mydb" ' Query data (chained call) db.Sql("SELECT * FROM users WHERE id > ?").Param("id", 100).QueryParam ' Get results Dim i As Long For i = 1 To db.Rows.Count Debug.Print db.Rows(i)("name") Next ``` *** ### 2. Multi-database Type Support ```vb ' SQL Server db.Connect VBMAN.enumDbType_MsSql, "127.0.0.1,1433", "sa", "pwd", "master" ' MySQL db.Connect VBMAN.enumDbType_Mysql, "localhost:3306", "root", "pwd", "testdb" ' Access db.Connect VBMAN.enumDbType_Access, "C:\data\mydb.mdb" ' CSV db.Connect VBMAN.enumDbType_Csv, "C:\data\csvfiles" ``` *** ### 3. Pagination Support ```vb ' Page 2, 10 items per page db.Sql("SELECT * FROM users").Page(2, 10).Query ' Automatically converts to pagination SQL for corresponding database ' SQL Server: OFFSET 10 ROWS FETCH NEXT 10 ROWS ONLY ' MySQL: LIMIT 10 OFFSET 10 ``` *** ### 4. Parameterized Queries (SQL Injection Prevention) ```vb ' Use parameterized queries, safe and reliable db.Sql("SELECT * FROM users WHERE name = ? AND age > ?") _ .Param("name", "Zhang San", adVarChar) _ .Param("age", 18, adInteger) _ .QueryParam ``` *** ### 5. Transaction Processing ```vb ' Start transaction db.TransBegin ' Execute multiple operations db.Sql("INSERT INTO users (name) VALUES ('user1')").Exec db.Sql("INSERT INTO users (name) VALUES ('user2')").Exec ' Commit transaction (auto rollback on failure) If db.TransCommit Then Debug.Print "Transaction committed successfully" End If ``` *** ### 6. Automatic Result Set Conversion ```vb ' Automatically converted to Dictionary collection after query db.Sql("SELECT * FROM users").Fetch ' Access first row data Debug.Print db.Row("name") Debug.Print db.Row("age") ' Iterate all rows Dim i As Long For i = 1 To db.Rows.Count Debug.Print db.Rows(i)("name") Next ``` *** ### 7. Connection Pool Management ```vb ' Create connection instance Dim db1 As VBMAN.cDataBase Set db1 = db.ConnInst("db1") ' Use independent connection instance db1.Sql("SELECT * FROM table1").Query ' Remove connection instance db.ConnInstRemove "db1" ``` *** ## Architecture Design ### Class Hierarchy ``` cDataBase (Database Operation Class) ├── Connection (ADODB.Connection) - Database connection ├── Recordset (ADODB.Recordset) - Recordset ├── Command (ADODB.Command) - Parameterized query command ├── Rows (cCollection) - Query result set (Dictionary nested) ├── Row (Dictionary) - Current row data ├── DatabaseType (enumDbType) - Current database type ├── IsCloneInstance (Boolean) - Whether it's a connection pool clone instance └── Connections (Dictionary) - Connection pool ``` ### Object Relationship Diagram ``` Database Object (cDataBase) ├── Main Connection (Conn) │ ├── Recordset (Rs) │ └── Command (Cmd) - Parameterized query └── Connection Pool (Connections) ├── Connection Instance 1 (cDataBase) │ └── Independent connection ├── Connection Instance 2 (cDataBase) │ └── Independent connection └── ... ``` ### Data Flow #### Query Flow ``` 1. Sql("SELECT ...") - Set SQL statement 2. Page(1, 10) - Optional: Set pagination 3. Query() - Execute query 4. Rs - Get Recordset 5. Rows - Auto-convert to Dictionary collection ``` #### Chained Builder Flow ``` 1. Table("table_name") - Set operation table (starting method) 2. Where/WhereIn/OrderBy/GroupBy/Join/Limit/Page - Stack chained conditions 3. RowRead/RowCreate/RowUpdate/RowDelete/RowCount/RowExists - Terminal methods 4. Rs - Get Recordset (after RowRead) 5. Rows - Auto-convert to Dictionary collection (with RowRead + Fetch) ``` #### Execution Flow ``` 1. Sql("INSERT/UPDATE/DELETE ...") - Set SQL statement 2. Param("name", value) - Optional: Add parameters 3. Exec() / ExecParam() - Execute operation 4. LastInsertId() - Optional: Get last inserted ID ``` #### Parameterized Query + Fetch Flow ``` 1. Sql("SELECT ... WHERE id = ?") - Set SQL statement 2. Param("id", value, type) - Add parameters 3. FetchParam() - Execute parameterized query + auto-convert to Rows/Row ``` *** ## Documentation Index | Document | Description | | --------------------------------------------------------------------- | -------------------------------------------------- | | [Quick Start](./quickstart.md) | Quick start guide | | [Connection Management](./connection.md) | Database connection and connection pool management | | [Chained CRUD - Overview](./chain-curd.md) | Overview & quick reference | | [Chained CRUD - Condition Methods](./chain-curd-where.md) | Where/OrWhere/WhereIn/WhereLike etc. | | [Chained CRUD - Sort/Group/Join/Selection](./chain-curd-modifiers.md) | OrderBy/GroupBy/Having/Join/Columns/Distinct | | [Chained CRUD - Limit & Pagination](./chain-curd-limit-page.md) | Limit/Offset/Page | | [Chained CRUD - Terminal Methods](./chain-curd-terminal.md) | RowCreate/RowRead/RowUpdate/RowDelete/Field | | [Chained CRUD - Aggregate Methods](./chain-curd-aggregate.md) | RowCount/RowExists/RowPluck/RowMax/Min/Sum/Avg | | [Chained CRUD - Examples & Best Practices](./chain-curd-examples.md) | SQL comparison, FAQ, best practices | | [Query Operations](./query.md) | Detailed SELECT query explanation | | [Execute Operations](./execute.md) | INSERT, UPDATE, DELETE operations | | [Transaction Processing](./transaction.md) | Complete transaction usage guide | | [Pagination](./pagination.md) | Detailed pagination explanation | | [Parameterized Queries](./parameterized.md) | Parameterized queries and SQL injection prevention | | [Utility Methods](./utilities.md) | Common utility methods explanation | | [Advanced Features](./advanced.md) | Advanced features and best practices | *** ## Dependencies | Component | Description | | ---------------------------------------------- | ------------------------------------------- | | **Microsoft ActiveX Data Objects 2.8 Library** | ADO core library, must be referenced | | **Microsoft Scripting Runtime** | Dictionary object support | | **cCollection** | Rows result set type (VBMAN internal) | | **ToolsList.bas** | Recordset to cCollection conversion utility | | **ToolsFso.bas** | File path handling utility | *** ## Compatibility * **VB6/VBA** - Fully compatible * **Windows** - Windows XP and above * **Database** - Access, MySQL, SQL Server, CSV, Custom (custom DSN) * **ADO Version** - ADO 2.8 and above *** ## License Developed based on VBMAN project *** ## Author **Database Library**: 215879458@qq.com *** **Last Updated**: 2026-01-21 --- --- url: /en/vbman/database/testing.md --- # cDatabase Testing Guide ## 📖 Introduction `Demo_Database.bas` is a complete test case module for the cDatabase class, providing comprehensive testing from basic connection to advanced features. ## 📁 File Location ``` src/Demos/database/Demo_Database.bas ``` ## ⚙️ Configuration Before running tests, modify the database configuration parameters at the top of the module: ```vb 'Database Configuration - Modify according to your environment Private Const TEST_DB_TYPE As Long = enumDbType.Mysql '1:Access, 2:Mysql, 3:MsSql, 4:Csv Private Const TEST_DB_ADDRESS As String = "172.18.131.71,3306" Private Const TEST_DB_USERNAME As String = "root" Private Const TEST_DB_PASSWORD As String = "root" Private Const TEST_DB_DATABASE As String = "testdb" ``` ### Supported Database Types | Value | Constant | Description | | ----- | ------------------ | -------------------- | | 1 | `enumDbType.Mysql` | MySQL database | | 2 | `enumDbType.Mysql` | MySQL database | | 3 | `enumDbType.MsSql` | SQL Server database | | 4 | `enumDbType.Csv` | CSV file data source | ### Connection String Examples **MySQL Standard Connection:** ```vb TEST_DB_ADDRESS = "172.18.131.71,3306" ``` **MySQL ODBC Custom DSN:** ```vb TEST_DB_ADDRESS = "DRIVER=VBMAN Mysql ODBC Driver;MULTI_HOST=1;SERVER=10.0.0.252,3306;DATABASE=mysql;UID=root;PWD=root" ``` ## 🚀 Running Tests ### Run All Tests ```vb 'Execute in Immediate window Demo_Database.RunAllTests ``` The following tests will be executed in order: | # | Test Name | Description | | --- | ------------------ | ------------------------------- | | 0 | CreateDatabase | Create test database | | 1 | ConnectDisconnect | Connect and disconnect database | | 2 | CreateTestTable | Create test table | | 3 | InsertData | Insert data test | | 4 | QueryData | Query data test | | 5 | UpdateData | Update data test | | 6 | DeleteData | Delete data test | | 7 | Transaction | Transaction processing test | | 8 | ParameterizedQuery | Parameterized query test | | 9 | Pagination | Pagination query test | | 10 | LastInsertId | Get last insert ID test | | 11 | Count | Record count test | | 12 | TableExists | Check table exists test | | 13 | GetTableFields | Get table field list test | | 14 | BatchInsert | Batch insert data test | | 15 | GetDatabases | Get database list test | | 16 | GetTables | Get table list test | | 17 | Escape | SQL escape test | | 18 | CheckConnection | Check connection status test | | 19 | GetVersion | Get version info test | | 20 | ConnectionPool | Connection pool feature test | | 21 | AsyncExecute | Async execution test | ### Run Single Test ```vb 'Run specific test case Demo_Database.TestSpecificCase "connect" Demo_Database.TestSpecificCase "query" Demo_Database.TestSpecificCase "transaction" ``` **Supported Test Case Names:** | Name | Test Content | | ------------- | ---------------- | | `database` | Create database | | `connect` | Connection test | | `insert` | Insert test | | `query` | Query test | | `transaction` | Transaction test | | `pagination` | Pagination test | ### Show Help Info ```vb Demo_Database.ShowTestHelp ``` ## 📋 Test Content Details ### Basic Connection Test ```vb 'Test connection and disconnect Private Sub Test_ConnectDisconnect() Dim bConnect As Boolean bConnect = TestDB.Connect(TEST_DB_TYPE, TEST_DB_ADDRESS, _ TEST_DB_USERNAME, TEST_DB_PASSWORD, TEST_DB_DATABASE) If bConnect Then Debug.Print "Database connection successful" Debug.Print "Connection status: " & TestDB.IsConnect Debug.Print "Connection version: " & TestDB.GetVersion() End If End Sub ``` ### CRUD Operations Test **Insert Data:** ```vb 'Single insert sqlInsert = "INSERT INTO test_users (username, email, age, score) " & _ "VALUES ('John', 'john@test.com', 25, 95.5)" bInsert = TestDB.Sql(sqlInsert).Exec(lAffected) 'Batch insert For i = 1 To 10 sqlInsert = "INSERT INTO test_users (...) VALUES (...)" bInsert = TestDB.Sql(sqlInsert).Exec(lAffected) Next i ``` **Query Data:** ```vb 'Query using Recordset sqlSelect = "SELECT * FROM test_users" bQuery = TestDB.Sql(sqlSelect).Query() If bQuery Then Debug.Print "Total records: " & TestDB.Rs.RecordCount End If 'Query using Rows collection bQuery = TestDB.Sql(sqlSelect).Fetch() If bQuery Then Debug.Print "Rows collection count: " & TestDB.Rows.Count End If ``` ### Transaction Test ```vb 'Test transaction commit TestDB.TransBegin() TestDB.Sql("INSERT INTO ...").Exec TestDB.Sql("INSERT INTO ...").Exec TestDB.TransCommit() 'Test transaction rollback TestDB.TransBegin() TestDB.Sql("INSERT INTO ...").Exec TestDB.TransRollback() ``` ### Parameterized Query Test ```vb 'Parameterized insert sqlInsert = "INSERT INTO test_users (username, email, age, score) VALUES (?, ?, ?, ?)" bExec = TestDB.Sql(sqlInsert) _ .Param("username", "Param User1", adVarChar) _ .Param("email", "param1@test.com", adVarChar) _ .Param("age", 35, adInteger) _ .Param("score", 92.5, adDouble) _ .ExecParam() 'Parameterized query sqlSelect = "SELECT * FROM test_users WHERE username = ? AND age > ?" bQuery = TestDB.Sql(sqlSelect) _ .Param("username", "Param User1", adVarChar) _ .Param("age", 30, adInteger) _ .QueryParam() ``` ### Pagination Test ```vb 'Query page 1, 3 items per page sqlSelect = "SELECT * FROM test_users ORDER BY id" bQuery = TestDB.Sql(sqlSelect).Page(1, 3).Query() 'Query page 2 using Fetch bQuery = TestDB.Sql(sqlSelect).Page(2, 3).Fetch() Debug.Print "Rows collection count: " & TestDB.Rows.Count ``` ### Batch Insert Test ```vb 'Prepare batch data Dim Data As New Collection Dim Row As Dictionary For i = 1 To 5 Set Row = New Dictionary Row.Add "username", "Batch User" & i Row.Add "email", "batch" & i & "@test.com" Row.Add "age", 50 + i Row.Add "score", 90 + i Data.Add Row Next 'Execute batch insert bBatch = TestDB.BatchInsert("test_users", Data) ``` ### Connection Pool Test ```vb 'Create connection pool instances Set dbPool1 = TestDB.ConnInst("Pool1") Set dbPool2 = TestDB.ConnInst("Pool2") 'Query using connection pool instance bQuery = dbPool1.Sql("SELECT COUNT(*) AS cnt FROM test_users").Query() 'Remove connection pool instances TestDB.ConnInstRemove "Pool1" TestDB.ConnInstRemove "Pool2" ``` ### Async Execute Test ```vb 'Async execute SQL sqlInsert = "INSERT INTO test_users (...) VALUES (...)" bExec = TestDB.Sql(sqlInsert).Async().Exec() ``` ## 📊 Test Output Example ``` ====================================================== Starting cDatabase Class Full Test ====================================================== >>> Test 0: Create Test Database [OK] Connected to database server Database 'testdb' exists, skipping creation >>> Test 1: Connect and Disconnect Database [OK] Database connection successful Connection status: True Connection version: ADO 6.1 Connection status check: Normal >>> Test 2: Create Test Table [OK] Test table created successfully Table exists check: Exists >>> Test 3: Insert Data [OK] Single record insert successful Affected rows: 1 Insert ID: 1 Starting batch insert... [OK] Batch insert completed >>> Test 4: Query Data [OK] Query successful Total records: 11 First 3 records: ID: 1, Username: John, Age: 25 ID: 2, Username: User1, Age: 21 ID: 3, Username: User2, Age: 22 [OK] Fetch query successful Rows collection count: 11 First row data: id: 1 username: John email: john@test.com ... ====================================================== All tests completed! Time: 2.35 seconds ====================================================== ``` ## ⚠️ Notes 1. **Auto create database**: Test will automatically create database specified by `TEST_DB_DATABASE` (if doesn't exist) 2. **Test table management**: Test will create `test_users` table, automatically deleted after test 3. **Connection config**: Ensure database server is accessible, username and password are correct 4. **Permission requirements**: Need permissions to create database, create table, insert, update, delete 5. **ODBC driver**: MySQL ODBC driver needs to be installed when using MySQL ## 🔧 Troubleshooting ### Connection Failed ``` [FAIL] Database connection failed Error: [08001] [Microsoft][ODBC Driver Manager] Data source name not found... ``` **Solutions:** * Check if `TEST_DB_ADDRESS` is correct * Confirm MySQL ODBC driver is installed * Try custom DSN connection string ### Create Database Failed ``` [FAIL] Create database failed Error: Access denied for user... ``` **Solutions:** * Confirm user has create database permission * Check if username and password are correct *** **Last Updated**: 2026-05-17 --- --- url: /zh/vbman/delay/TODO.md --- # cDelay 延时对象 - TODO 与路线图 ```vb '=========================================================================== ' 名称: cDelay ' 描述: 延时对象类 - 支持事件触发、回调函数和同步等待三种模式 ' 作者: 邓伟，QQ: 215879458 ' 网站: https://vb6.pro ' 日期: 2026-03-31 ' 参考: cTimer.cls 架构 '=========================================================================== ``` ## 当前版本: v1.0 ### 已实现功能 * \[x] 三种工作模式：事件、回调、同步 * \[x] ParamArray 变长参数支持（最多9个） * \[x] 同步模式消息泵实现（无 DoEvents） * \[x] 同步模式取消功能 * \[x] 自动生命周期管理（引用计数） * \[x] 链式调用 API 设计 *** ## 路线图 ### v1.1 增强版多实例管理 参考 Toast 实现，实现更强大的多实例管理： #### 1.1.1 实例命名与追踪 ```vb ' 为延迟实例设置名称，便于后续管理 Dim delay As New cDelay delay.Tag("AutoSaveTimer").Callback(Me, "AutoSave").CountDown(5000) ' 通过名称获取实例状态 If Delays.Exists("AutoSaveTimer") Then Debug.Print "剩余时间: " & Delays("AutoSaveTimer").RemainingTime End If ``` **实现要点：** * 添加 `Tag` 属性/方法，支持链式调用 * 全局集合使用 Key（如 "id:" & TimerID 或自定义 Tag） * 提供 `Delays.Exists(Tag)` 方法检查实例是否存在 * 提供 `Delays(Tag)` 索引器获取实例引用 #### 1.1.2 按类型分组管理 参考 Toast 的 9 个位置集合，按用途分组： ```vb ' 枚举定义 Public Enum DelayGroup dgSystem = 1 ' 系统级延时 dgUser = 2 ' 用户操作相关 dgBackground = 3 ' 后台任务 dgAnimation = 4 ' 动画相关 End Enum ' 使用 delay.Group(dgBackground).Callback(Me, "SyncData").CountDown(60000) ' 批量操作 delay.Group(dgBackground).CancelAll ' 取消所有后台任务 ``` **实现要点：** * 每个 Group 对应一个独立的 Collection * 支持分组级别的批量操作（CancelAll、PauseAll、ResumeAll） #### 1.1.3 实例状态查询 ```vb ' 获取当前活动的延迟数量 Dim count As Long count = Delays.Count ' 总数 count = Delays.CountByGroup(dgSystem) ' 按分组 ' 枚举所有活动实例 Dim d As cDelay For Each d In Delays Debug.Print d.Tag & " - 剩余: " & d.RemainingTime Next ``` **新增属性/方法：** * `RemainingTime` - 剩余毫秒数（计算属性） * `ElapsedTime` - 已过去毫秒数 * `Progress` - 完成百分比（0-100） *** ### v1.2 新增延迟方式（与 CountDown 同级） #### 1.2.1 ClockAt - 指定绝对时间 ```vb ' 今天14:30执行 delay.ClockAt "14:30:00".Callback(Me, "DoSomething") ' 指定日期时间 delay.ClockAtDate "2026-04-01 09:00:00".Callback(Me, "MeetingReminder") ' 明天早上8点 delay.ClockAtDate DateAdd("d", 1, Date) & " 08:00:00" ``` **实现要点：** * 计算目标时间与当前时间的差值 * 如果目标时间已过，可选择立即执行或次日执行 * 支持重复：每天/每周/每月的同时间执行 #### 1.2.2 Interval - 重复间隔 ```vb ' 每5秒执行一次 delay.Interval(5000).Callback(Me, "CheckStatus") ' 限制次数 delay.Interval(1000).RepeatCount(10).Callback(Me, "UpdateProgress") ' 停止 delay.StopInterval ``` **实现要点：** * 内部使用 Windows 定时器或循环 * 支持无限重复或指定次数 * 可以动态修改间隔时间 #### 1.2.3 Random - 随机延迟 ```vb ' 在1-5秒之间随机 delay.Random(1000, 5000).Callback(Me, "RandomTask") ' 用于防检测、模拟人工操作 ``` #### 1.2.4 WaitUntil - 条件等待 ```vb ' 等待某个条件为真（最多等10秒） delay.WaitUntil(AddressOf IsDataReady, 10000).Callback(Me, "ProcessData") ' 配合函数 Public Function IsDataReady() As Boolean IsDataReady = (FileLen("data.txt") > 0) End Function ``` **实现要点：** * 在消息循环中轮询检查条件 * 支持超时 * 可设置检查间隔（默认100ms） #### 1.2.5 Debounce - 防抖 ```vb ' 输入停止500ms后才执行搜索 delay.Debounce(500).Callback(Me, "DoSearch") ' 使用场景：搜索框、窗口调整大小 ' 频繁触发时，只有最后一次会真正执行 ``` #### 1.2.6 Throttle - 节流 ```vb ' 最多每2秒执行一次 delay.Throttle(2000).Callback(Me, "SaveLog") ' 使用场景：日志记录、滚动事件 ' 频繁触发时，按固定频率执行 ``` #### 1.2.7 AfterLast - 空闲后执行 ```vb ' 鼠标键盘无操作3秒后执行 delay.AfterLastInput(3000).Callback(Me, "AutoSave") ' 配合特定事件 delay.AfterLast("MouseMove", 1000).Callback(Me, "ShowTooltip") ``` **实现要点：** * 需要监听系统消息或轮询 GetLastInputInfo * 重置计时器当有新输入时 #### 1.2.8 Retry - 重试机制 ```vb ' 失败后自动重试，最多3次，间隔递增 delay.Retry(3, 1000, 2).Callback(Me, "ConnectServer") ' 第1次失败后等1秒，第2次等2秒，第3次等4秒 ' 配合回调返回值判断是否成功 Public Function ConnectServer() As Boolean ' 返回 False 会自动触发重试 ConnectServer = AttemptConnection() End Function ``` #### 1.2.9 Schedule - 多时间点调度 ```vb ' 一天内的多个时间点 delay.Schedule(Array("09:00", "12:00", "18:00")).Callback(Me, "CheckMail") ' 工作日调度 delay.ScheduleWeekday("09:00,12:00,18:00").Callback(Me, "CheckMail") ``` #### 1.2.10 DelayAfter - 事件后延迟 ```vb ' 文件修改后5秒自动备份 delay.AfterEvent("FileChanged", "C:\data.txt", 5000).Callback(Me, "BackupFile") ' 窗口失焦后自动保存 delay.AfterEvent("LostFocus", Me.hWnd, 1000).Callback(Me, "AutoSave") ``` *** ### v1.3 高级控制功能 #### 1.3.1 暂停与恢复 ```vb delay.CountDown(10000) ' 10秒延时 ' 暂停 delay.Pause ' 暂停计时 Debug.Print delay.RemainingTime ' 还剩多少 ' 恢复 delay.Resume ' 从暂停处继续 ``` **技术方案：** * 暂停时记录 `PausedTick` 和 `RemainingAtPause` * 恢复时重新计算 `EndTick = GetTickCount() + RemainingAtPause` * 仅适用于 Windows 定时器模式（事件/回调） #### 1.3.2 重置与修改 ```vb ' 重置当前延时（从头开始） delay.Reset ' 修改剩余时间 delay.ChangeDelay 5000 ' 修改为还剩5秒 ' 增加时间 delay.AddTime 2000 ' 增加2秒 ``` *** ### v1.4 性能与调试增强 #### 1.4.1 调试模式 ```vb ' 全局开启调试 Delays.DebugMode = True ' 输出日志 ' [cDelay] AutoSaveTimer: CountDown started, 5000ms ' [cDelay] AutoSaveTimer: Tick, remaining 3000ms ' [cDelay] AutoSaveTimer: OnTime fired ' [cDelay] AutoSaveTimer: Cancelled by user ``` #### 1.4.2 性能统计 ```vb ' 获取统计信息 Dim stats As DelayStats stats = Delays.GetStats Debug.Print "总创建数: " & stats.TotalCreated Debug.Print "总完成数: " & stats.TotalCompleted Debug.Print "总取消数: " & stats.TotalCancelled Debug.Print "平均执行时间: " & stats.AvgExecutionTime ``` #### 1.4.3 内存监控 ```vb ' 自动清理僵尸实例（可选） Delays.AutoCleanup = True Delays.AutoCleanupInterval = 60000 ' 每60秒检查一次 ``` *** ### v1.5 同步模式增强 #### 1.5.1 超时处理 ```vb ' 同步模式支持超时回调 delay.Sync().Timeout(5000).OnTimeout(Me, "OnSyncTimeout").CountDown(10000) ' 如果10秒内未完成，5秒后触发 OnSyncTimeout ``` #### 1.5.2 条件等待 ```vb ' 等待直到条件满足或超时 delay.Sync().WaitUntil(AddressOf CheckCondition, 5000) ' 每帧检查 CheckCondition 函数，返回 True 则提前结束 ``` #### 1.5.3 多任务等待 ```vb ' 等待多个延时全部完成 Dim tasks As New Collection tasks.Add delay1 tasks.Add delay2 tasks.Add delay3 Delay.WaitAll(tasks, 10000) ' 最多等10秒 ' 或等待任一完成 Delay.WaitAny(tasks, 10000) ``` *** ### v1.6 回调增强 #### 1.6.1 Lambda/匿名函数支持（VB6 模拟） ```vb ' 使用 AddressOf 传递函数指针 delay.Callback(AddressOf MyStaticFunc).CountDown(1000) ' 或使用类实例方法 delay.Callback2(Me, "MethodName", param1, param2) ``` #### 1.6.2 异步回调 ```vb ' 回调在独立线程执行（需谨慎） delay.AsyncCallback(Me, "HeavyTask").CountDown(100) ``` #### 1.6.3 回调链 ```vb ' 多个回调按顺序执行 delay.Callback(Me, "Step1") _ .Then(Me, "Step2") _ .Then(Me, "Step3") _ .CountDown(1000) ' 1000ms 后依次执行 Step1 -> Step2 -> Step3 ``` *** ### v1.7 集成与扩展 #### 1.7.1 与 UI 控件集成 ```vb ' 自动更新进度条 delay.BindProgressBar(ProgressBar1).CountDown(5000) ' 自动更新标签 delay.BindLabel(Label1, "剩余时间: {remaining}s").CountDown(5000) ``` #### 1.7.2 音效支持 ```vb delay.OnTimeSound("C:\Windows\Media\chimes.wav").CountDown(5000) delay.OnCancelSound("C:\Windows\Media\ding.wav") ``` #### 1.7.3 配置文件支持 ```vb ' 从配置加载 delay.LoadConfig("AutoSaveDelay") ' 读取注册表/INI：Delay.AutoSaveDelay = 5000 ``` *** ### v2.0 架构重构（远期） #### 2.0.1 COM 组件化 * 编译为 ActiveX DLL * 支持跨项目复用 * 提供强类型接口 #### 2.0.2 多线程支持 * 真正的后台线程定时器 * 不依赖 Windows 消息队列 * 适用于无窗口环境（如 Windows Service） #### 2.0.3 .NET 互操作 * 提供 .NET 封装类 * 支持从 VB.NET/C# 调用 *** ## 优先级建议 ### 高优先级（近期实现） 1. **实例命名与追踪** - 基础功能，很多高级特性依赖于此 2. **ClockAt** - 指定时间执行，非常实用的功能 3. **Interval** - 重复间隔执行，类似定时器 4. **Debounce/Throttle** - 防抖节流，UI开发必备 5. **调试模式** - 便于开发和排查问题 ### 中优先级（中期实现） 6. 按类型分组管理 7. 暂停/恢复功能 8. Random 随机延迟 9. WaitUntil 条件等待 10. 性能统计 ### 低优先级（远期考虑） 11. Retry 重试机制 12. Schedule 多时间点调度 13. 多任务等待 14. 回调链 15. COM 组件化 *** ## 设计原则 1. **向后兼容**：所有新增功能都是可选的，不影响现有 API 2. **链式调用**：保持 `object.Method().Another().Action()` 风格 3. **默认值合理**：不设置时提供智能默认行为 4. **错误处理**：所有操作都有明确的错误状态和返回值 5. **资源安全**：确保没有内存泄漏，清理彻底 *** ## 贡献建议 如果你想参与开发，以下是一些切入点： * **文档完善**：补充更多使用示例和最佳实践 * **测试用例**：编写边界情况测试（如极限时间值、并发场景） * **性能优化**：优化消息循环，减少 CPU 占用 * **代码审查**：检查线程安全和资源释放 *** ## 参考资源 * Toast 多实例管理：`D:\code\vi\vbmanlib\vbman\src\Toast\cToast.cls` * Windows Timer API：MSDN `SetTimer` / `KillTimer` * VB6 消息循环：`PeekMessage` / `DispatchMessage` * 设计模式：观察者模式、工厂模式、对象池 *** *最后更新: 2026-03-31* --- --- url: /zh/vbman/delay/readme.md --- # cDelay 延时对象开发文档 ```vb '=========================================================================== ' 名称: cDelay ' 描述: 延时对象类 - 支持事件触发、回调函数和同步等待三种模式 ' 作者: 邓伟，QQ: 215879458 ' 网站: https://vb6.pro ' 日期: 2026-03-31 ' 参考: cTimer.cls 架构 '=========================================================================== ``` ## 概述 `cDelay` 是一个 VB6 延时对象类，提供三种使用模式： * **事件模式**：通过 `OnTime` 事件触发 * **回调模式**：通过 `CallByName` 调用指定函数 * **同步模式**：阻塞等待，不卡 UI ## 文件结构 ``` Delay/ ├── cDelay.cls ' 延时对象类 ├── mDelay.bas ' 管理模块（全局集合、定时器回调） └── cDelayDemo.frm ' 演示窗体 ``` ## 特性 * ✅ 自动生命周期管理（引用计数） * ✅ 支持最多 9 个回调参数（使用 ParamArray） * ✅ 同步模式支持取消操作 * ✅ 消息泵实现，不依赖 DoEvents * ✅ 线程安全的消息循环 *** ## 快速开始 ### 1. 事件模式 ```vb Private WithEvents m_Delay As cDelay Private Sub Form_Load() Set m_Delay = New cDelay End Sub Private Sub btnStart_Click() m_Delay.CountDown 3000 ' 3秒后触发 OnTime End Sub Private Sub m_Delay_OnTime() MsgBox "时间到了！" End Sub ``` ### 2. 回调模式 ```vb Private m_Delay As cDelay Private Sub Form_Load() Set m_Delay = New cDelay End Sub Private Sub btnStart_Click() ' 链式调用，传递多个参数 m_Delay.Callback(Me, "MyFunc", "参数1", 123, Now).CountDown 3000 End Sub Public Sub MyFunc(ByVal s As String, ByVal n As Long, ByVal d As Date) MsgBox s & ", " & n End Sub ``` ### 3. 同步模式 ```vb Private m_DelaySync As cDelay ' 必须是模块级变量才能取消 Private Sub btnStart_Click() lblStatus.Caption = "等待中..." lblStatus.Refresh m_DelaySync.Sync().CountDown 3000 ' 等待3秒，UI保持响应 ' 检查是否被取消 If m_DelaySync.IsCancelled Then lblStatus.Caption = "已取消" Else lblStatus.Caption = "完成！" End If End Sub Private Sub btnCancel_Click() m_DelaySync.Cancel ' 取消同步等待 End Sub ``` *** ## API 参考 ### 属性 | 属性 | 类型 | 说明 | | ------------- | ----------- | ---------------------------- | | `Mode` | `DelayMode` | 当前模式（只读） | | `IsActive` | `Boolean` | 是否处于活动状态（只读） | | `IsCancelled` | `Boolean` | 同步模式下是否被取消（只读） | | `DelayMs` | `Long` | 延迟毫秒数（只读） | > 📊 **对比分析**：[cDelay vs 原生 DoEvents 对比](./whyDelay.md) ### 方法 #### `Callback(CallbackObject, ProcName, [ParamArray P()])` 设置回调模式。 **参数：** * `CallbackObject` - 回调方法所在的对象（通常是 `Me`） * `ProcName` - 回调方法名称（字符串） * `P()` - 可选参数，最多 9 个 **返回：** `cDelay` 对象自身（支持链式调用） **示例：** ```vb delay.Callback(Me, "ProcessData", userId, userName).CountDown(2000) ``` #### `Sync()` 设置同步模式。 **返回：** `cDelay` 对象自身（支持链式调用） **示例：** ```vb delay.Sync().CountDown(5000) ``` #### `CountDown(Milliseconds)` 开始倒计时。 **参数：** * `Milliseconds` - 延迟时间（毫秒） **注意：** * 事件/回调模式：立即返回，时间到后触发事件/回调 * 同步模式：阻塞等待，UI保持响应 #### `Cancel()` 取消延迟。 **行为：** * 停止定时器（事件/回调模式） * 设置取消标志（同步模式） * 清理回调信息 * 触发 `OnCancel` 事件 ### 事件 #### `OnTime()` 时间到达时触发（仅事件模式）。 #### `OnCancel()` 延迟被取消时触发。 *** ## 同步模式详解 ### 为什么需要模块级变量？ 同步模式下 `CountDown` 是**阻塞调用**： ```vb ' 错误：局部变量无法在阻塞期间操作 Private Sub btnStart_Click() Dim delay As New cDelay delay.Sync().CountDown(3000) ' 阻塞在这里！ ' 下面的代码在3秒后才执行 End Sub ' 正确：模块级变量可以在其他事件中访问 Private m_Delay As cDelay Private Sub btnStart_Click() Set m_Delay = New cDelay m_Delay.Sync().CountDown(3000) ' 阻塞 End Sub Private Sub btnCancel_Click() m_Delay.Cancel ' 可以取消上面的等待 End Sub ``` ### 取消机制 ```vb Private Sub btnStart_Click() m_Delay.Sync().CountDown(10000) ' 10秒等待 ' 检查取消状态 If m_Delay.IsCancelled Then ' 用户提前取消了 Else ' 正常完成 End If End Sub ``` *** ## 技术实现 ### 消息泵原理 同步模式使用 Windows API 实现消息循环： ```vb Private Declare Function PeekMessage Lib "user32" ... Private Declare Function DispatchMessage Lib "user32" ... Do While Not bDone ' 检查取消标志 If m_Cancelled Then Exit Do ' 检查时间 If GetTickCount() >= EndTick Then Exit Do ' 处理消息队列 Do While PeekMessage(uMsg, 0, 0, 0, PM_REMOVE) <> 0 TranslateMessage uMsg DispatchMessage uMsg Loop Sleep 1 ' 避免CPU占用过高 Loop ``` 相比 `DoEvents` 的优势： * 更精细的控制 * 可以处理特定消息 * 避免重入问题 ### 自动生命周期管理 ``` 第一个实例创建 ↓ AutoInit() 调用 InitDelaySystem() ↓ 引用计数 = 1 ... 最后一个实例销毁 ↓ AutoCleanup() 检测到计数 = 0 ↓ 调用 TermDelaySystem() 清理全局资源 ``` *** ## 注意事项 1. **同步模式必须配合模块级变量使用**，否则无法取消 2. **取消后回调被清理**，需要重新设置 `Callback` 才能再次使用 3. **参数传递使用 Variant**，回调函数参数类型要匹配 4. **避免在回调中阻塞**，否则会影响其他定时器 5. **窗体卸载时清理**： ```vb Private Sub Form_Unload(Cancel As Integer) m_Delay.Cancel Set m_Delay = Nothing End Sub ``` *** ## 常见问题 ### Q: 同步模式下 UI 还会响应吗？ A: 会。消息泵会处理 Windows 消息，包括鼠标、键盘、重绘等。 ### Q: 可以同时运行多个延迟吗？ A: 可以。每个 `cDelay` 实例独立运行，通过全局集合管理。（将来增加 cDelays.cls 使用 Tag 管理多实例） ### Q: 回调模式可以调用私有方法吗？ A: 不可以。回调方法必须是 `Public` 的，因为 `CallByName` 需要外部可见。 ### Q: 同步模式的精度如何？ A: 受 `Sleep 1` 影响，精度约为 1-15 毫秒（取决于系统调度）。 *** ## 更新日志 ### v1.0 (2026-03-31) * 初始版本 * 支持三种模式：事件、回调、同步 * 自动生命周期管理 * 同步模式支持取消 *** ## 未来扩展功能预览 以下是计划中将与 `CountDown` 同级的新增延迟方式： ### 新增延迟方式概览 | 方法 | 用途 | 示例场景 | | --------------- | ------------ | --------------------- | | **ClockAt** | 指定时间执行 | 每天14:30提醒 | | **ClockAtDate** | 指定日期时间 | 2026-04-01会议提醒 | | **Interval** | 重复间隔执行 | 每5秒检查状态 | | **Random** | 随机时间范围 | 模拟人工操作防检测 | | **WaitUntil** | 条件满足执行 | 等待数据准备好 | | **Debounce** | 防抖 | 搜索框输入停止后搜索 | | **Throttle** | 节流 | 滚动事件限制频率 | | **AfterLast** | 空闲后执行 | 无操作3秒后自动保存 | | **Retry** | 重试机制 | 网络请求失败自动重试 | | **Schedule** | 多时间点 | 每天9/12/18点检查邮件 | | **DelayAfter** | 事件后延迟 | 文件修改后5秒备份 | ### 代码示例 ```vb ' 每天14:30执行 delay.ClockAt("14:30:00").RepeatDaily().Callback(Me, "DailyReport") ' 每5秒检查一次，最多10次 delay.Interval(5000).RepeatCount(10).Callback(Me, "CheckStatus") ' 防抖：输入停止500ms后才搜索 delay.Debounce(500).Callback(Me, "DoSearch") ' 节流：最多每2秒记录一次日志 delay.Throttle(2000).Callback(Me, "SaveLog") ' 空闲3秒后自动保存 delay.AfterLastInput(3000).Callback(Me, "AutoSave") ' 失败后重试3次，间隔递增(1s, 2s, 4s) delay.Retry(3, 1000, 2).Callback(Me, "ConnectServer") ``` ### 这些功能让 cDelay 从一个简单的延时工具变成强大的调度系统！ 路线图：[./TODO.md](./TODO.md) *最后更新: 2026-03-31* --- --- url: /en/vbman/delay/TODO.md --- # cDelay Delay Object - TODO and Roadmap ```vb '=========================================================================== ' Name: cDelay ' Description: Delay object class - supports event-triggered, callback, ' and synchronous wait modes ' Author: Deng Wei, QQ: 215879458 ' Website: https://vb6.pro ' Date: 2026-03-31 ' Reference: cTimer.cls architecture '=========================================================================== ``` ## Current Version: v1.0 ### Implemented Features * \[x] Three working modes: Event, Callback, Sync * \[x] ParamArray variable parameter support (up to 9) * \[x] Sync mode message pump implementation (without DoEvents) * \[x] Sync mode cancellation * \[x] Automatic lifecycle management (reference counting) * \[x] Chainable API design *** ## Roadmap ### v1.1 Enhanced Multi-Instance Management Based on Toast implementation, implement more powerful multi-instance management: #### 1.1.1 Instance Naming and Tracking ```vb ' Set name for delay instance for easier management Dim delay As New cDelay delay.Tag("AutoSaveTimer").Callback(Me, "AutoSave").CountDown(5000) ' Get instance status by name If Delays.Exists("AutoSaveTimer") Then Debug.Print "Remaining time: " & Delays("AutoSaveTimer").RemainingTime End If ``` **Implementation Points:** * Add `Tag` property/method supporting chainable calls * Global collection uses Key (such as "id:" & TimerID or custom Tag) * Provide `Delays.Exists(Tag)` method to check if instance exists * Provide `Delays(Tag)` indexer to get instance reference #### 1.1.2 Group Management by Type Based on Toast's 9 position collections, group by usage: ```vb ' Enum definition Public Enum DelayGroup dgSystem = 1 ' System-level delay dgUser = 2 ' User operation related dgBackground = 3 ' Background tasks dgAnimation = 4 ' Animation related End Enum ' Usage delay.Group(dgBackground).Callback(Me, "SyncData").CountDown(60000) ' Batch operations delay.Group(dgBackground).CancelAll ' Cancel all background tasks ``` **Implementation Points:** * Each Group corresponds to an independent Collection * Support group-level batch operations (CancelAll, PauseAll, ResumeAll) #### 1.1.3 Instance Status Query ```vb ' Get count of currently active delays Dim count As Long count = Delays.Count ' Total count = Delays.CountByGroup(dgSystem) ' By group ' Enumerate all active instances Dim d As cDelay For Each d In Delays Debug.Print d.Tag & " - Remaining: " & d.RemainingTime Next ``` **New Properties/Methods:** * `RemainingTime` - Remaining milliseconds (calculated property) * `ElapsedTime` - Elapsed milliseconds * `Progress` - Completion percentage (0-100) *** ### v1.2 New Delay Methods (Same level as CountDown) #### 1.2.1 ClockAt - Specify Absolute Time ```vb ' Execute at 14:30 today delay.ClockAt "14:30:00".Callback(Me, "DoSomething") ' Specify date and time delay.ClockAtDate "2026-04-01 09:00:00".Callback(Me, "MeetingReminder") ' Tomorrow at 8 AM delay.ClockAtDate DateAdd("d", 1, Date) & " 08:00:00" ``` **Implementation Points:** * Calculate difference between target time and current time * If target time has passed, choose to execute immediately or next day * Support repetition: daily/weekly/monthly at the same time #### 1.2.2 Interval - Repeating Interval ```vb ' Execute once every 5 seconds delay.Interval(5000).Callback(Me, "CheckStatus") ' Limited count delay.Interval(1000).RepeatCount(10).Callback(Me, "UpdateProgress") ' Stop delay.StopInterval ``` **Implementation Points:** * Internal use of Windows timer or loop * Support infinite repetition or specified count * Can dynamically modify interval time #### 1.2.3 Random - Random Delay ```vb ' Random between 1-5 seconds delay.Random(1000, 5000).Callback(Me, "RandomTask") ' Use for anti-detection, simulate human operations ``` #### 1.2.4 WaitUntil - Conditional Wait ```vb ' Wait for a condition to be true (up to 10 seconds) delay.WaitUntil(AddressOf IsDataReady, 10000).Callback(Me, "ProcessData") ' With function Public Function IsDataReady() As Boolean IsDataReady = (FileLen("data.txt") > 0) End Function ``` **Implementation Points:** * Poll and check condition in message loop * Support timeout * Can set check interval (default 100ms) #### 1.2.5 Debounce ```vb ' Execute search after 500ms of no input delay.Debounce(500).Callback(Me, "DoSearch") ' Use cases: search box, window resize ' When triggered frequently, only the last one executes ``` #### 1.2.6 Throttle ```vb ' Execute at most once every 2 seconds delay.Throttle(2000).Callback(Me, "SaveLog") ' Use cases: logging, scroll events ' When triggered frequently, execute at fixed rate ``` #### 1.2.7 AfterLast - Execute After Idle ```vb ' Execute after 3 seconds of no mouse/keyboard input delay.AfterLastInput(3000).Callback(Me, "AutoSave") ' With specific events delay.AfterLast("MouseMove", 1000).Callback(Me, "ShowTooltip") ``` **Implementation Points:** * Need to listen to system messages or poll GetLastInputInfo * Reset timer when new input arrives #### 1.2.8 Retry - Retry Mechanism ```vb ' Auto retry on failure, max 3 times, increasing interval delay.Retry(3, 1000, 2).Callback(Me, "ConnectServer") ' After 1st failure wait 1s, 2nd wait 2s, 3rd wait 4s ' With callback return value to determine success Public Function ConnectServer() As Boolean ' Return False will automatically trigger retry ConnectServer = AttemptConnection() End Function ``` #### 1.2.9 Schedule - Multi-Time Scheduling ```vb ' Multiple time points in a day delay.Schedule(Array("09:00", "12:00", "18:00")).Callback(Me, "CheckMail") ' Weekday scheduling delay.ScheduleWeekday("09:00,12:00,18:00").Callback(Me, "CheckMail") ``` #### 1.2.10 DelayAfter - Delay After Event ```vb ' Auto backup 5 seconds after file modification delay.AfterEvent("FileChanged", "C:\data.txt", 5000).Callback(Me, "BackupFile") ' Auto save after window loses focus delay.AfterEvent("LostFocus", Me.hWnd, 1000).Callback(Me, "AutoSave") ``` *** ### v1.3 Advanced Control Features #### 1.3.1 Pause and Resume ```vb delay.CountDown(10000) ' 10 second delay ' Pause delay.Pause ' Pause timing Debug.Print delay.RemainingTime ' How much time remains ' Resume delay.Resume ' Continue from where it paused ``` **Technical Approach:** * When pausing, record `PausedTick` and `RemainingAtPause` * When resuming, recalculate `EndTick = GetTickCount() + RemainingAtPause` * Only applicable to Windows timer mode (event/callback) #### 1.3.2 Reset and Modify ```vb ' Reset current delay (start from beginning) delay.Reset ' Modify remaining time delay.ChangeDelay 5000 ' Change to 5 seconds remaining ' Add time delay.AddTime 2000 ' Add 2 seconds ``` *** ### v1.4 Performance and Debugging Enhancements #### 1.4.1 Debug Mode ```vb ' Enable global debug Delays.DebugMode = True ' Output logs ' [cDelay] AutoSaveTimer: CountDown started, 5000ms ' [cDelay] AutoSaveTimer: Tick, remaining 3000ms ' [cDelay] AutoSaveTimer: OnTime fired ' [cDelay] AutoSaveTimer: Cancelled by user ``` #### 1.4.2 Performance Statistics ```vb ' Get statistics Dim stats As DelayStats stats = Delays.GetStats Debug.Print "Total created: " & stats.TotalCreated Debug.Print "Total completed: " & stats.TotalCompleted Debug.Print "Total cancelled: " & stats.TotalCancelled Debug.Print "Average execution time: " & stats.AvgExecutionTime ``` #### 1.4.3 Memory Monitoring ```vb ' Auto cleanup zombie instances (optional) Delays.AutoCleanup = True Delays.AutoCleanupInterval = 60000 ' Check every 60 seconds ``` *** ### v1.5 Sync Mode Enhancements #### 1.5.1 Timeout Handling ```vb ' Sync mode supports timeout callback delay.Sync().Timeout(5000).OnTimeout(Me, "OnSyncTimeout").CountDown(10000) ' If not completed within 10 seconds, trigger OnSyncTimeout after 5 seconds ``` #### 1.5.2 Conditional Wait ```vb ' Wait until condition is met or timeout delay.Sync().WaitUntil(AddressOf CheckCondition, 5000) ' Check CheckCondition function every frame, return True to end early ``` #### 1.5.3 Multi-Task Wait ```vb ' Wait for all multiple delays to complete Dim tasks As New Collection tasks.Add delay1 tasks.Add delay2 tasks.Add delay3 Delay.WaitAll(tasks, 10000) ' Wait max 10 seconds ' Or wait for any to complete Delay.WaitAny(tasks, 10000) ``` *** ### v1.6 Callback Enhancements #### 1.6.1 Lambda/Anonymous Function Support (VB6 Simulation) ```vb ' Use AddressOf to pass function pointer delay.Callback(AddressOf MyStaticFunc).CountDown(1000) ' Or use class instance method delay.Callback2(Me, "MethodName", param1, param2) ``` #### 1.6.2 Async Callback ```vb ' Callback executes in independent thread (use with caution) delay.AsyncCallback(Me, "HeavyTask").CountDown(100) ``` #### 1.6.3 Callback Chain ```vb ' Multiple callbacks execute in order delay.Callback(Me, "Step1") _ .Then(Me, "Step2") _ .Then(Me, "Step3") _ .CountDown(1000) ' After 1000ms, execute Step1 -> Step2 -> Step3 in sequence ``` *** ### v1.7 Integration and Extensions #### 1.7.1 Integration with UI Controls ```vb ' Auto update progress bar delay.BindProgressBar(ProgressBar1).CountDown(5000) ' Auto update label delay.BindLabel(Label1, "Time remaining: {remaining}s").CountDown(5000) ``` #### 1.7.2 Sound Support ```vb delay.OnTimeSound("C:\Windows\Media\chimes.wav").CountDown(5000) delay.OnCancelSound("C:\Windows\Media\ding.wav") ``` #### 1.7.3 Configuration File Support ```vb ' Load from configuration delay.LoadConfig("AutoSaveDelay") ' Read from registry/INI: Delay.AutoSaveDelay = 5000 ``` *** ### v2.0 Architecture Refactoring (Long-term) #### 2.0.1 COM Component * Compile as ActiveX DLL * Support cross-project reuse * Provide strongly-typed interfaces #### 2.0.2 Multi-threading Support * True background thread timer * Does not depend on Windows message queue * Suitable for windowless environments (like Windows Service) #### 2.0.3 .NET Interoperability * Provide .NET wrapper class * Support calling from VB.NET/C# *** ## Priority Recommendations ### High Priority (Near-term Implementation) 1. **Instance naming and tracking** - Basic functionality, many advanced features depend on it 2. **ClockAt** - Execute at specified time, very practical feature 3. **Interval** - Repeating interval execution, similar to timer 4. **Debounce/Throttle** - Essential for UI development 5. **Debug mode** - Easier development and troubleshooting ### Medium Priority (Mid-term Implementation) 6. Group management by type 7. Pause/Resume functionality 8. Random delay 9. WaitUntil conditional wait 10. Performance statistics ### Low Priority (Long-term Consideration) 11. Retry mechanism 12. Multi-time scheduling 13. Multi-task wait 14. Callback chain 15. COM component *** ## Design Principles 1. **Backward Compatibility**: All new features are optional, do not affect existing API 2. **Chainable Calls**: Maintain `object.Method().Another().Action()` style 3. **Reasonable Defaults**: Provide smart default behavior when not set 4. **Error Handling**: All operations have clear error status and return values 5. **Resource Safety**: Ensure no memory leaks, thorough cleanup *** ## Contribution Suggestions If you want to participate in development, here are some entry points: * **Documentation**: Supplement more usage examples and best practices * **Test Cases**: Write boundary condition tests (like extreme time values, concurrent scenarios) * **Performance Optimization**: Optimize message loop, reduce CPU usage * **Code Review**: Check thread safety and resource release *** ## Reference Resources * Toast multi-instance management: `D:\code\vi\vbmanlib\vbman\src\Toast\cToast.cls` * Windows Timer API: MSDN `SetTimer` / `KillTimer` * VB6 message loop: `PeekMessage` / `DispatchMessage` * Design patterns: Observer pattern, Factory pattern, Object pool *** *Last Updated: 2026-03-31* --- --- url: /en/vbman/delay/readme.md --- # cDelay Delay Object Development Documentation ```vb '=========================================================================== ' Name: cDelay ' Description: Delay object class - supports event-triggered, callback, ' and synchronous wait modes ' Author: Deng Wei, QQ: 215879458 ' Website: https://vb6.pro ' Date: 2026-03-31 ' Reference: cTimer.cls architecture '=========================================================================== ``` ## Overview `cDelay` is a VB6 delay object class providing three usage modes: * **Event Mode**: Triggered via `OnTime` event * **Callback Mode**: Calls specified function via `CallByName` * **Sync Mode**: Blocks and waits without freezing UI ## File Structure ``` Delay/ ├── cDelay.cls ' Delay object class ├── mDelay.bas ' Management module (global collection, timer callback) └── cDelayDemo.frm ' Demo form ``` ## Features * ✅ Automatic lifecycle management (reference counting) * ✅ Support up to 9 callback parameters (using ParamArray) * ✅ Sync mode supports cancellation * ✅ Message pump implementation without DoEvents dependency * ✅ Thread-safe message loop *** ## Quick Start ### 1. Event Mode ```vb Private WithEvents m_Delay As cDelay Private Sub Form_Load() Set m_Delay = New cDelay End Sub Private Sub btnStart_Click() m_Delay.CountDown 3000 ' Triggers OnTime after 3 seconds End Sub Private Sub m_Delay_OnTime() MsgBox "Time's up!" End Sub ``` ### 2. Callback Mode ```vb Private m_Delay As cDelay Private Sub Form_Load() Set m_Delay = New cDelay End Sub Private Sub btnStart_Click() ' Chainable call with multiple parameters m_Delay.Callback(Me, "MyFunc", "param1", 123, Now).CountDown 3000 End Sub Public Sub MyFunc(ByVal s As String, ByVal n As Long, ByVal d As Date) MsgBox s & ", " & n End Sub ``` ### 3. Sync Mode ```vb Private m_DelaySync As cDelay ' Must be module-level to allow cancellation Private Sub btnStart_Click() lblStatus.Caption = "Waiting..." lblStatus.Refresh m_DelaySync.Sync().CountDown 3000 ' Wait 3 seconds, UI stays responsive ' Check if cancelled If m_DelaySync.IsCancelled Then lblStatus.Caption = "Cancelled" Else lblStatus.Caption = "Done!" End If End Sub Private Sub btnCancel_Click() m_DelaySync.Cancel ' Cancel sync wait End Sub ``` *** ## API Reference ### Properties | Property | Type | Description | |----------|------|-------------| | `Mode` | `DelayMode` | Current mode (read-only) | | `IsActive` | `Boolean` | Whether active (read-only) | | `IsCancelled` | `Boolean` | Whether cancelled in sync mode (read-only) | | `DelayMs` | `Long` | Delay milliseconds (read-only) | > 📊 **Comparison Analysis**: [cDelay vs Native DoEvents](./whyDelay.md) ### Methods #### `Callback(CallbackObject, ProcName, [ParamArray P()])` Sets callback mode. **Parameters:** * `CallbackObject` - Object containing the callback method (usually `Me`) * `ProcName` - Callback method name (string) * `P()` - Optional parameters, up to 9 **Returns:** `cDelay` object itself (chainable) **Example:** ```vb delay.Callback(Me, "ProcessData", userId, userName).CountDown(2000) ``` #### `Sync()` Sets sync mode. **Returns:** `cDelay` object itself (chainable) **Example:** ```vb delay.Sync().CountDown(5000) ``` #### `CountDown(Milliseconds)` Starts countdown. **Parameters:** * `Milliseconds` - Delay time (milliseconds) **Notes:** * Event/Callback mode: Returns immediately, triggers event/callback when time is up * Sync mode: Blocks and waits, UI stays responsive #### `Cancel()` Cancels the delay. **Behavior:** * Stops timer (event/callback mode) * Sets cancelled flag (sync mode) * Clears callback info * Triggers `OnCancel` event ### Events #### `OnTime()` Triggers when time is up (event mode only). #### `OnCancel()` Triggers when delay is cancelled. *** ## Sync Mode Details ### Why Module-Level Variable Required? In sync mode, `CountDown` is a **blocking call**: ```vb ' Wrong: Local variable cannot be operated during blocking Private Sub btnStart_Click() Dim delay As New cDelay delay.Sync().CountDown(3000) ' Blocks here! ' Code below executes after 3 seconds End Sub ' Correct: Module-level variable can be accessed in other events Private m_Delay As cDelay Private Sub btnStart_Click() Set m_Delay = New cDelay m_Delay.Sync().CountDown(3000) ' Blocks End Sub Private Sub btnCancel_Click() m_Delay.Cancel ' Can cancel the wait above End Sub ``` ### Cancellation Mechanism ```vb Private Sub btnStart_Click() m_Delay.Sync().CountDown(10000) ' 10 second wait ' Check cancellation status If m_Delay.IsCancelled Then ' User cancelled early Else ' Completed normally End If End Sub ``` *** ## Technical Implementation ### Message Pump Principle Sync mode uses Windows API to implement message loop: ```vb Private Declare Function PeekMessage Lib "user32" ... Private Declare Function DispatchMessage Lib "user32" ... Do While Not bDone ' Check cancelled flag If m_Cancelled Then Exit Do ' Check time If GetTickCount() >= EndTick Then Exit Do ' Process message queue Do While PeekMessage(uMsg, 0, 0, 0, PM_REMOVE) <> 0 TranslateMessage uMsg DispatchMessage uMsg Loop Sleep 1 ' Avoid high CPU usage Loop ``` Advantages over `DoEvents`: * Finer control * Can process specific messages * Avoids reentrancy issues ### Automatic Lifecycle Management ``` First instance created ↓ AutoInit() calls InitDelaySystem() ↓ Reference count = 1 ... Last instance destroyed ↓ AutoCleanup() detects count = 0 ↓ Calls TermDelaySystem() to cleanup global resources ``` *** ## Notes 1. **Sync mode must use module-level variable**, otherwise cannot be cancelled 2. **Callback is cleared after cancellation**, need to set `Callback` again to use 3. **Parameter passing uses Variant**, callback function parameter types must match 4. **Avoid blocking in callback**, otherwise will affect other timers 5. **Cleanup on form unload**: ```vb Private Sub Form_Unload(Cancel As Integer) m_Delay.Cancel Set m_Delay = Nothing End Sub ``` *** ## FAQ ### Q: Will UI still respond in sync mode? A: Yes. The message pump processes Windows messages including mouse, keyboard, repaint, etc. ### Q: Can multiple delays run simultaneously? A: Yes. Each `cDelay` instance runs independently, managed through global collection. (Future: add cDelays.cls for multi-instance management with Tag) ### Q: Can callback mode call private methods? A: No. Callback methods must be `Public` because `CallByName` requires external visibility. ### Q: What is the precision of sync mode? A: Affected by `Sleep 1`, precision is approximately 1-15 milliseconds (depending on system scheduling). *** ## Changelog ### v1.0 (2026-03-31) * Initial release * Three modes: Event, Callback, Sync * Automatic lifecycle management * Sync mode supports cancellation *** ## Future Feature Preview Below are planned new delay methods at the same level as `CountDown`: ### New Delay Methods Overview | Method | Purpose | Example Scenario | |--------|---------|------------------| | **ClockAt** | Execute at specified time | Daily 14:30 reminder | | **ClockAtDate** | Specify date and time | 2026-04-01 meeting reminder | | **Interval** | Repeating interval | Check status every 5 seconds | | **Random** | Random time range | Simulate human operations | | **WaitUntil** | Execute when condition met | Wait for data ready | | **Debounce** | Debounce | Search after input stops | | **Throttle** | Throttle | Limit scroll event frequency | | **AfterLast** | Execute after idle | Auto save after 3 seconds idle | | **Retry** | Retry mechanism | Auto retry failed network request | | **Schedule** | Multi-time | Check mail at 9/12/18 daily | | **DelayAfter** | Delay after event | Auto backup 5s after file modified | ### Code Examples ```vb ' Execute at 14:30 daily delay.ClockAt("14:30:00").RepeatDaily().Callback(Me, "DailyReport") ' Check once every 5 seconds, max 10 times delay.Interval(5000).RepeatCount(10).Callback(Me, "CheckStatus") ' Debounce: search after 500ms of no input delay.Debounce(500).Callback(Me, "DoSearch") ' Throttle: log at most once every 2 seconds delay.Throttle(2000).Callback(Me, "SaveLog") ' Auto save after 3 seconds idle delay.AfterLastInput(3000).Callback(Me, "AutoSave") ' Retry 3 times on failure, increasing interval (1s, 2s, 4s) delay.Retry(3, 1000, 2).Callback(Me, "ConnectServer") ``` ### These features transform cDelay from a simple delay utility into a powerful scheduling system! Roadmap: [./TODO.md](./TODO.md) *Last Updated: 2026-03-31* --- --- url: /zh/vbman/delay/whyDelay.md --- # cDelay vs 原生 `Do...Loop + DoEvents` 及 `Timer 控件` 对比分析 ## 本质区别 **不完全一样**。cDelay 提供了更完善、更灵活的延迟机制，适用于不同的场景需求。 *** ## 实现机制对比 | 方式 | 实现机制 | 阻塞性 | CPU 占用 | | ------------------------ | -------------------------------------- | ------ | ------------------------- | | **原生 Do Loop** | 纯循环占用 CPU，靠 DoEvents 释放控制权 | 半阻塞 | 高（循环一直在跑） | | **Timer 控件** | Windows 定时器 (SetTimer)，需手动关闭 | 非阻塞 | 低 | | **cDelay 事件/回调模式** | Windows 定时器 (SetTimer)，异步回调 | 非阻塞 | 低（定时器由系统触发） | | **cDelay 同步模式** | 消息泵循环 (PeekMessage) | 伪阻塞 | 低（处理消息但不卡死 UI） | *** ## cDelay 的核心优势 ### 1. 真正的非阻塞（事件/回调模式） **原生方式** - 代码一直在运行，占用 CPU： ```vb Do While Timer < target DoEvents ' 释放控制权，但循环仍在跑 Loop ``` **Timer 控件方式** - 需要手动管理启用/关闭： ```vb ' 设计时拖一个 Timer 控件到窗体 Timer1.Interval = 3000 Timer1.Enabled = True Private Sub Timer1_Timer() Timer1.Enabled = False ' 必须手动关闭，否则会重复触发 MsgBox "时间到了！" End Sub ``` **cDelay 事件模式** - 设置后立即返回，自动一次性触发： ```vb Delay.CountDown 3000 ' 立即返回，3 秒后触发 OnTime 事件，自动清理 ``` ### 2. 支持回调函数模式 可以直接调用对象方法并传参： ```vb ' 链式调用，简洁优雅 Delay.Callback(Me, "UpdateUI", "参数1", 123).CountDown 1000 ' 对比原生方式需要在循环后手动调用 ``` ### 3. 精确的时间控制 | 方式 | 精度 | | --------------------- | -------- | | 原生 `Timer` | 约 50ms | | cDelay `GetTickCount` | 1ms 级别 | ### 4. 可取消机制 ```vb ' 随时可以调用 Cancel 停止 Delay.Cancel ' 同步模式还能检查是否被取消 If Delay.IsCancelled Then ' 用户取消了操作 End If ``` ### 5. 消息泵处理更完整 cDelay 使用完整的 `PeekMessage → TranslateMessage → DispatchMessage` 消息处理链，比单纯的 `DoEvents` 更可靠。 *** ## Timer 控件 vs cDelay 深度对比 虽然 Timer 控件也是基于 Windows 定时器，但与 cDelay 相比有明显局限： ### Timer 控件的局限 | 局限 | 说明 | | ---------------- | ---------------------------------------------------- | | **重复触发** | Timer 默认会重复触发，必须手动设置 `Enabled = False` | | **无内置回调** | 只能通过事件处理，无法直接调用指定函数 | | **难以传递参数** | 需要通过全局/模块级变量间接传递 | | **代码分散** | 初始化代码和回调代码分离，可读性差 | | **生命周期管理** | 需手动管理，易忘记关闭导致重复执行 | ### 代码对比示例 **场景：3秒后执行特定任务，并传递参数** #### Timer 控件方式（繁琐） ```vb ' 模块级变量存储参数 Private m_UserID As Long Private m_Message As String Private Sub btnStart_Click() m_UserID = 123 m_Message = "操作完成" Timer1.Interval = 3000 Timer1.Enabled = True End Sub Private Sub Timer1_Timer() Timer1.Enabled = False ' 必须手动关闭！ ProcessResult m_UserID, m_Message ' 使用存储的参数 End Sub Private Sub ProcessResult(ByVal UserID As Long, ByVal Msg As String) MsgBox "用户 " & UserID & ": " & Msg End Sub ``` #### cDelay 回调模式（简洁） ```vb Private Sub btnStart_Click() ' 一行代码，参数直接传递，自动一次性执行 Delay.Callback(Me, "ProcessResult", 123, "操作完成").CountDown 3000 End Sub Public Sub ProcessResult(ByVal UserID As Long, ByVal Msg As String) MsgBox "用户 " & UserID & ": " & Msg End Sub ``` ### 多任务场景对比 **场景：同时执行多个不同的延迟任务** #### Timer 控件方式（需要多个控件或复杂管理） ```vb ' 需要多个 Timer 控件或复杂的单 Timer 状态管理 Timer1.Interval = 1000: Timer1.Enabled = True ' 任务1 Timer2.Interval = 2000: Timer2.Enabled = True ' 任务2 Timer3.Interval = 3000: Timer3.Enabled = True ' 任务3 ' 或者一个 Timer + 复杂的状态判断... ``` #### cDelay 方式（实例独立管理，后续引入 cDelays 后更优雅和简洁） ```vb Private m_Delay1 As cDelay Private m_Delay2 As cDelay Private m_Delay3 As cDelay Private Sub btnStart_Click() Set m_Delay1 = New cDelay Set m_Delay2 = New cDelay Set m_Delay3 = New cDelay m_Delay1.Callback(Me, "Task1").CountDown 1000 m_Delay2.Callback(Me, "Task2").CountDown 2000 m_Delay3.Callback(Me, "Task3").CountDown 3000 End Sub ``` *** ## 代码简洁性对比 ### 原生方式（冗长） ```vb Dim start As Long, cancelled As Boolean start = GetTickCount() Do While GetTickCount() < start + 3000 DoEvents If UserClickedCancel Then cancelled = True Exit Do End If Loop If Not cancelled Then Call DoSomething ``` ### cDelay 方式（简洁） ```vb ' 回调模式 Delay.Callback(Me, "DoSomething").CountDown 3000 ' 需要取消时：Delay.Cancel ``` *** ## 适用场景对比 | 场景 | 推荐方式 | 理由 | | ---------------------- | --------------- | -------------------------- | | 简单延迟、临时测试 | 原生 Do Loop | 简单直接，无需额外依赖 | | 简单的周期性任务 | Timer 控件 | 窗体设计器直接拖放，简单 | | 一次性延时 + 回调 | cDelay 回调模式 | 无需手动关闭，参数直接传递 | | 等待时仍需响应用户操作 | cDelay 同步模式 | 消息泵处理更完善 | | 需要精确计时、可取消 | cDelay | 1ms 精度 + Cancel 机制 | | 批量定时任务管理 | cDelay | 集合管理，生命周期自动 | | 多实例独立管理 | cDelay | 每个实例独立，不冲突 | *** ## 总结 | 维度 | 原生 Do Loop | Timer 控件 | cDelay | | -------------- | ------------- | --------------- | --------------- | | **使用方式** | 代码直接写 | 窗体拖放 | 创建对象实例 | | **复杂度** | 简单 | 简单 | 中等（封装类） | | **一次性触发** | ✅ 天然支持 | ❌ 需手动关闭 | ✅ 自动支持 | | **内置回调** | ❌ 不支持 | ❌ 不支持 | ✅ 支持 | | **参数传递** | 直接 | 需全局变量 | 直接（最多9个） | | **取消机制** | Exit Do | Enabled=False | Cancel 方法 | | **多实例管理** | 单线程 | 需多控件 | 独立实例 | | **精度** | 50ms | 55ms (系统限制) | 1ms | | **CPU 占用** | 高 | 低 | 低 | | **生命周期** | 代码控制 | 手动管理 | 自动管理 | | **可维护性** | 一般 | 一般 | 好 | | **适用规模** | 临时/简单场景 | 简单定时任务 | 项目级/复杂调度 | ### 选择建议 | 你的需求 | 推荐方案 | | ------------------------------ | ------------------------- | | 临时测试、几行代码搞定 | 原生 `Do Loop + DoEvents` | | 简单的周期性轮询（如状态检查） | **Timer 控件** | | 一次性延时后执行回调 | **cDelay 回调模式** | | 需要传递参数、精确控制 | **cDelay** | | 多个独立定时任务 | **cDelay** | | 需要同步等待但保持 UI 响应 | **cDelay 同步模式** | **cDelay 的核心价值**： * ✅ **一次性触发**（Timer 需手动关闭） * ✅ **直接回调传参**（无需全局变量） * ✅ **实例独立管理**（多任务不冲突） * ✅ **自动生命周期**（无需手动清理） * ✅ **1ms 精度 + 取消机制** --- --- url: /en/vbman/delay/whyDelay.md --- # cDelay vs Native `Do...Loop + DoEvents` and `Timer Control` Comparison ## Fundamental Differences **Not exactly the same.** cDelay provides a more complete and flexible delay mechanism, suitable for different scenario requirements. *** ## Implementation Mechanism Comparison | Method | Implementation | Blocking | CPU Usage | |--------|---------------|----------|-----------| | **Native Do Loop** | Pure loop occupies CPU, uses DoEvents to release control | Semi-blocking | High (loop always running) | | **Timer Control** | Windows timer (SetTimer), requires manual shutdown | Non-blocking | Low | | **cDelay Event/Callback Mode** | Windows timer (SetTimer), async callback | Non-blocking | Low (timer triggered by system) | | **cDelay Sync Mode** | Message pump loop (PeekMessage) | Pseudo-blocking | Low (processes messages without freezing UI) | *** ## cDelay Core Advantages ### 1. True Non-blocking (Event/Callback Mode) **Native approach** - Code runs continuously, occupies CPU: ```vb Do While Timer < target DoEvents ' Releases control, but loop still running Loop ``` **Timer Control approach** - Requires manual management of enable/disable: ```vb ' Drag a Timer control onto the form at design time Timer1.Interval = 3000 Timer1.Enabled = True Private Sub Timer1_Timer() Timer1.Enabled = False ' Must manually disable, otherwise repeats MsgBox "Time's up!" End Sub ``` **cDelay Event Mode** - Returns immediately after setting, triggers once automatically: ```vb Delay.CountDown 3000 ' Returns immediately, triggers OnTime event after 3 seconds, auto cleanup ``` ### 2. Supports Callback Function Mode Can directly call object methods and pass parameters: ```vb ' Chainable call, concise and elegant Delay.Callback(Me, "UpdateUI", "param1", 123).CountDown 1000 ' Compared to native approach requiring manual call after loop ``` ### 3. Precise Time Control | Method | Precision | |--------|-----------| | Native `Timer` | ~50ms | | cDelay `GetTickCount` | 1ms level | ### 4. Cancellable Mechanism ```vb ' Cancel anytime Delay.Cancel ' Sync mode can also check if cancelled If Delay.IsCancelled Then ' User cancelled operation End If ``` ### 5. More Complete Message Pump Processing cDelay uses complete `PeekMessage → TranslateMessage → DispatchMessage` message processing chain, more reliable than simple `DoEvents`. *** ## Timer Control vs cDelay Deep Comparison Although Timer control is also based on Windows timer, it has obvious limitations compared to cDelay: ### Timer Control Limitations | Limitation | Description | |------------|-------------| | **Repeat Triggering** | Timer triggers repeatedly by default, must manually set `Enabled = False` | | **No Built-in Callback** | Can only handle via events, cannot directly call specified function | | **Hard to Pass Parameters** | Needs to use global/module-level variables indirectly | | **Scattered Code** | Initialization code and callback code are separated, poor readability | | **Lifecycle Management** | Manual management, easy to forget shutdown causing repeated execution | ### Code Comparison Example **Scenario: Execute specific task after 3 seconds with parameters** #### Timer Control Approach (Cumbersome) ```vb ' Module-level variables to store parameters Private m_UserID As Long Private m_Message As String Private Sub btnStart_Click() m_UserID = 123 m_Message = "Operation complete" Timer1.Interval = 3000 Timer1.Enabled = True End Sub Private Sub Timer1_Timer() Timer1.Enabled = False ' Must manually disable! ProcessResult m_UserID, m_Message ' Use stored parameters End Sub Private Sub ProcessResult(ByVal UserID As Long, ByVal Msg As String) MsgBox "User " & UserID & ": " & Msg End Sub ``` #### cDelay Callback Mode (Concise) ```vb Private Sub btnStart_Click() ' One line, parameters passed directly, auto one-time execution Delay.Callback(Me, "ProcessResult", 123, "Operation complete").CountDown 3000 End Sub Public Sub ProcessResult(ByVal UserID As Long, ByVal Msg As String) MsgBox "User " & UserID & ": " & Msg End Sub ``` ### Multi-Task Scenario Comparison **Scenario: Execute multiple different delay tasks simultaneously** #### Timer Control Approach (Requires multiple controls or complex management) ```vb ' Need multiple Timer controls or complex single Timer state management Timer1.Interval = 1000: Timer1.Enabled = True ' Task 1 Timer2.Interval = 2000: Timer2.Enabled = True ' Task 2 Timer3.Interval = 3000: Timer3.Enabled = True ' Task 3 ' Or one Timer + complex state judgment... ``` #### cDelay Approach (Instances are independent, more elegant and concise with future cDelays) ```vb Private m_Delay1 As cDelay Private m_Delay2 As cDelay Private m_Delay3 As cDelay Private Sub btnStart_Click() Set m_Delay1 = New cDelay Set m_Delay2 = New cDelay Set m_Delay3 = New cDelay m_Delay1.Callback(Me, "Task1").CountDown 1000 m_Delay2.Callback(Me, "Task2").CountDown 2000 m_Delay3.Callback(Me, "Task3").CountDown 3000 End Sub ``` *** ## Code Conciseness Comparison ### Native Approach (Verbose) ```vb Dim start As Long, cancelled As Boolean start = GetTickCount() Do While GetTickCount() < start + 3000 DoEvents If UserClickedCancel Then cancelled = True Exit Do End If Loop If Not cancelled Then Call DoSomething ``` ### cDelay Approach (Concise) ```vb ' Callback mode Delay.Callback(Me, "DoSomething").CountDown 3000 ' When cancellation needed: Delay.Cancel ``` *** ## Use Case Comparison | Scenario | Recommended | Reason | |----------|-------------|--------| | Simple delay, temporary test | Native Do Loop | Simple and direct, no extra dependencies | | Simple periodic task | Timer Control | Drag and drop directly on form designer | | One-time delay + callback | cDelay Callback Mode | No manual shutdown, direct parameter passing | | Still need to respond to user operations while waiting | cDelay Sync Mode | Message pump processing more complete | | Need precise timing, cancellable | cDelay | 1ms precision + Cancel mechanism | | Batch scheduling tasks | cDelay | Collection management, auto lifecycle | | Multi-instance independent management | cDelay | Each instance independent, no conflicts | *** ## Summary | Dimension | Native Do Loop | Timer Control | cDelay | |-----------|---------------|---------------|--------| | **Usage** | Code written directly | Form drag-drop | Create object instance | | **Complexity** | Simple | Simple | Medium (wrapper class) | | **One-time Trigger** | ✅ Natural support | ❌ Manual shutdown | ✅ Auto support | | **Built-in Callback** | ❌ Not supported | ❌ Not supported | ✅ Supported | | **Parameter Passing** | Direct | Need global variables | Direct (up to 9) | | **Cancel Mechanism** | Exit Do | Enabled=False | Cancel method | | **Multi-instance** | Single thread | Need multiple controls | Independent instances | | **Precision** | 50ms | 55ms (system limit) | 1ms | | **CPU Usage** | High | Low | Low | | **Lifecycle** | Code controlled | Manual management | Auto management | | **Maintainability** | Average | Average | Good | | **Scale** | Temporary/simple | Simple timer tasks | Project-level/complex scheduling | ### Selection Recommendations | Your Requirement | Recommended Solution | |-----------------|---------------------| | Temporary test, a few lines搞定 | Native `Do Loop + DoEvents` | | Simple periodic polling (like status check) | **Timer Control** | | One-time delay then execute callback | **cDelay Callback Mode** | | Need to pass parameters, precise control | **cDelay** | | Multiple independent timer tasks | **cDelay** | | Need sync wait but keep UI responsive | **cDelay Sync Mode** | **cDelay Core Value:** * ✅ **One-time trigger** (Timer requires manual shutdown) * ✅ **Direct callback parameter passing** (No global variables needed) * ✅ **Independent instance management** (Multi-tasks without conflicts) * ✅ **Auto lifecycle** (No manual cleanup needed) * ✅ **1ms precision + Cancel mechanism** --- --- url: /zh/vbman2/webview2/cdp.md --- # CDP 专题 - Chrome DevTools Protocol 调用指南 ## 📖 目录 * [概述](#概述) * [同步调用](#同步调用) * [异步调用](#异步调用) * [常用 CDP 方法](#常用-cdp-方法) * [Cookie 操作](#cookie-操作) * [性能与限制](#性能与限制) * [完整示例](#完整示例) *** ## 概述 Chrome DevTools Protocol (CDP) 是 Chromium 浏览器提供的底层调试和控制协议。cWebView2Host 支持 VB6 直接调用 CDP，实现对浏览器行为的深度控制，远超 WebView2 公开 API 的能力范围。 ### ✨ 核心特点 * 🔧 **同步/异步双模式** - 简单场景用同步调用获取结果，复杂场景用异步避免阻塞 * 🍪 **HttpOnly Cookie** - 通过 CDP 获取 JavaScript 无法读取的 HttpOnly Cookie * 📸 **截图捕获** - 调用 Page.captureScreenshot 实现页面截图 * 🔍 **DOM 深度操作** - 直接操控 DOM 树，不经过 JavaScript 层 * 🌐 **网络控制** - 拦截和修改网络请求/响应 *** ## 同步调用 ### CallDevToolsProtocolMethodSync 阻塞当前线程直到 CDP 返回结果，最简单的使用方式： ```vb Public Function CallDevToolsProtocolMethodSync( _ ByVal MethodName As String, _ ByVal ParametersAsJson As String) As String ``` **返回**: CDP 响应的 JSON 字符串 **内部机制**: 使用 Sleep + DoEvents 循环等待，不影响 VB6 窗体消息循环。 **示例**: ```vb Dim wv As New cWebView2Host ' 同步调用无需 WithEvents Private Sub Form_Load() wv.Initialize Me.hWnd, "https://vb6.pro" End Sub Private Sub Command1_Click() ' 获取页面标题 Dim title As String title = wv.CallDevToolsProtocolMethodSync( _ "Runtime.evaluate", _ "{""expression"":""document.title""}") MsgBox "Title: " & title ' 获取所有 Cookie Dim cookies As String cookies = wv.CallDevToolsProtocolMethodSync( _ "Network.getCookies", _ "{}") ' 获取浏览器版本 Dim version As String version = wv.CallDevToolsProtocolMethodSync( _ "Browser.getVersion", _ "{}") End Sub ``` ### 何时使用同步模式 * 简单的查询操作（获取属性、Cookie 等） * 需要立即获取结果继续后续逻辑 * 不关心 UI 阻塞（或阻塞时间极短） *** ## 异步调用 ### CallDevToolsProtocolMethod 发起 CDP 调用后立即返回，结果通过事件异步回报： ```vb Public Sub CallDevToolsProtocolMethod( _ ByVal MethodName As String, _ ByVal ParametersAsJson As String, _ ByVal CustomEventId As String) ``` **参数**: * `CustomEventId` - 自定义事件 ID，在 `DevToolsProtocolResponse` 事件中用于匹配响应 **示例**: ```vb Dim WithEvents wv As cWebView2Host ' 异步需要 WithEvents Private Sub Command1_Click() ' 发起多个异步 CDP 调用 wv.CallDevToolsProtocolMethod "Page.captureScreenshot", "{}", "screenshot" wv.CallDevToolsProtocolMethod "DOM.getDocument", "{}", "domDoc" wv.CallDevToolsProtocolMethod "Runtime.evaluate", _ "{""expression"":""document.URL""}", "pageUrl" End Sub Private Sub wv_DevToolsProtocolResponse(ByVal CustomEventId As Variant, ByVal JsonResponse As String) Select Case CustomEventId Case "screenshot" Debug.Print "Screenshot data received" ' JsonResponse 包含 base64 编码的截图数据 Case "domDoc" Debug.Print "DOM document: " & Left(JsonResponse, 200) Case "pageUrl" Debug.Print "Page URL: " & JsonResponse End Select End Sub ``` ### 何时使用异步模式 * 耗时操作（截图、大量 DOM 操作） * 需要同时发起多个 CDP 调用 * 不希望阻塞 UI 线程 *** ## 常用 CDP 方法 ### Runtime 域 | 方法 | 参数 | 用途 | |------|------|------| | `Runtime.evaluate` | `{expression, returnByValue?, awaitPromise?}` | 执行 JS 表达式 | | `Runtime.callFunctionOn` | `{functionDeclaration, objectId, arguments, returnByValue}` | 在指定对象上调用函数 | | `Runtime.getProperties` | `{objectId, ownProperties}` | 获取对象属性 | ### Network 域 | 方法 | 参数 | 用途 | |------|------|------| | `Network.getCookies` | `{urls?}` | 获取 Cookie（含 HttpOnly） | | `Network.getAllCookies` | `{}` | 获取所有 Cookie | | `Network.deleteCookies` | `{name, url?, domain?, path?}` | 删除 Cookie | | `Network.setCookie` | `{name, value, url?, domain?, path?, httpOnly?, secure?}` | 设置 Cookie | | `Network.setExtraHTTPHeaders` | `{headers}` | 设置额外 HTTP 头 | ### Page 域 | 方法 | 参数 | 用途 | |------|------|------| | `Page.captureScreenshot` | `{format?, quality?, clip?}` | 页面截图 | | `Page.printToPDF` | `{landscape?, paperWidth?, ...}` | 打印为 PDF | | `Page.navigate` | `{url, referrer?}` | 导航 | | `Page.reload` | `{ignoreCache?}` | 重新加载 | ### DOM 域 | 方法 | 参数 | 用途 | |------|------|------| | `DOM.getDocument` | `{depth?}` | 获取文档根节点 | | `DOM.querySelector` | `{nodeId, selector}` | CSS 选择器查询 | | `DOM.getOuterHTML` | `{nodeId}` | 获取元素 HTML | | `DOM.setAttributeValue` | `{nodeId, name, value}` | 设置属性值 | ### Browser 域 | 方法 | 参数 | 用途 | |------|------|------| | `Browser.getVersion` | `{}` | 获取浏览器版本信息 | *** ## Cookie 操作 ### 简易模式 (cWebView2Cookies) ```vb ' document.cookie 解析（不含 HttpOnly） Dim simple As String simple = wv.Cookies.GetCookies ' CDP Network.getCookies（含 HttpOnly，同步） Dim full As String full = wv.Cookies.GetCookiesFull ``` ### 完整 CDP Cookie 操作 ```vb ' 获取所有 Cookie（含详细信息） Dim cookies As String cookies = wv.CallDevToolsProtocolMethodSync("Network.getAllCookies", "{}") ' 返回格式: {"result":{"cookies":[{name,value,domain,path,httpOnly,secure,...}]}} ' 设置 Cookie wv.CallDevToolsProtocolMethodSync "Network.setCookie", _ "{""name"":""token"",""value"":""abc123"",""domain"":"".example.com"",""httpOnly"":true}" ' 删除 Cookie wv.CallDevToolsProtocolMethodSync "Network.deleteCookies", _ "{""name"":""token"",""domain"":"".example.com""}" ``` *** ## 性能与限制 ### 同步调用超时 CallDevToolsProtocolMethodSync 默认超时为 5 秒。对于耗时的 CDP 操作（如截图），建议使用异步模式。 ### CDP 版本兼容 CDP 方法可用性取决于 WebView2 Runtime 版本。建议使用 `Browser.getVersion` 检查版本： ```vb Dim version As String version = wv.CallDevToolsProtocolMethodSync("Browser.getVersion", "{}") ' 返回包含 product、protocolVersion 等字段 ``` ### 调用频率 CDP 调用比 JS 执行更重，应避免在循环中高频调用。对于批量操作，优先使用单次 JS 执行： ```vb ' 避免：循环中大量 CDP 调用 For i = 0 To 100 wv.CallDevToolsProtocolMethodSync "DOM.setAttributeValue", ... Next ' 推荐：单次 JS 执行 wv.JsRun "document.querySelectorAll('.item').forEach(el => el.classList.add('active'))" ``` *** ## 完整示例 ### 页面截图 ```vb Private Sub Command1_Click() wv.CallDevToolsProtocolMethod "Page.captureScreenshot", _ "{""format"":""png""}", "screenshot" End Sub Private Sub wv_DevToolsProtocolResponse(ByVal CustomEventId As Variant, ByVal JsonResponse As String) If CustomEventId = "screenshot" Then ' JsonResponse 包含 base64 编码的 PNG 数据 ' 解析并保存到文件... Debug.Print "Screenshot received, length: " & Len(JsonResponse) End If End Sub ``` ### 网络请求拦截 ```vb ' 设置额外请求头 wv.CallDevToolsProtocolMethodSync "Network.setExtraHTTPHeaders", _ "{""headers"":{""X-Custom-Header"":""MyValue""}}" ``` ### 修改 DOM 属性 ```vb ' 通过 CDP 修改元素属性 Dim result As String result = wv.CallDevToolsProtocolMethodSync("Runtime.evaluate", _ "{""expression"":""document.getElementById('title').textContent = 'New Title'""}") ``` *** **最后更新**: 2026-06-24 --- --- url: /en/vbman2/webview2/cdp.md --- # CDP Guide - Chrome DevTools Protocol Calling Guide ## 📖 Table of Contents * [Overview](#overview) * [Synchronous Calls](#synchronous-calls) * [Asynchronous Calls](#asynchronous-calls) * [Common CDP Methods](#common-cdp-methods) * [Cookie Operations](#cookie-operations) * [Performance and Limitations](#performance-and-limitations) * [Complete Examples](#complete-examples) *** ## Overview Chrome DevTools Protocol (CDP) is a low-level debugging and control protocol provided by the Chromium browser. cWebView2Host enables VB6 to directly call CDP, achieving deep control over browser behavior that far exceeds the capabilities of the WebView2 public API. ### ✨ Core Features * 🔧 **Sync/Async Dual Mode** - Simple scenarios use synchronous calls for results; complex scenarios use async to avoid blocking * 🍪 **HttpOnly Cookies** - Access HttpOnly cookies that JavaScript cannot read via CDP * 📸 **Screenshot Capture** - Call Page.captureScreenshot for page screenshots * 🔍 **Deep DOM Operations** - Directly manipulate DOM tree without going through the JavaScript layer * 🌐 **Network Control** - Intercept and modify network requests/responses *** ## Synchronous Calls ### CallDevToolsProtocolMethodSync Blocks the current thread until CDP returns the result — the simplest usage: ```vb Public Function CallDevToolsProtocolMethodSync( _ ByVal MethodName As String, _ ByVal ParametersAsJson As String) As String ``` **Returns**: JSON string of CDP response **Internal Mechanism**: Uses Sleep + DoEvents loop for waiting, does not affect VB6 form message loop. **Example**: ```vb Dim wv As New cWebView2Host ' Synchronous calls don't need WithEvents Private Sub Form_Load() wv.Initialize Me.hWnd, "https://vb6.pro" End Sub Private Sub Command1_Click() ' Get page title Dim title As String title = wv.CallDevToolsProtocolMethodSync( _ "Runtime.evaluate", _ "{""expression"":""document.title""}") MsgBox "Title: " & title ' Get all cookies Dim cookies As String cookies = wv.CallDevToolsProtocolMethodSync( _ "Network.getCookies", _ "{}") ' Get browser version Dim version As String version = wv.CallDevToolsProtocolMethodSync( _ "Browser.getVersion", _ "{}") End Sub ``` ### When to Use Synchronous Mode * Simple query operations (getting properties, cookies, etc.) * Need to get results immediately for subsequent logic * Not concerned about UI blocking (or blocking time is very short) *** ## Asynchronous Calls ### CallDevToolsProtocolMethod Initiate CDP call and return immediately; results are returned asynchronously via events: ```vb Public Sub CallDevToolsProtocolMethod( _ ByVal MethodName As String, _ ByVal ParametersAsJson As String, _ ByVal CustomEventId As String) ``` **Parameters**: * `CustomEventId` - Custom event ID for matching responses in the `DevToolsProtocolResponse` event **Example**: ```vb Dim WithEvents wv As cWebView2Host ' Async requires WithEvents Private Sub Command1_Click() ' Initiate multiple async CDP calls wv.CallDevToolsProtocolMethod "Page.captureScreenshot", "{}", "screenshot" wv.CallDevToolsProtocolMethod "DOM.getDocument", "{}", "domDoc" wv.CallDevToolsProtocolMethod "Runtime.evaluate", _ "{""expression"":""document.URL""}", "pageUrl" End Sub Private Sub wv_DevToolsProtocolResponse(ByVal CustomEventId As Variant, ByVal JsonResponse As String) Select Case CustomEventId Case "screenshot" Debug.Print "Screenshot data received" ' JsonResponse contains base64-encoded screenshot data Case "domDoc" Debug.Print "DOM document: " & Left(JsonResponse, 200) Case "pageUrl" Debug.Print "Page URL: " & JsonResponse End Select End Sub ``` ### When to Use Asynchronous Mode * Time-consuming operations (screenshots, extensive DOM operations) * Need to initiate multiple CDP calls simultaneously * Don't want to block the UI thread *** ## Common CDP Methods ### Runtime Domain | Method | Parameters | Purpose | |--------|------------|---------| | `Runtime.evaluate` | `{expression, returnByValue?, awaitPromise?}` | Execute JS expression | | `Runtime.callFunctionOn` | `{functionDeclaration, objectId, arguments, returnByValue}` | Call function on specified object | | `Runtime.getProperties` | `{objectId, ownProperties}` | Get object properties | ### Network Domain | Method | Parameters | Purpose | |--------|------------|---------| | `Network.getCookies` | `{urls?}` | Get cookies (including HttpOnly) | | `Network.getAllCookies` | `{}` | Get all cookies | | `Network.deleteCookies` | `{name, url?, domain?, path?}` | Delete cookies | | `Network.setCookie` | `{name, value, url?, domain?, path?, httpOnly?, secure?}` | Set cookie | | `Network.setExtraHTTPHeaders` | `{headers}` | Set extra HTTP headers | ### Page Domain | Method | Parameters | Purpose | |--------|------------|---------| | `Page.captureScreenshot` | `{format?, quality?, clip?}` | Page screenshot | | `Page.printToPDF` | `{landscape?, paperWidth?, ...}` | Print to PDF | | `Page.navigate` | `{url, referrer?}` | Navigate | | `Page.reload` | `{ignoreCache?}` | Reload | ### DOM Domain | Method | Parameters | Purpose | |--------|------------|---------| | `DOM.getDocument` | `{depth?}` | Get document root node | | `DOM.querySelector` | `{nodeId, selector}` | CSS selector query | | `DOM.getOuterHTML` | `{nodeId}` | Get element HTML | | `DOM.setAttributeValue` | `{nodeId, name, value}` | Set attribute value | ### Browser Domain | Method | Parameters | Purpose | |--------|------------|---------| | `Browser.getVersion` | `{}` | Get browser version info | *** ## Cookie Operations ### Simple Mode (cWebView2Cookies) ```vb ' document.cookie parsing (excluding HttpOnly) Dim simple As String simple = wv.Cookies.GetCookies ' CDP Network.getCookies (including HttpOnly, synchronous) Dim full As String full = wv.Cookies.GetCookiesFull ``` ### Full CDP Cookie Operations ```vb ' Get all cookies (with detailed info) Dim cookies As String cookies = wv.CallDevToolsProtocolMethodSync("Network.getAllCookies", "{}") ' Return format: {"result":{"cookies":[{name,value,domain,path,httpOnly,secure,...}]}} ' Set cookie wv.CallDevToolsProtocolMethodSync "Network.setCookie", _ "{""name"":""token"",""value"":""abc123"",""domain"":"".example.com"",""httpOnly"":true}" ' Delete cookie wv.CallDevToolsProtocolMethodSync "Network.deleteCookies", _ "{""name"":""token"",""domain"":"".example.com""}" ``` *** ## Performance and Limitations ### Synchronous Call Timeout CallDevToolsProtocolMethodSync has a default timeout of 5 seconds. For time-consuming CDP operations (e.g., screenshots), use asynchronous mode. ### CDP Version Compatibility CDP method availability depends on the WebView2 Runtime version. Use `Browser.getVersion` to check the version: ```vb Dim version As String version = wv.CallDevToolsProtocolMethodSync("Browser.getVersion", "{}") ' Returns fields including product, protocolVersion, etc. ``` ### Call Frequency CDP calls are heavier than JS execution — avoid high-frequency calls in loops. For batch operations, prefer single JS execution: ```vb ' Avoid: Many CDP calls in a loop For i = 0 To 100 wv.CallDevToolsProtocolMethodSync "DOM.setAttributeValue", ... Next ' Recommended: Single JS execution wv.JsRun "document.querySelectorAll('.item').forEach(el => el.classList.add('active'))" ``` *** ## Complete Examples ### Page Screenshot ```vb Private Sub Command1_Click() wv.CallDevToolsProtocolMethod "Page.captureScreenshot", _ "{""format"":""png""}", "screenshot" End Sub Private Sub wv_DevToolsProtocolResponse(ByVal CustomEventId As Variant, ByVal JsonResponse As String) If CustomEventId = "screenshot" Then ' JsonResponse contains base64-encoded PNG data ' Parse and save to file... Debug.Print "Screenshot received, length: " & Len(JsonResponse) End If End Sub ``` ### Network Request Interception ```vb ' Set extra request headers wv.CallDevToolsProtocolMethodSync "Network.setExtraHTTPHeaders", _ "{""headers"":{""X-Custom-Header"":""MyValue""}}" ``` ### Modifying DOM Attributes ```vb ' Modify element attribute via CDP Dim result As String result = wv.CallDevToolsProtocolMethodSync("Runtime.evaluate", _ "{""expression"":""document.getElementById('title').textContent = 'New Title'""}") ``` *** **Last Updated**: 2026-06-24 --- --- url: /en/vbman/tls/certfile.md --- # Certificate File Mode (TlsCertFile) ## Overview Certificate file mode is the most commonly used and simplest TLS configuration method. Pass the certificate file path and password to the `TlsCertFile()` chained function, and the underlying layer automatically parses the file format and loads the certificate. ## Function Signature ```vb Public Function TlsCertFile( _ ByVal CertFile As String, _ Optional ByVal Password As String, _ Optional ByVal AlpnProtocols As String = "...") As ``` ### Parameters | Parameter | Type | Required | Description | |-----------|------|----------|-------------| | `CertFile` | String | Yes | Certificate file path, supports PFX/P12 and PEM formats | | `Password` | String | No | Certificate password. Leave empty for PEM with unencrypted private key | | `AlpnProtocols` | String | No | ALPN protocol negotiation. Default values vary by component, see table below | | Component | AlpnProtocols Default | |-----------|----------------------| | cHttpServer | `"http/1.1"` | | cWinsock | `"http/1.1"` | | cWebSocketServer | `""` (Empty) | ## Supported File Formats ### 1. PFX / P12 (PKCS#12) Binary format, single file containing certificate chain and private key, most convenient for management. ```vb Server.TlsCertFile("C:\certs\server.pfx", "my-password").Start 443 ``` **Characteristics:** * Single file contains complete certificate chain + private key * Supports password protection * Windows certificate export standard format * Default format for IIS certificate export **Acquisition Methods:** * Download from CA authority * OpenSSL generation: `openssl req -x509 -newkey rsa:2048 -keyout key.pem -out cert.pem -days 365 -nodes` * OpenSSL to PFX: `openssl pkcs12 -export -out server.pfx -inkey key.pem -in cert.pem` * Windows Certificate Manager export (with private key) ### 2. PEM Format — Single File Text format, file contains both certificate and private key. ```vb Server.TlsCertFile("C:\certs\server.pem").Start 443 ``` **File Content Example:** ``` -----BEGIN CERTIFICATE----- MIIFazCCBFOgAwIBAgISA2Q3p... (Server certificate) -----END CERTIFICATE----- -----BEGIN CERTIFICATE----- MIIFazCCBFOgAwIBAgISA3B4q... (Intermediate certificate) -----END CERTIFICATE----- -----BEGIN PRIVATE KEY----- MIIEvgIBADANBgkqhkiG9w0BAQ... (Private key) -----END PRIVATE KEY----- ``` ### 3. PEM Format — Multiple Files (Use `|` separator) Most flexible method, certificate and private key stored in separate files. Use `|` pipe character to separate multiple file paths. ```vb ' Let's Encrypt standard output format Server.TlsCertFile("C:\certs\fullchain.pem|C:\certs\privkey.pem").Start 443 ' Three files: certificate + intermediate + private key Server.TlsCertFile("C:\certs\cert.pem|C:\certs\chain.pem|C:\certs\privkey.pem").Start 443 ``` **Underlying Processing:** 1. First attempts PKCS#12 parsing (for single files) 2. On failure, splits `CertFile` by `|` into array 3. Calls PEM parsing for each file path 4. Automatically identifies PEM block types (CERTIFICATE / PRIVATE KEY / RSA PRIVATE KEY / EC PRIVATE KEY) ## Usage Examples by Component ### cHttpServer (HTTPS) ```vb ' PEM multiple files (Let's Encrypt most common) Server.TlsCertFile("C:\certs\fullchain.pem|C:\certs\privkey.pem").Start 443 ' PFX with password + WebRoot Server.TlsCertFile("C:\certs\server.pfx", "password").WebRoot("C:\www").Start 443 ' PEM single file Server.TlsCertFile("C:\certs\server.pem").Start 443 ' HTTP + HTTPS dual ports Dim httpSvr As New cHttpServer httpSvr.WebRoot("C:\www").Start 80 Dim httpsSvr As New cHttpServer httpsSvr.TlsCertFile("C:\certs\server.pfx", "pwd").WebRoot("C:\www").Start 443 ``` ### cWinsock (TLS TCP) ```vb ' Server: Present certificate Dim svr As New cWinsock svr.TlsCertFile("C:\certs\server.pfx", "password").Listen 443 ' Client: Just enable TLS (no certificate needed) Dim cli As New cWinsock cli.Tls.Connect "example.com", 443 ``` ### cWebSocketServer (wss://) ```vb ' PFX certificate Dim wsSvr As New cWebSocketServer wsSvr.TlsCertFile("C:\certs\server.pfx", "password").Listen 443 ' PEM multiple files wsSvr.TlsCertFile("C:\certs\fullchain.pem|C:\certs\privkey.pem").Listen 443 ``` ## Let's Encrypt Automation Let's Encrypt is the most common free certificate source, and its output files perfectly match the PEM multi-file mode: ``` /etc/letsencrypt/live/example.com/ ├── fullchain.pem ← Server certificate + Intermediate certificate ├── privkey.pem ← Private key ├── cert.pem ← Server certificate only └── chain.pem ← Intermediate certificate only ``` ```vb ' Using fullchain + privkey (recommended) Server.TlsCertFile("/etc/letsencrypt/live/example.com/fullchain.pem|" & _ "/etc/letsencrypt/live/example.com/privkey.pem").Start 443 ``` **Note:** On Windows use backslash `C:\certs\fullchain.pem|C:\certs\privkey.pem`. ## Self-Signed Certificates (Development/Testing) Use OpenSSL to generate self-signed certificates: ```bash # Generate private key and certificate (valid for 365 days) openssl req -x509 -newkey rsa:2048 -keyout key.pem -out cert.pem -days 365 -nodes -subj "/CN=localhost" # Merge into single PEM file type cert.pem key.pem > server.pem # Or convert to PFX openssl pkcs12 -export -out server.pfx -inkey key.pem -in cert.pem ``` ```vb ' Use self-signed PEM Server.TlsCertFile("C:\dev\server.pem").Start 443 ' Use self-signed PFX Server.TlsCertFile("C:\dev\server.pfx").Start 443 ``` ## Certificate Chain Completeness PEM format must contain complete certificate chain, otherwise clients will report untrusted certificate: ``` ✅ Correct: fullchain.pem = Server certificate + Intermediate certificate ❌ Incorrect: cert.pem = Server certificate only (missing intermediate) ``` Common CA intermediate certificates: * Let's Encrypt: ISRG Root X1 → R3/R4/R10 etc. * DigiCert: DigiCert Global Root CA → Intermediate CA * GlobalSign: GlobalSign Root CA → Intermediate CA ## FAQ ### 1. File path not found ``` LastError: Certificate file does not exist or format error ``` **Solution:** Check if file path is correct, note Windows paths use backslashes. ### 2. Password error ``` LastError: Certificate file does not exist or format error ``` **Solution:** PFX passwords are case-sensitive, confirm password is correct. Leave Password empty for unencrypted PEM private keys. ### 3. PEM missing private key ``` LastError: Certificate file does not exist or format error ``` **Solution:** Ensure PEM file or file combination contains `-----BEGIN PRIVATE KEY-----` or `-----BEGIN RSA PRIVATE KEY-----` block. ### 4. Certificate expired ``` Browser shows: Your connection is not private ``` **Solution:** Update certificate. Let's Encrypt certificates are valid for 90 days, automatic renewal needs to be configured. ## Underlying Processing Flow ``` TlsCertFile(path, pwd) │ ├─ Attempt PKCS#12 parsing (for single files) │ └─ pvPkiPkcs12ImportCertificates() │ └─ OpenSSL d2i_PKCS12 + PKCS12_parse │ └─ Attempt PEM parsing (Split by "|") └─ pvPkiPemImportCertificates() └─ OpenSSL PEM_read_bio_X509 + PEM_read_bio_PrivateKey ``` ## Related Documentation * [TLS Certificate Configuration Overview](./overview.md) * [Windows Certificate Store Mode](./certsubject.md) * [Memory Certificate Collection Mode](./certmemory.md) * [cHttpServer TLS Support](../httpserver/tls.md) * [cWinsock TLS Support](../winsock/tls.md) * [cWebSocket TLS Support](../websocket/tls.md) *** **Last Updated**: 2026-06-09 --- --- url: /zh/vbman/tools/fso/cFileEx.md --- # cFileEx 类 基于 VB 原生 Open 语句的高级文件操作类，兼容性好，接口与 cFileIO 保持一致。 ## 说明 `cFileEx` 使用 VB 原生 `Open` 语句实现文件操作，相比 `cFileIO` 具有以下特点： * 更好的兼容性（不依赖 Win32 API） * 额外的数据格式支持（Base64、Hex、Binary） * 接口与 `cFileIO` 保持一致，方便互换使用 **特点：** * 一个实例同一时间只能操作一个文件 * 读取内容先进入内部缓冲区，再通过 `ReturnXXX` 方法提取 * 支持 UTF-8、ANSI、UTF-16LE 编码 * 支持 Base64、Hex、Binary 字符串格式 *** ## 属性 | 属性名 | 类型 | 说明 | |--------|------|------| | `IsOpen` | `Boolean` | 文件是否已打开（只读） | | `FilePath` | `String` | 当前打开的文件路径（只读） | | `LastError` | `String` | 最后一次错误信息（只读） | | `FileSize` | `Currency` | 文件大小（字节） | | `BufferSize` | `Long` | 当前缓冲区字节数 | *** ## 方法 ### OpenFile 打开文件，返回 Me 支持链式调用。 **语法：** ```vb Public Function OpenFile(ByVal FilePath As String, Optional ByVal AccessMode As String = "RW") As cFileEx ``` **参数：** | 参数 | 类型 | 说明 | |------|------|------| | `FilePath` | `String` | 要打开的文件路径 | | `AccessMode` | `String` | 可选。访问模式：`R`=只读, `W`=只写, `RW`=读写(默认) | **返回值：** * 返回自身实例，支持链式调用 **说明：** * `R` 模式：文件必须存在 * `W` 模式：创建或覆盖文件 * `RW` 模式：文件不存在则创建 **示例：** ```vb Dim File As New cFileEx ' 只读模式打开 File.OpenFile "C:\\data\\file.txt", "R" ' 读写模式打开（链式调用） Dim Content As String Content = File.OpenFile("C:\\data\\file.txt", "RW").ReadData().ReturnText() ``` *** ### CloseFile 关闭当前打开的文件。 **语法：** ```vb Public Sub CloseFile() ``` **示例：** ```vb File.CloseFile ``` *** ### ClearBuffer 清空内部缓冲区。 **语法：** ```vb Public Function ClearBuffer() As cFileEx ``` **返回值：** * 返回自身实例，支持链式调用 **示例：** ```vb File.ClearBuffer() ``` *** ### SetBuffer 用外部字节数组填充缓冲区。 **语法：** ```vb Public Function SetBuffer(Data() As Byte) As cFileEx ``` **参数：** | 参数 | 类型 | 说明 | |------|------|------| | `Data` | `Byte()` | 要设置的字节数组 | **返回值：** * 返回自身实例，支持链式调用 **示例：** ```vb Dim Bytes() As Byte Bytes = StrConv("Hello", vbFromUnicode) File.SetBuffer Bytes ``` *** ### AppendBuffer 追加字节到缓冲区。 **语法：** ```vb Public Function AppendBuffer(Data() As Byte) As cFileEx ``` **参数：** | 参数 | 类型 | 说明 | |------|------|------| | `Data` | `Byte()` | 要追加的字节数组 | **返回值：** * 返回自身实例，支持链式调用 **示例：** ```vb Dim Part1() As Byte, Part2() As Byte Part1 = StrConv("Hello ", vbFromUnicode) Part2 = StrConv("World", vbFromUnicode) File.SetBuffer(Part1).AppendBuffer(Part2) ``` *** ### SetBufferText 用字符串填充缓冲区（默认 UTF-8 编码）。 **语法：** ```vb Public Function SetBufferText(ByVal Text As String, Optional ByVal CharSet As String = "UTF-8") As cFileEx ``` **参数：** | 参数 | 类型 | 说明 | |------|------|------| | `Text` | `String` | 要设置的文本 | | `CharSet` | `String` | 可选。编码：`UTF-8`(默认)、`ANSI`、`UTF-16LE` | **返回值：** * 返回自身实例，支持链式调用 **示例：** ```vb File.SetBufferText "Hello World 你好世界" File.SetBufferText "Hello World", "ANSI" ``` *** ### SetBufferBase64 用 Base64 字符串填充缓冲区。 **语法：** ```vb Public Function SetBufferBase64(ByVal Base64String As String) As cFileEx ``` **参数：** | 参数 | 类型 | 说明 | |------|------|------| | `Base64String` | `String` | Base64 编码的字符串 | **返回值：** * 返回自身实例，支持链式调用 **示例：** ```vb Dim Base64 As String Base64 = "SGVsbG8gV29ybGQ=" File.SetBufferBase64 Base64 ``` *** ### SetBufferHex 用 Hex 字符串填充缓冲区。 **语法：** ```vb Public Function SetBufferHex(ByVal HexString As String, Optional ByVal Separator As String = " ") As cFileEx ``` **参数：** | 参数 | 类型 | 说明 | |------|------|------| | `HexString` | `String` | Hex 编码的字符串 | | `Separator` | `String` | 可选。分隔符，默认为空格 | **返回值：** * 返回自身实例，支持链式调用 **说明：** * 自动移除分隔符和空白字符 * 支持空格、制表符、换行等作为分隔符 **示例：** ```vb ' 空格分隔 File.SetBufferHex "48 65 6C 6C 6F" ' 无分隔符 File.SetBufferHex "48656C6C6F", "" ' 自定义分隔符 File.SetBufferHex "48-65-6C-6C-6F", "-" ``` *** ### SetBufferBinString 用二进制字符串填充缓冲区。 **语法：** ```vb Public Function SetBufferBinString(ByVal BinString As String, Optional ByVal Separator As String = " ") As cFileEx ``` **参数：** | 参数 | 类型 | 说明 | |------|------|------| | `BinString` | `String` | 二进制字符串（如 "01001000"） | | `Separator` | `String` | 可选。分隔符，默认为空格 | **返回值：** * 返回自身实例，支持链式调用 **说明：** * 每组 8 位二进制表示一个字节 * 长度不足 8 的倍数时自动前面补 0 **示例：** ```vb ' 空格分隔 File.SetBufferBinString "01001000 01100101 01101100 01101100 01101111" ' 无分隔符 File.SetBufferBinString "0100100001100101", "" ``` *** ### ReadData 将文件指定范围读入内部缓冲区。 **语法：** ```vb Public Function ReadData(Optional ByVal StartPos As Long = -1, Optional ByVal EndPos As Long = -1) As cFileEx ``` **参数：** | 参数 | 类型 | 说明 | |------|------|------| | `StartPos` | `Long` | 可选。起始位置（1-based，-1 表示从开头） | | `EndPos` | `Long` | 可选。结束位置（1-based，-1 表示到末尾） | **返回值：** * 返回自身实例，支持链式调用 **说明：** * 位置参数为 1-based 字节位置（与 cFileIO 不同） **示例：** ```vb ' 读取整个文件 File.OpenFile("C:\\data\\file.txt", "R").ReadData() ' 读取第 1-1000 字节 File.ReadData(1, 1000) ' 从第 1001 字节读到末尾 File.ReadData(1001, -1) ``` *** ### ReturnText 从缓冲区返回文本。 **语法：** ```vb Public Function ReturnText(Optional ByVal CharSet As String = "UTF-8") As String ``` **参数：** | 参数 | 类型 | 说明 | |------|------|------| | `CharSet` | `String` | 可选。编码：`UTF-8`(默认)、`ANSI`、`UTF-16LE` | **返回值：** * 字符串内容 **示例：** ```vb Dim Content As String Content = File.OpenFile("C:\\data\\file.txt", "R") _ .ReadData() _ .ReturnText("UTF-8") ``` *** ### ReturnBytes 从缓冲区返回字节数组（副本）。 **语法：** ```vb Public Function ReturnBytes() As Byte() ``` **返回值：** * 字节数组 **示例：** ```vb Dim Bytes() As Byte Bytes = File.ReadData().ReturnBytes() ``` *** ### ReturnBase64 从缓冲区返回 Base64 编码字符串。 **语法：** ```vb Public Function ReturnBase64() As String ``` **返回值：** * Base64 编码字符串 **示例：** ```vb Dim Base64 As String Base64 = File.OpenFile("C:\\data\\image.png", "R").ReadData().ReturnBase64() ``` *** ### ReturnHex 从缓冲区返回 Hex 编码字符串。 **语法：** ```vb Public Function ReturnHex(Optional ByVal Separator As String = " ") As String ``` **参数：** | 参数 | 类型 | 说明 | |------|------|------| | `Separator` | `String` | 可选。分隔符，默认为空格 | **返回值：** * Hex 编码字符串 **示例：** ```vb Dim HexStr As String HexStr = File.ReadData().ReturnHex(" ") ' 输出: 48 65 6C 6C 6F HexStr = File.ReadData().ReturnHex("") ' 输出: 48656C6C6F ``` *** ### ReturnBinString 从缓冲区返回二进制字符串。 **语法：** ```vb Public Function ReturnBinString(Optional ByVal Separator As String = " ") As String ``` **参数：** | 参数 | 类型 | 说明 | |------|------|------| | `Separator` | `String` | 可选。分隔符，默认为空格 | **返回值：** * 二进制字符串（每组 8 位） **示例：** ```vb Dim BinStr As String BinStr = File.ReadData().ReturnBinString(" ") ' 输出: 01001000 01100101 01101100 01101100 01101111 ``` *** ### SaveData 将内部缓冲区写入文件。 **语法：** ```vb Public Function SaveData(Optional ByVal FilePath As String, Optional ByVal IsAppend As Boolean = False) As cFileEx ``` **参数：** | 参数 | 类型 | 说明 | |------|------|------| | `FilePath` | `String` | 可选。目标路径，未提供则使用 OpenFile 时的路径 | | `IsAppend` | `Boolean` | 可选。`False`=覆盖(默认), `True`=追加到文件末尾 | **返回值：** * 返回自身实例，支持链式调用 **示例：** ```vb ' 覆盖写入 File.SetBufferText("Hello").SaveData("C:\\data\\output.txt") ' 追加写入 File.SetBufferText("\nNew line").SaveData("C:\\data\\log.txt", True) ``` *** ## 使用示例 ### 示例 1：基本文件读写 ```vb Sub BasicFileExample() Dim File As New cFileEx ' 写入文件 File.SetBufferText("Hello World 你好世界", "UTF-8") _ .SaveData("C:\\data\\test.txt") ' 读取文件 Dim Content As String Content = File.OpenFile("C:\\data\\test.txt", "R") _ .ReadData() _ .ReturnText("UTF-8") Debug.Print Content File.CloseFile End Sub ``` ### 示例 2：Hex 数据处理 ```vb Sub HexDataExample() Dim File As New cFileEx ' 从 Hex 字符串创建数据 File.SetBufferHex("48 65 6C 6C 6F 20 57 6F 72 6C 64") ' 以不同格式返回 Debug.Print "文本: " & File.ReturnText() ' Hello World Debug.Print "Base64: " & File.ReturnBase64() ' SGVsbG8gV29ybGQ= Debug.Print "Hex(无分隔): " & File.ReturnHex("") ' 48656C6C6F20576F726C64 Debug.Print "二进制: " & File.ReturnBinString(" ") ' 01001000 01100101 ... End Sub ``` ### 示例 3：二进制数据处理 ```vb Sub BinaryDataExample() Dim File As New cFileEx ' 从二进制字符串创建数据 File.SetBufferBinString("01000001 01000010 01000011") ' ABC ' 保存为文件 File.SaveData "C:\\data\\binary.bin" ' 读取并显示为 Hex File.OpenFile("C:\\data\\binary.bin", "R").ReadData() Debug.Print File.ReturnHex() ' 41 42 43 End Sub ``` ### 示例 4：Base64 编解码 ```vb Sub Base64Example() Dim File As New cFileEx ' 读取文件并转为 Base64 File.OpenFile("C:\\data\\image.png", "R").ReadData() Dim Base64 As String Base64 = File.ReturnBase64() ' 从 Base64 恢复 File.SetBufferBase64(Base64).SaveData "C:\\data\\image_copy.png" Debug.Print "Base64 编解码完成" End Sub ``` ### 示例 5：数据格式转换 ```vb Sub FormatConversionExample() Dim File As New cFileEx ' 原始文本 Dim Text As String Text = "Hello" ' 文本 -> Hex File.SetBufferText(Text) Debug.Print "Hex: " & File.ReturnHex(" ") ' 48 65 6C 6C 6F ' Hex -> 文本 File.SetBufferHex("48 65 6C 6C 6F") Debug.Print "文本: " & File.ReturnText() ' Hello ' 文本 -> Base64 File.SetBufferText(Text) Debug.Print "Base64: " & File.ReturnBase64() ' SGVsbG8= ' Base64 -> 文本 File.SetBufferBase64("SGVsbG8=") Debug.Print "文本: " & File.ReturnText() ' Hello End Sub ``` *** ## cFileIO 与 cFileEx 对比 | 特性 | cFileIO | cFileEx | |------|---------|---------| | 实现方式 | Win32 API | VB Open 语句 | | 大文件支持 | 是（>2GB） | 否（VB 限制） | | 兼容性 | 需要 Windows | 更好的跨平台兼容 | | Base64 支持 | 是 | 是 | | Hex 支持 | 否 | 是 | | Binary 支持 | 否 | 是 | | 读取位置 | 0-based | 1-based | **选择建议：** * 需要处理大文件（>2GB）→ 使用 `cFileIO` * 需要 Hex/Binary 格式支持 → 使用 `cFileEx` * 一般文件操作 → 两者均可 --- --- url: /en/vbman/tools/fso/cFileEx.md --- # cFileEx Class Advanced file operations class based on VB native Open statement, with good compatibility and interface consistent with cFileIO. ## Description `cFileEx` uses VB native `Open` statement for file operations, with the following characteristics compared to `cFileIO`: * Better compatibility (does not depend on Win32 API) * Additional data format support (Base64, Hex, Binary) * Interface consistent with `cFileIO`, convenient for interchangeable use **Features:** * One instance can only operate on one file at a time * Read content first enters internal buffer, then extracted via `ReturnXXX` methods * Supports UTF-8, ANSI, UTF-16LE encodings * Supports Base64, Hex, Binary string formats *** ## Properties | Property Name | Type | Description | |---------------|------|-------------| | `IsOpen` | `Boolean` | Whether file is open (read-only) | | `FilePath` | `String` | Currently opened file path (read-only) | | `LastError` | `String` | Last error message (read-only) | | `FileSize` | `Currency` | File size (bytes) | | `BufferSize` | `Long` | Current buffer byte count | *** ## Methods ### OpenFile Opens a file, returns Me to support method chaining. **Syntax:** ```vb Public Function OpenFile(ByVal FilePath As String, Optional ByVal AccessMode As String = "RW") As cFileEx ``` **Parameters:** | Parameter | Type | Description | |-----------|------|-------------| | `FilePath` | `String` | File path to open | | `AccessMode` | `String` | Optional. Access mode: `R`=read-only, `W`=write-only, `RW`=read-write (default) | **Returns:** * Returns self instance, supports method chaining **Description:** * `R` mode: file must exist * `W` mode: creates or overwrites file * `RW` mode: creates file if it doesn't exist **Example:** ```vb Dim File As New cFileEx ' Open in read-only mode File.OpenFile "C:\\data\\file.txt", "R" ' Open in read-write mode (method chaining) Dim Content As String Content = File.OpenFile("C:\\data\\file.txt", "RW").ReadData().ReturnText() ``` *** ### CloseFile Closes the currently opened file. **Syntax:** ```vb Public Sub CloseFile() ``` **Example:** ```vb File.CloseFile ``` *** ### ClearBuffer Clears the internal buffer. **Syntax:** ```vb Public Function ClearBuffer() As cFileEx ``` **Returns:** * Returns self instance, supports method chaining **Example:** ```vb File.ClearBuffer() ``` *** ### SetBuffer Fills the buffer with external byte array. **Syntax:** ```vb Public Function SetBuffer(Data() As Byte) As cFileEx ``` **Parameters:** | Parameter | Type | Description | |-----------|------|-------------| | `Data` | `Byte()` | Byte array to set | **Returns:** * Returns self instance, supports method chaining **Example:** ```vb Dim Bytes() As Byte Bytes = StrConv("Hello", vbFromUnicode) File.SetBuffer Bytes ``` *** ### AppendBuffer Appends bytes to the buffer. **Syntax:** ```vb Public Function AppendBuffer(Data() As Byte) As cFileEx ``` **Parameters:** | Parameter | Type | Description | |-----------|------|-------------| | `Data` | `Byte()` | Byte array to append | **Returns:** * Returns self instance, supports method chaining **Example:** ```vb Dim Part1() As Byte, Part2() As Byte Part1 = StrConv("Hello ", vbFromUnicode) Part2 = StrConv("World", vbFromUnicode) File.SetBuffer(Part1).AppendBuffer(Part2) ``` *** ### SetBufferText Fills the buffer with string (default UTF-8 encoding). **Syntax:** ```vb Public Function SetBufferText(ByVal Text As String, Optional ByVal CharSet As String = "UTF-8") As cFileEx ``` **Parameters:** | Parameter | Type | Description | |-----------|------|-------------| | `Text` | `String` | Text to set | | `CharSet` | `String` | Optional. Encoding: `UTF-8`(default), `ANSI`, `UTF-16LE` | **Returns:** * Returns self instance, supports method chaining **Example:** ```vb File.SetBufferText "Hello World 你好世界" File.SetBufferText "Hello World", "ANSI" ``` *** ### SetBufferBase64 Fills the buffer with Base64 string. **Syntax:** ```vb Public Function SetBufferBase64(ByVal Base64String As String) As cFileEx ``` **Parameters:** | Parameter | Type | Description | |-----------|------|-------------| | `Base64String` | `String` | Base64-encoded string | **Returns:** * Returns self instance, supports method chaining **Example:** ```vb Dim Base64 As String Base64 = "SGVsbG8gV29ybGQ=" File.SetBufferBase64 Base64 ``` *** ### SetBufferHex Fills the buffer with Hex string. **Syntax:** ```vb Public Function SetBufferHex(ByVal HexString As String, Optional ByVal Separator As String = " ") As cFileEx ``` **Parameters:** | Parameter | Type | Description | |-----------|------|-------------| | `HexString` | `String` | Hex-encoded string | | `Separator` | `String` | Optional. Separator, default is space | **Returns:** * Returns self instance, supports method chaining **Description:** * Automatically removes separators and whitespace * Supports spaces, tabs, newlines as separators **Example:** ```vb ' Space separated File.SetBufferHex "48 65 6C 6C 6F" ' Without separator File.SetBufferHex "48656C6C6F", "" ' Custom separator File.SetBufferHex "48-65-6C-6C-6F", "-" ``` *** ### SetBufferBinString Fills the buffer with binary string. **Syntax:** ```vb Public Function SetBufferBinString(ByVal BinString As String, Optional ByVal Separator As String = " ") As cFileEx ``` **Parameters:** | Parameter | Type | Description | |-----------|------|-------------| | `BinString` | `String` | Binary string (e.g., "01001000") | | `Separator` | `String` | Optional. Separator, default is space | **Returns:** * Returns self instance, supports method chaining **Description:** * Each group of 8 bits represents one byte * Pads with leading zeros if length is not a multiple of 8 **Example:** ```vb ' Space separated File.SetBufferBinString "01001000 01100101 01101100 01101100 01101111" ' Without separator File.SetBufferBinString "0100100001100101", "" ``` *** ### ReadData Reads specified range of file into internal buffer. **Syntax:** ```vb Public Function ReadData(Optional ByVal StartPos As Long = -1, Optional ByVal EndPos As Long = -1) As cFileEx ``` **Parameters:** | Parameter | Type | Description | |-----------|------|-------------| | `StartPos` | `Long` | Optional. Start position (1-based, -1 means from beginning) | | `EndPos` | `Long` | Optional. End position (1-based, -1 means to end) | **Returns:** * Returns self instance, supports method chaining **Description:** * Position parameters are 1-based byte positions (different from cFileIO) **Example:** ```vb ' Read entire file File.OpenFile("C:\\data\\file.txt", "R").ReadData() ' Read bytes 1-1000 File.ReadData(1, 1000) ' Read from byte 1001 to end File.ReadData(1001, -1) ``` *** ### ReturnText Returns text from buffer. **Syntax:** ```vb Public Function ReturnText(Optional ByVal CharSet As String = "UTF-8") As String ``` **Parameters:** | Parameter | Type | Description | |-----------|------|-------------| | `CharSet` | `String` | Optional. Encoding: `UTF-8`(default), `ANSI`, `UTF-16LE` | **Returns:** * String content **Example:** ```vb Dim Content As String Content = File.OpenFile("C:\\data\\file.txt", "R") _ .ReadData() _ .ReturnText("UTF-8") ``` *** ### ReturnBytes Returns byte array from buffer (copy). **Syntax:** ```vb Public Function ReturnBytes() As Byte() ``` **Returns:** * Byte array **Example:** ```vb Dim Bytes() As Byte Bytes = File.ReadData().ReturnBytes() ``` *** ### ReturnBase64 Returns Base64-encoded string from buffer. **Syntax:** ```vb Public Function ReturnBase64() As String ``` **Returns:** * Base64-encoded string **Example:** ```vb Dim Base64 As String Base64 = File.OpenFile("C:\\data\\image.png", "R").ReadData().ReturnBase64() ``` *** ### ReturnHex Returns Hex-encoded string from buffer. **Syntax:** ```vb Public Function ReturnHex(Optional ByVal Separator As String = " ") As String ``` **Parameters:** | Parameter | Type | Description | |-----------|------|-------------| | `Separator` | `String` | Optional. Separator, default is space | **Returns:** * Hex-encoded string **Example:** ```vb Dim HexStr As String HexStr = File.ReadData().ReturnHex(" ") ' Output: 48 65 6C 6C 6F HexStr = File.ReadData().ReturnHex("") ' Output: 48656C6C6F ``` *** ### ReturnBinString Returns binary string from buffer. **Syntax:** ```vb Public Function ReturnBinString(Optional ByVal Separator As String = " ") As String ``` **Parameters:** | Parameter | Type | Description | |-----------|------|-------------| | `Separator` | `String` | Optional. Separator, default is space | **Returns:** * Binary string (8 bits per group) **Example:** ```vb Dim BinStr As String BinStr = File.ReadData().ReturnBinString(" ") ' Output: 01001000 01100101 01101100 01101100 01101111 ``` *** ### SaveData Writes internal buffer to file. **Syntax:** ```vb Public Function SaveData(Optional ByVal FilePath As String, Optional ByVal IsAppend As Boolean = False) As cFileEx ``` **Parameters:** | Parameter | Type | Description | |-----------|------|-------------| | `FilePath` | `String` | Optional. Target path, uses path from OpenFile if not provided | | `IsAppend` | `Boolean` | Optional. `False`=overwrite (default), `True`=append to end of file | **Returns:** * Returns self instance, supports method chaining **Example:** ```vb ' Overwrite File.SetBufferText("Hello").SaveData("C:\\data\\output.txt") ' Append File.SetBufferText("\nNew line").SaveData("C:\\data\\log.txt", True) ``` *** ## Usage Examples ### Example 1: Basic File Read/Write ```vb Sub BasicFileExample() Dim File As New cFileEx ' Write file File.SetBufferText("Hello World 你好世界", "UTF-8") _ .SaveData("C:\\data\\test.txt") ' Read file Dim Content As String Content = File.OpenFile("C:\\data\\test.txt", "R") _ .ReadData() _ .ReturnText("UTF-8") Debug.Print Content File.CloseFile End Sub ``` ### Example 2: Hex Data Processing ```vb Sub HexDataExample() Dim File As New cFileEx ' Create data from Hex string File.SetBufferHex("48 65 6C 6C 6F 20 57 6F 72 6C 64") ' Return in different formats Debug.Print "Text: " & File.ReturnText() ' Hello World Debug.Print "Base64: " & File.ReturnBase64() ' SGVsbG8gV29ybGQ= Debug.Print "Hex(no sep): " & File.ReturnHex("") ' 48656C6C6F20576F726C64 Debug.Print "Binary: " & File.ReturnBinString(" ") ' 01001000 01100101 ... End Sub ``` ### Example 3: Binary Data Processing ```vb Sub BinaryDataExample() Dim File As New cFileEx ' Create data from binary string File.SetBufferBinString "01000001 01000010 01000011" ' ABC ' Save as file File.SaveData "C:\\data\\binary.bin" ' Read and display as Hex File.OpenFile("C:\\data\\binary.bin", "R").ReadData() Debug.Print File.ReturnHex() ' 41 42 43 End Sub ``` ### Example 4: Base64 Encoding/Decoding ```vb Sub Base64Example() Dim File As New cFileEx ' Read file and convert to Base64 File.OpenFile("C:\\data\\image.png", "R").ReadData() Dim Base64 As String Base64 = File.ReturnBase64() ' Restore from Base64 File.SetBufferBase64(Base64).SaveData "C:\\data\\image_copy.png" Debug.Print "Base64 encoding/decoding completed" End Sub ``` ### Example 5: Data Format Conversion ```vb Sub FormatConversionExample() Dim File As New cFileEx ' Original text Dim Text As String Text = "Hello" ' Text -> Hex File.SetBufferText(Text) Debug.Print "Hex: " & File.ReturnHex(" ") ' 48 65 6C 6C 6F ' Hex -> Text File.SetBufferHex("48 65 6C 6C 6F") Debug.Print "Text: " & File.ReturnText() ' Hello ' Text -> Base64 File.SetBufferText(Text) Debug.Print "Base64: " & File.ReturnBase64() ' SGVsbG8= ' Base64 -> Text File.SetBufferBase64("SGVsbG8=") Debug.Print "Text: " & File.ReturnText() ' Hello End Sub ``` *** ## cFileIO vs cFileEx Comparison | Feature | cFileIO | cFileEx | |---------|---------|---------| | Implementation | Win32 API | VB Open statement | | Large file support | Yes (>2GB) | No (VB limitation) | | Compatibility | Requires Windows | Better cross-platform compatibility | | Base64 support | Yes | Yes | | Hex support | No | Yes | | Binary support | No | Yes | | Read position | 0-based | 1-based | **Selection Guide:** * Need to handle large files (>2GB) → Use `cFileIO` * Need Hex/Binary format support → Use `cFileEx` * General file operations → Either works --- --- url: /zh/vbman/tools/fso/cFileIO.md --- # cFileIO 类 基于 Win32 API 的高级文件操作类，支持大文件（>2GB）和流式读写。 ## 说明 `cFileIO` 使用 `CreateFile` API 实现文件操作，相比 VB 原生 `Open` 语句具有以下优势： * 支持大文件（>2GB） * 支持流式分块读写 * 统一的缓冲区操作模式 * 支持链式调用 **特点：** * 一个实例同一时间只能操作一个文件 * 读取内容先进入内部缓冲区，再通过 `ReturnXXX` 方法提取 * 支持 UTF-8、ANSI、UTF-16LE 编码 *** ## 属性 | 属性名 | 类型 | 说明 | |--------|------|------| | `IsOpen` | `Boolean` | 文件是否已打开（只读） | | `FilePath` | `String` | 当前打开的文件路径（只读） | | `LastError` | `String` | 最后一次错误信息（只读） | | `FileSize` | `Currency` | 文件大小（字节，支持大文件） | | `BufferSize` | `Long` | 当前缓冲区字节数 | *** ## 方法 ### OpenFile 打开文件，返回 Me 支持链式调用。 **语法：** ```vb Public Function OpenFile(ByVal FilePath As String, Optional ByVal AccessMode As String = "RW") As cFileIO ``` **参数：** | 参数 | 类型 | 说明 | |------|------|------| | `FilePath` | `String` | 要打开的文件路径 | | `AccessMode` | `String` | 可选。访问模式：`R`=只读, `W`=只写, `RW`=读写(默认) | **返回值：** * 返回自身实例，支持链式调用 **异常：** * 文件无法打开时抛出错误 **示例：** ```vb Dim File As New cFileIO ' 基本打开 File.OpenFile "C:\\data\\file.txt", "R" ' 链式调用 Dim Content As String Content = File.OpenFile("C:\\data\\file.txt", "R").ReadData().ReturnText() ``` *** ### CloseFile 关闭当前打开的文件。 **语法：** ```vb Public Sub CloseFile() ``` **说明：** * 自动刷新缓冲区 * 类终止时会自动调用 **示例：** ```vb Dim File As New cFileIO File.OpenFile "C:\\data\\file.txt" ' ... 操作文件 ... File.CloseFile ``` *** ### ClearBuffer 清空内部缓冲区。 **语法：** ```vb Public Function ClearBuffer() As cFileIO ``` **返回值：** * 返回自身实例，支持链式调用 **示例：** ```vb File.ClearBuffer() ``` *** ### SetBuffer 用外部字节数组填充缓冲区。 **语法：** ```vb Public Function SetBuffer(Data() As Byte) As cFileIO ``` **参数：** | 参数 | 类型 | 说明 | |------|------|------| | `Data` | `Byte()` | 要设置的字节数组 | **返回值：** * 返回自身实例，支持链式调用 **示例：** ```vb Dim Bytes() As Byte Bytes = StrConv("Hello World", vbFromUnicode) File.SetBuffer Bytes ``` *** ### AppendBuffer 追加字节到缓冲区。 **语法：** ```vb Public Function AppendBuffer(Data() As Byte) As cFileIO ``` **参数：** | 参数 | 类型 | 说明 | |------|------|------| | `Data` | `Byte()` | 要追加的字节数组 | **返回值：** * 返回自身实例，支持链式调用 **示例：** ```vb Dim Part1() As Byte, Part2() As Byte Part1 = StrConv("Hello ", vbFromUnicode) Part2 = StrConv("World", vbFromUnicode) File.SetBuffer(Part1).AppendBuffer(Part2) ``` *** ### SetBufferText 用字符串填充缓冲区（默认 UTF-8 编码）。 **语法：** ```vb Public Function SetBufferText(ByVal Text As String, Optional ByVal CharSet As String = "UTF-8") As cFileIO ``` **参数：** | 参数 | 类型 | 说明 | |------|------|------| | `Text` | `String` | 要设置的文本 | | `CharSet` | `String` | 可选。编码：`UTF-8`(默认)、`ANSI`、`UTF-16LE` | **返回值：** * 返回自身实例，支持链式调用 **示例：** ```vb ' UTF-8 编码 File.SetBufferText "Hello World 你好世界" ' ANSI 编码 File.SetBufferText "Hello World", "ANSI" ``` *** ### ReadData 将文件指定范围读入内部缓冲区。 **语法：** ```vb Public Function ReadData(Optional ByVal StartPos As Long = -1, Optional ByVal EndPos As Long = -1) As cFileIO ``` **参数：** | 参数 | 类型 | 说明 | |------|------|------| | `StartPos` | `Long` | 可选。起始位置（0-based，-1 表示从开头） | | `EndPos` | `Long` | 可选。结束位置（0-based，-1 表示到末尾） | **返回值：** * 返回自身实例，支持链式调用 **说明：** * 位置参数为 0-based 字节偏移 * 支持大文件，但单次读取不能超过 2GB **示例：** ```vb Dim File As New cFileIO ' 读取整个文件 File.OpenFile("C:\\data\\file.txt", "R").ReadData() ' 读取前 1000 字节 File.ReadData(0, 999) ' 从第 1000 字节读到末尾 File.ReadData(1000, -1) ``` *** ### ReturnText 从缓冲区返回文本。 **语法：** ```vb Public Function ReturnText(Optional ByVal CharSet As String = "UTF-8") As String ``` **参数：** | 参数 | 类型 | 说明 | |------|------|------| | `CharSet` | `String` | 可选。编码：`UTF-8`(默认)、`ANSI`、`UTF-16LE` | **返回值：** * 字符串内容 **示例：** ```vb Dim Content As String Content = File.OpenFile("C:\\data\\file.txt", "R") _ .ReadData() _ .ReturnText("UTF-8") Debug.Print Content ``` *** ### ReturnBytes 从缓冲区返回字节数组（副本）。 **语法：** ```vb Public Function ReturnBytes() As Byte() ``` **返回值：** * 字节数组 **示例：** ```vb Dim Bytes() As Byte Bytes = File.OpenFile("C:\\data\\file.bin", "R").ReadData().ReturnBytes() ``` *** ### ReturnBase64 从缓冲区返回 Base64 编码字符串。 **语法：** ```vb Public Function ReturnBase64() As String ``` **返回值：** * Base64 编码字符串 **示例：** ```vb Dim Base64 As String Base64 = File.OpenFile("C:\\data\\image.png", "R").ReadData().ReturnBase64() Debug.Print Base64 ``` *** ### SaveData 将内部缓冲区写入文件。 **语法：** ```vb Public Function SaveData(Optional ByVal FilePath As String, Optional ByVal IsAppend As Boolean = False) As cFileIO ``` **参数：** | 参数 | 类型 | 说明 | |------|------|------| | `FilePath` | `String` | 可选。目标路径，未提供则使用 OpenFile 时的路径 | | `IsAppend` | `Boolean` | 可选。`False`=覆盖(默认), `True`=追加到文件末尾 | **返回值：** * 返回自身实例，支持链式调用 **示例：** ```vb ' 覆盖写入 File.SetBufferText("Hello World").SaveData("C:\\data\\output.txt") ' 追加写入 File.SetBufferText("\nNew line").SaveData("C:\\data\\log.txt", True) ``` *** ## 使用示例 ### 示例 1：读取文本文件 ```vb Sub ReadTextFileExample() Dim File As New cFileIO Dim Content As String On Error GoTo ErrorHandler ' 打开并读取文件 Content = File.OpenFile("C:\\data\\readme.txt", "R") _ .ReadData() _ .ReturnText("UTF-8") Debug.Print "文件内容:" Debug.Print Content File.CloseFile Exit Sub ErrorHandler: Debug.Print "错误: " & File.LastError File.CloseFile End Sub ``` ### 示例 2：写入文本文件 ```vb Sub WriteTextFileExample() Dim File As New cFileIO ' 创建并写入文件 File.SetBufferText("这是第一行", "UTF-8") _ .SaveData("C:\\data\\output.txt") ' 追加内容 File.SetBufferText("\n这是追加的行", "UTF-8") _ .SaveData("C:\\data\\output.txt", True) Debug.Print "文件写入完成" End Sub ``` ### 示例 3：复制文件（分块读取） ```vb Sub CopyFileExample() Dim SrcFile As New cFileIO Dim DstFile As New cFileIO Dim FileSize As Currency Dim Offset As Currency Const ChunkSize As Long = 1048576 ' 1MB ' 打开源文件 SrcFile.OpenFile "C:\\source\\largefile.zip", "R" FileSize = SrcFile.FileSize ' 分块读取并写入 Offset = 0 Do While Offset < FileSize Dim EndPos As Long EndPos = Offset + ChunkSize - 1 If EndPos >= FileSize Then EndPos = -1 ' 读取一块数据 SrcFile.ReadData CLng(Offset), EndPos ' 写入目标文件 If Offset = 0 Then DstFile.SetBuffer(SrcFile.ReturnBytes()).SaveData "C:\\dest\\largefile.zip" Else DstFile.SetBuffer(SrcFile.ReturnBytes()).SaveData "C:\\dest\\largefile.zip", True End If Offset = Offset + ChunkSize Loop SrcFile.CloseFile Debug.Print "文件复制完成" End Sub ``` ### 示例 4：编码转换 ```vb Sub ConvertEncodingExample() Dim File As New cFileIO Dim Content As String ' 读取 ANSI 文件 Content = File.OpenFile("C:\\data\\ansi.txt", "R") _ .ReadData() _ .ReturnText("ANSI") ' 转换为 UTF-8 保存 File.SetBufferText(Content, "UTF-8") _ .SaveData "C:\\data\\utf8.txt" Debug.Print "编码转换完成" End Sub ``` *** ## 注意事项 1. **内存限制**：单次读取不能超过 2GB 2. **编码检测**：读取时会自动跳过 UTF-8 BOM 和 UTF-16 BOM 3. **资源释放**：类终止时会自动关闭文件，但建议显式调用 `CloseFile` 4. **线程安全**：每个实例只能操作一个文件，多线程需要多个实例 --- --- url: /en/vbman/tools/fso/cFileIO.md --- # cFileIO Class Advanced file operations class based on Win32 API, supports large files (>2GB) and streaming read/write. ## Description `cFileIO` uses `CreateFile` API for file operations, with the following advantages over VB native `Open` statement: * Supports large files (>2GB) * Supports streaming chunked read/write * Unified buffer operation mode * Supports method chaining **Features:** * One instance can only operate on one file at a time * Read content first enters internal buffer, then extracted via `ReturnXXX` methods * Supports UTF-8, ANSI, UTF-16LE encodings *** ## Properties | Property Name | Type | Description | |---------------|------|-------------| | `IsOpen` | `Boolean` | Whether file is open (read-only) | | `FilePath` | `String` | Currently opened file path (read-only) | | `LastError` | `String` | Last error message (read-only) | | `FileSize` | `Currency` | File size (bytes, supports large files) | | `BufferSize` | `Long` | Current buffer byte count | *** ## Methods ### OpenFile Opens a file, returns Me to support method chaining. **Syntax:** ```vb Public Function OpenFile(ByVal FilePath As String, Optional ByVal AccessMode As String = "RW") As cFileIO ``` **Parameters:** | Parameter | Type | Description | |-----------|------|-------------| | `FilePath` | `String` | File path to open | | `AccessMode` | `String` | Optional. Access mode: `R`=read-only, `W`=write-only, `RW`=read-write (default) | **Returns:** * Returns self instance, supports method chaining **Exceptions:** * Throws error when file cannot be opened **Example:** ```vb Dim File As New cFileIO ' Basic open File.OpenFile "C:\\data\\file.txt", "R" ' Method chaining Dim Content As String Content = File.OpenFile("C:\\data\\file.txt", "R").ReadData().ReturnText() ``` *** ### CloseFile Closes the currently opened file. **Syntax:** ```vb Public Sub CloseFile() ``` **Description:** * Automatically flushes buffer * Automatically called when class terminates **Example:** ```vb Dim File As New cFileIO File.OpenFile "C:\\data\\file.txt" ' ... operate on file ... File.CloseFile ``` *** ### ClearBuffer Clears the internal buffer. **Syntax:** ```vb Public Function ClearBuffer() As cFileIO ``` **Returns:** * Returns self instance, supports method chaining **Example:** ```vb File.ClearBuffer() ``` *** ### SetBuffer Fills the buffer with external byte array. **Syntax:** ```vb Public Function SetBuffer(Data() As Byte) As cFileIO ``` **Parameters:** | Parameter | Type | Description | |-----------|------|-------------| | `Data` | `Byte()` | Byte array to set | **Returns:** * Returns self instance, supports method chaining **Example:** ```vb Dim Bytes() As Byte Bytes = StrConv("Hello World", vbFromUnicode) File.SetBuffer Bytes ``` *** ### AppendBuffer Appends bytes to the buffer. **Syntax:** ```vb Public Function AppendBuffer(Data() As Byte) As cFileIO ``` **Parameters:** | Parameter | Type | Description | |-----------|------|-------------| | `Data` | `Byte()` | Byte array to append | **Returns:** * Returns self instance, supports method chaining **Example:** ```vb Dim Part1() As Byte, Part2() As Byte Part1 = StrConv("Hello ", vbFromUnicode) Part2 = StrConv("World", vbFromUnicode) File.SetBuffer(Part1).AppendBuffer(Part2) ``` *** ### SetBufferText Fills the buffer with string (default UTF-8 encoding). **Syntax:** ```vb Public Function SetBufferText(ByVal Text As String, Optional ByVal CharSet As String = "UTF-8") As cFileIO ``` **Parameters:** | Parameter | Type | Description | |-----------|------|-------------| | `Text` | `String` | Text to set | | `CharSet` | `String` | Optional. Encoding: `UTF-8`(default), `ANSI`, `UTF-16LE` | **Returns:** * Returns self instance, supports method chaining **Example:** ```vb ' UTF-8 encoding File.SetBufferText "Hello World 你好世界" ' ANSI encoding File.SetBufferText "Hello World", "ANSI" ``` *** ### ReadData Reads specified range of file into internal buffer. **Syntax:** ```vb Public Function ReadData(Optional ByVal StartPos As Long = -1, Optional ByVal EndPos As Long = -1) As cFileIO ``` **Parameters:** | Parameter | Type | Description | |-----------|------|-------------| | `StartPos` | `Long` | Optional. Start position (0-based, -1 means from beginning) | | `EndPos` | `Long` | Optional. End position (0-based, -1 means to end) | **Returns:** * Returns self instance, supports method chaining **Description:** * Position parameters are 0-based byte offsets * Supports large files, but single read cannot exceed 2GB **Example:** ```vb Dim File As New cFileIO ' Read entire file File.OpenFile("C:\\data\\file.txt", "R").ReadData() ' Read first 1000 bytes File.ReadData(0, 999) ' Read from byte 1000 to end File.ReadData(1000, -1) ``` *** ### ReturnText Returns text from buffer. **Syntax:** ```vb Public Function ReturnText(Optional ByVal CharSet As String = "UTF-8") As String ``` **Parameters:** | Parameter | Type | Description | |-----------|------|-------------| | `CharSet` | `String` | Optional. Encoding: `UTF-8`(default), `ANSI`, `UTF-16LE` | **Returns:** * String content **Example:** ```vb Dim Content As String Content = File.OpenFile("C:\\data\\file.txt", "R") _ .ReadData() _ .ReturnText("UTF-8") Debug.Print Content ``` *** ### ReturnBytes Returns byte array from buffer (copy). **Syntax:** ```vb Public Function ReturnBytes() As Byte() ``` **Returns:** * Byte array **Example:** ```vb Dim Bytes() As Byte Bytes = File.OpenFile("C:\\data\\file.bin", "R").ReadData().ReturnBytes() ``` *** ### ReturnBase64 Returns Base64-encoded string from buffer. **Syntax:** ```vb Public Function ReturnBase64() As String ``` **Returns:** * Base64-encoded string **Example:** ```vb Dim Base64 As String Base64 = File.OpenFile("C:\\data\\image.png", "R").ReadData().ReturnBase64() Debug.Print Base64 ``` *** ### SaveData Writes internal buffer to file. **Syntax:** ```vb Public Function SaveData(Optional ByVal FilePath As String, Optional ByVal IsAppend As Boolean = False) As cFileIO ``` **Parameters:** | Parameter | Type | Description | |-----------|------|-------------| | `FilePath` | `String` | Optional. Target path, uses path from OpenFile if not provided | | `IsAppend` | `Boolean` | Optional. `False`=overwrite (default), `True`=append to end of file | **Returns:** * Returns self instance, supports method chaining **Example:** ```vb ' Overwrite File.SetBufferText("Hello World").SaveData("C:\\data\\output.txt") ' Append File.SetBufferText("\nNew line").SaveData("C:\\data\\log.txt", True) ``` *** ## Usage Examples ### Example 1: Read Text File ```vb Sub ReadTextFileExample() Dim File As New cFileIO Dim Content As String On Error GoTo ErrorHandler ' Open and read file Content = File.OpenFile("C:\\data\\readme.txt", "R") _ .ReadData() _ .ReturnText("UTF-8") Debug.Print "File content:" Debug.Print Content File.CloseFile Exit Sub ErrorHandler: Debug.Print "Error: " & File.LastError File.CloseFile End Sub ``` ### Example 2: Write Text File ```vb Sub WriteTextFileExample() Dim File As New cFileIO ' Create and write file File.SetBufferText("This is the first line", "UTF-8") _ .SaveData("C:\\data\\output.txt") ' Append content File.SetBufferText("\nThis is an appended line", "UTF-8") _ .SaveData("C:\\data\\output.txt", True) Debug.Print "File write completed" End Sub ``` ### Example 3: Copy File (Chunked Reading) ```vb Sub CopyFileExample() Dim SrcFile As New cFileIO Dim DstFile As New cFileIO Dim FileSize As Currency Dim Offset As Currency Const ChunkSize As Long = 1048576 ' 1MB ' Open source file SrcFile.OpenFile "C:\\source\\largefile.zip", "R" FileSize = SrcFile.FileSize ' Read chunks and write Offset = 0 Do While Offset < FileSize Dim EndPos As Long EndPos = Offset + ChunkSize - 1 If EndPos >= FileSize Then EndPos = -1 ' Read a chunk SrcFile.ReadData CLng(Offset), EndPos ' Write to destination file If Offset = 0 Then DstFile.SetBuffer(SrcFile.ReturnBytes()).SaveData "C:\\dest\\largefile.zip" Else DstFile.SetBuffer(SrcFile.ReturnBytes()).SaveData "C:\\dest\\largefile.zip", True End If Offset = Offset + ChunkSize Loop SrcFile.CloseFile Debug.Print "File copy completed" End Sub ``` ### Example 4: Encoding Conversion ```vb Sub ConvertEncodingExample() Dim File As New cFileIO Dim Content As String ' Read ANSI file Content = File.OpenFile("C:\\data\\ansi.txt", "R") _ .ReadData() _ .ReturnText("ANSI") ' Convert to UTF-8 and save File.SetBufferText(Content, "UTF-8") _ .SaveData "C:\\data\\utf8.txt" Debug.Print "Encoding conversion completed" End Sub ``` *** ## Notes 1. **Memory Limit**: Single read cannot exceed 2GB 2. **Encoding Detection**: Automatically skips UTF-8 BOM and UTF-16 BOM when reading 3. **Resource Release**: File is automatically closed when class terminates, but explicit `CloseFile` is recommended 4. **Thread Safety**: Each instance can only operate on one file, multiple instances needed for multi-threading --- --- url: /en/vbman/database/chain-curd-aggregate.md --- # Chained CRUD - Aggregate Terminal Methods Aggregate methods directly return calculation results without manually building `SELECT COUNT(*) FROM ...`. For architecture details, see [Chained CRUD Overview](./chain-curd). *** ## RowCount - Count Rows ### Syntax ```vb Function RowCount() As Long ``` ### Example ```vb ' Count total rows Dim total As Long total = db.Table("users").RowCount ' Conditional count Dim activeCount As Long activeCount = db.Table("users").Where("status=?", "active").RowCount ' Range count Dim youngCount As Long youngCount = db.Table("users").WhereBetween("age", 18, 30).RowCount ``` *** ## RowExists - Check Existence ### Syntax ```vb Function RowExists() As Boolean ``` ### Example ```vb ' Check if user exists If db.Table("users").Where("serial_no=?", sn).RowExists Then MsgBox "Device already exists" Else MsgBox "Device does not exist" End If ' Check if email is registered If db.Table("users").Where("email=?", email).RowExists Then MsgBox "Email already registered" End If ``` *** ## RowPluck - Extract Single Column Value List Returns a Collection containing all values of the specified field. ### Syntax ```vb Function RowPluck(ByVal FieldName As String) As Collection ``` ### Example ```vb ' Extract all usernames Dim names As Collection Set names = db.Table("users").RowPluck("name") ' Extract IDs meeting conditions Dim ids As Collection Set ids = db.Table("users").Where("role=?", "admin").RowPluck("id") ' Iterate extracted results Dim v As Variant For Each v In ids Debug.Print "Admin ID: " & v Next ``` *** ## RowMax - Maximum Value ### Syntax ```vb Function RowMax(ByVal FieldName As String) As Variant ``` ### Example ```vb Dim maxAge As Variant maxAge = db.Table("users").RowMax("age") Debug.Print "Maximum age: " & maxAge ' Conditional maximum Dim maxSalary As Variant maxSalary = db.Table("users").Where("dept=?", "IT").RowMax("salary") ``` *** ## RowMin - Minimum Value ```vb Dim minAge As Variant minAge = db.Table("users").RowMin("age") ``` *** ## RowSum - Sum ```vb Dim totalAmount As Variant totalAmount = db.Table("orders").Where("year=?", 2026).RowSum("amount") Debug.Print "2026 total amount: " & totalAmount ``` *** ## RowAvg - Average ```vb Dim avgSalary As Variant avgSalary = db.Table("users").Where("dept=?", "IT").RowAvg("salary") Debug.Print "IT department average salary: " & avgSalary ``` *** **Last Updated**: 2026-06-26 --- --- url: /en/vbman/database/chain-curd-where.md --- # Chained CRUD - Condition Methods All condition methods return the `cDataBase` object, allowing free stacking and combination. For architecture details, see [Chained CRUD Overview](./chain-curd). *** ## Where - WHERE Condition Sets WHERE AND condition, supports `?` placeholder + automatic parameter escaping. ### Syntax ```vb Function Where(ByVal Condition As String, ParamArray Params() As Variant) As cDataBase ``` ### Example ```vb ' Simple condition db.Table("users").Where("age > 18").RowRead ' Placeholder parameters (auto-escape single quotes) db.Table("users").Where("name=?", "Zhang San").RowRead ' Multiple parameters db.Table("users").Where("name=? AND age>?", "Zhang San", 18).RowRead ``` *** ## OrWhere - OR Condition Adds OR condition, connected with OR to the AND conditions from Where. ### Syntax ```vb Function OrWhere(ByVal Condition As String, ParamArray Params() As Variant) As cDataBase ``` ### Example ```vb ' AND + OR combination ' Generated SQL: WHERE age > 18 OR (status = 'VIP') db.Table("users").Where("age>?", 18).OrWhere("status=?", "VIP").RowRead ' Multiple OrWhere ' Generated SQL: WHERE age > 18 OR (role='admin' OR role='super') db.Table("users").Where("age>?", 18).OrWhere("role='admin'").OrWhere("role='super'").RowRead ``` *** ## WhereIn - IN Condition Field value is in the specified list. Supports comma-separated string or multiple parameter forms. ### Syntax ```vb Function WhereIn(ByVal FieldName As String, ParamArray Values() As Variant) As cDataBase ``` ### Example ```vb ' Comma-separated string form db.Table("users").WhereIn("status", "active,pending,closed").RowRead ' Multiple parameter form db.Table("users").WhereIn("id", 1, 2, 3, 5, 8).RowRead ' Combined with other conditions db.Table("users").Where("age>?", 18).WhereIn("dept", "IT,HR").RowRead ``` *** ## WhereNotIn - NOT IN Condition Field value is not in the specified list. ### Syntax ```vb Function WhereNotIn(ByVal FieldName As String, ParamArray Values() As Variant) As cDataBase ``` ### Example ```vb ' Exclude specified roles db.Table("users").WhereNotIn("role", "admin,root,superadmin").RowRead ``` *** ## WhereBetween - BETWEEN Condition Field value is between two values. ### Syntax ```vb Function WhereBetween(ByVal FieldName As String, ByVal Value1 As Variant, ByVal Value2 As Variant) As cDataBase ``` ### Example ```vb ' Age range query db.Table("users").WhereBetween("age", 18, 30).RowRead ' Date range query db.Table("orders").WhereBetween("created_at", "2025-01-01", "2025-12-31").RowRead ' Combined conditions db.Table("users").Where("dept=?", "IT").WhereBetween("salary", 5000, 15000).RowRead ``` *** ## WhereNotBetween - NOT BETWEEN Condition ```vb db.Table("users").WhereNotBetween("age", 18, 30).RowRead ``` *** ## WhereLike - LIKE Fuzzy Match ### Syntax ```vb Function WhereLike(ByVal FieldName As String, ByVal Pattern As String) As cDataBase ``` ### Example ```vb ' Contains match db.Table("users").WhereLike("name", "%Zhang%").RowRead ' Prefix match db.Table("users").WhereLike("email", "admin%").RowRead ' Combined with other conditions db.Table("users").Where("dept=?", "IT").WhereLike("name", "%Zhang%").RowRead ``` *** ## WhereNotLike - NOT LIKE ```vb db.Table("users").WhereNotLike("name", "%test%").RowRead ``` *** ## WhereNull - IS NULL Condition ### Syntax ```vb Function WhereNull(ByVal FieldName As String) As cDataBase ``` ### Example ```vb ' Query records not deleted db.Table("users").WhereNull("deleted_at").RowRead ' Query users without email set db.Table("users").WhereNull("email").RowRead ``` *** ## WhereNotNull - IS NOT NULL Condition ```vb ' Query users with verified email db.Table("users").WhereNotNull("email_verified_at").RowRead ``` *** **Last Updated**: 2026-06-26 --- --- url: /en/vbman/database/chain-curd-examples.md --- # Chained CRUD - Examples & Best Practices This document contains practical examples, comparison with traditional SQL, FAQ, and best practices. For method details, see the sub-pages: * [Condition Methods](./chain-curd-where) * [Sort/Group/Join/Selection](./chain-curd-modifiers) * [Limit & Pagination](./chain-curd-limit-page) * [Terminal Methods](./chain-curd-terminal) * [Aggregate Methods](./chain-curd-aggregate) *** ## Comprehensive Examples ### Example 1: User Management System ```vb ' Query active user list (sort + pagination) If db.Table("users") _ .Where("status=?", "active") _ .WhereNotNull("email") _ .OrderByDesc("last_login") _ .Page(1, 20) _ .RowRead Then Do Until db.Rs.EOF Debug.Print db.Rs!name & " | " & db.Rs!email db.Rs.MoveNext Loop End If ' Search users (fuzzy match + OR condition) db.Table("users") _ .WhereLike("name", "%" & keyword & "%") _ .OrWhereLike("email", "%" & keyword & "%") _ .OrderBy("name") _ .RowRead ' Create new user With db.Table("users") .Field "name", txtName.Text .Field "age", CLng(txtAge.Text) .Field "email", txtEmail.Text .Field "status", "active" .RowCreate newId = db.LastInsertId End With ' Update user info With db.Table("users").Where("id=?", userId) .Field "name", txtName.Text .Field "email", txtEmail.Text .RowUpdate End With ' Delete expired users db.Table("users").Where("status=?", "expired").WhereNull("email").RowDelete ``` ### Example 2: Report Statistics ```vb ' Department count statistics db.Table("users") _ .Columns("dept,COUNT(*) AS cnt") _ .GroupBy("dept") _ .Having("cnt>5") _ .OrderByDesc("cnt") _ .RowRead ' Monthly sales summary db.Table("orders") _ .Columns("YEAR(created_at) AS y,MONTH(created_at) AS m,SUM(amount) AS total") _ .GroupBy("YEAR(created_at)") _ .GroupBy("MONTH(created_at)") _ .WhereBetween("created_at", "2026-01-01", "2026-12-31") _ .OrderBy("y") _ .OrderBy("m") _ .RowRead ' Quick statistics Dim totalUsers As Long totalUsers = db.Table("users").RowCount Dim avgSalary As Variant avgSalary = db.Table("users").Where("dept=?", "IT").RowAvg("salary") Dim maxOrder As Variant maxOrder = db.Table("orders").RowMax("amount") ' Get all department names list Dim depts As Collection Set depts = db.Table("users").Distinct.Columns("dept").RowPluck("dept") ``` ### Example 3: Multi-Table Join Query ```vb ' Order details (orders + users + products) db.Table("orders") _ .Columns("orders.id,users.name AS user_name,products.title AS product,orders.amount") _ .Join("users", "orders.user_id=users.id") _ .LeftJoin("products", "orders.product_id=products.id") _ .Where("orders.amount>?", 100) _ .WhereBetween("orders.created_at", "2026-01-01", "2026-06-30") _ .OrderByDesc("orders.amount") _ .Limit(50) _ .RowRead ``` ### Example 4: Check Existence and Extract List ```vb ' Check if email exists before registration If db.Table("users").Where("email=?", newEmail).RowExists Then MsgBox "This email is already registered" Exit Sub End If ' Get admin ID list Dim adminIds As Collection Set adminIds = db.Table("users").WhereIn("role", "admin,superadmin").RowPluck("id") ' Batch operation: mark all admins as online With db.Table("users").WhereIn("id", "1,2,3,5") .Field "online_status", True .RowUpdate End With ``` *** ## Comparison with Traditional SQL ### Query Comparison ```vb ' ── Traditional SQL Approach ── db.Sql("SELECT id,name FROM users WHERE age > 18 AND dept IN ('IT','HR') ORDER BY age DESC LIMIT 10").Fetch ' ── Chained Builder Approach ── db.Table("users") _ .Columns("id,name") _ .Where("age>?", 18) _ .WhereIn("dept", "IT,HR") _ .OrderByDesc("age") _ .Limit(10) _ .RowRead ``` ### Insert Comparison ```vb ' ── Traditional SQL Approach ── db.Sql("INSERT INTO users (name,age) VALUES ('Zhang San',25)").Exec ' ── Chained Builder Approach ── db.Table("users").Field("name", "Zhang San").Field("age", 25).RowCreate ``` ### Update Comparison ```vb ' ── Traditional SQL Approach ── db.Sql("UPDATE users SET name='Li Si' WHERE id=1").Exec ' ── Chained Builder Approach ── db.Table("users").Where("id=?", 1).Field("name", "Li Si").RowUpdate ``` ### Delete Comparison ```vb ' ── Traditional SQL Approach ── db.Sql("DELETE FROM users WHERE status='expired'").Exec ' ── Chained Builder Approach ── db.Table("users").Where("status=?", "expired").RowDelete ``` ### Chained Advantages | Dimension | Traditional SQL | Chained Builder | | --------------- | --------------------------------- | ----------------------------- | | Readability | Long string concatenation, hard to read | Method chain with clear semantics | | SQL Injection Risk | Manual value concatenation, easy to miss escaping | Automatic parameter escaping | | Cross-Database | Need to write different pagination/limit syntax | Auto-adapts MySQL/MSSQL/Access | | Maintainability | Changing conditions requires rewriting entire SQL | Add/remove chained methods | | Debugging | Need to print complete SQL | Each step corresponds to a SQL clause | *** ## FAQ ### Q1: Can the chained builder and Sql() method be mixed? **Not recommended**. The chained builder (`Table` + `Where` + ...) and the traditional approach (`Sql`) use different internal states. If `Sql()` has been called, chained conditions won't apply; and vice versa. Choose one approach: ```vb ' Approach 1: Chained builder (recommended for standard CRUD) db.Table("users").Where("id=?", 1).RowRead ' Approach 2: Traditional SQL (suitable for complex queries, subqueries, etc.) db.Sql("SELECT * FROM users WHERE id = 1").Fetch ``` ### Q2: What if complex queries don't fit the chained approach? For advanced SQL like subqueries, UNION, window functions that the chained builder cannot cover, use the traditional `Sql()` approach: ```vb ' Subquery - use Sql() approach db.Sql("SELECT * FROM users WHERE id IN (SELECT user_id FROM orders WHERE amount > 1000)").Fetch ' UNION query - use Sql() approach db.Sql("SELECT name FROM users UNION SELECT name FROM admins").Fetch ``` ### Q3: Can Where and WhereLike be used together? Yes, they are both AND conditions and will be automatically merged: ```vb db.Table("users") _ .Where("dept=?", "IT") _ .WhereLike("name", "%Zhang%") _ .RowRead ' Generated: WHERE dept='IT' AND name LIKE '%Zhang%' ``` ### Q4: How does OrWhere priority work? OrWhere is wrapped in parentheses to ensure correct combination with AND conditions: ```vb db.Table("users").Where("age>?", 18).OrWhere("role='VIP'").RowRead ' Generated: WHERE age > 18 OR (role='VIP') ``` ### Q5: Can Rs editing continue after RowCreate? Yes. `RowCreate` does not automatically reset the builder, allowing you to continue operating on Rs: ```vb With db.Table("users").RowCreate .Rs!name = "Zhang San" If someCondition Then .Rs!email = "zhang@test.com" End If .Rs.Update End With ``` ### Q6: What's the difference between Page and Limit/Offset? | Method | Use Case | Implementation | | ------------- | -------------- | ---------------------------- | | `Page(N,M)` | Standard pagination | ADO `PageSize/AbsolutePage`, universal for all databases | | `Limit(M)` | Simple truncation | SQL `LIMIT M`, MySQL/MSSQL syntax adaptation | | `Offset(N)` | Offset with Limit | SQL `OFFSET N`, MySQL/MSSQL syntax adaptation | **Do not use Page and Limit/Offset simultaneously** - choose one. ### Q7: Is builder state preserved after chained method execution? No. Terminal methods (`RowRead`, `RowCreate`, `RowUpdate`, `RowDelete`, `RowCount`, etc.) automatically call `ResetBuilder` to clear all internal state after execution. Next chained call must start again from `Table()`. *** ## Best Practices ### 1. Use With to Simplify Chained Calls ```vb ' Recommended: Clear With structure With db.Table("users").Where("id=?", userId) .Field "name", newName .Field "age", newAge .RowUpdate End With ' Not recommended: Scattered writing db.Table "users" db.Where "id=?", userId db.Field "name", newName db.Field "age", newAge db.RowUpdate ``` ### 2. Prefer Chained Parameter Escaping ```vb ' Recommended: Where placeholder auto-escaping db.Table("users").Where("name=?", userName).RowRead ' Not recommended: Manual value concatenation db.Table("users").Where("name='" & userName & "'").RowRead ``` ### 3. Always Set Conditions for Update/Delete ```vb ' Safe: Must have Where condition db.Table("users").Where("id=?", 1).RowUpdate db.Table("users").Where("status=?", "expired").RowDelete ' Dangerous: No condition will error (builder protection) db.Table("users").RowUpdate ' Error: no condition set ``` ### 4. Use Sql() for Complex Queries ```vb ' Chained: Standard CRUD, simple conditions, sorting, pagination db.Table("users").Where("age>?", 18).OrderByDesc("id").Page(1, 10).RowRead ' Sql(): Subqueries, UNION, window functions, complex expressions db.Sql("SELECT * FROM (SELECT id,name FROM users UNION SELECT id,name FROM admins) t").Fetch ``` *** **Last Updated**: 2026-06-26 --- --- url: /en/vbman/database/chain-curd-limit-page.md --- # Chained CRUD - Limit & Pagination Limit and pagination methods control the number and offset of query results. For architecture details, see [Chained CRUD Overview](./chain-curd). *** ## Limit - Limit Return Count Simple truncation for non-pagination scenarios, suitable for "get latest N records" etc. ### Syntax ```vb Function Limit(ByVal N As Long) As cDataBase ``` ### Database Adaptation | Database | Generated SQL | | ------------ | ---------------------------------------------- | | MySQL | `LIMIT N` | | SQL Server | `OFFSET 0 ROWS FETCH NEXT N ROWS ONLY` | | Access | Automatically converts to ADO pagination mechanism | ### Example ```vb ' Get latest 10 records db.Table("logs").OrderByDesc("id").Limit(10).RowRead ' Get top 5 active users db.Table("users").Where("status=?", "active").OrderBy("name").Limit(5).RowRead ``` *** ## Offset - Offset Used with Limit to skip the first N records. ### Syntax ```vb Function Offset(ByVal N As Long) As cDataBase ``` ### Database Adaptation | Database | Generated SQL | | ------------ | ---------------------------------------------- | | MySQL | `LIMIT Offset, Limit` | | SQL Server | `OFFSET N ROWS FETCH NEXT M ROWS ONLY` | ### Example ```vb ' Skip first 20, take 10 (page 3, 10 per page) db.Table("users").OrderBy("id").Limit(10).Offset(20).RowRead ' Rankings: skip top 100, take 50 db.Table("scores").OrderByDesc("score").Limit(50).Offset(100).RowRead ``` *** ## Page - ADO Pagination Based on ADO native pagination properties (`PageSize` + `AbsolutePage`), works for all database types. ### Syntax ```vb Function Page(Optional Num As Long = 1, Optional Limit As Long = 10) As cDataBase ``` ### Parameter Description | Parameter | Type | Description | | ---------- | ------ | ---------------------------------- | | `Num` | `Long` | Page number (optional, default 1) | | `Limit` | `Long` | Records per page (optional, default 10) | ### Example ```vb ' Page 2, 20 per page db.Table("users").OrderBy("id").Page(2, 20).RowRead ' Chained pagination query db.Table("users") _ .Where("status=?", "active") _ .OrderByDesc("created_at") _ .Page(1, 10) _ .RowRead ' Comparison with traditional Sql approach ' Traditional: db.Sql("SELECT * FROM users").Page(1, 10).Fetch ' Chained: db.Table("users").Page(1, 10).RowRead (more concise) ``` > **Note**: Do not use `Page` and `Limit/Offset` simultaneously as their functionality overlaps. `Page` is suitable for standard pagination, `Limit/Offset` for flexible truncation. *** **Last Updated**: 2026-06-26 --- --- url: /en/vbman/database/chain-curd-modifiers.md --- # Chained CRUD - Sort, Group, Join & Selection Sort, group, join, and selection methods all return the `cDataBase` object, allowing free stacking and combination. For architecture details, see [Chained CRUD Overview](./chain-curd). *** ## Sorting Methods ### OrderBy - ASC Sorting Can be called multiple times to stack multiple sort fields. #### Syntax ```vb Function OrderBy(ByVal FieldName As String) As cDataBase ``` #### Example ```vb ' Single field sorting db.Table("users").OrderBy("age").RowRead ' Multi-field sorting (by age, then by name) db.Table("users").OrderBy("age").OrderBy("name").RowRead ``` ### OrderByDesc - DESC Sorting #### Syntax ```vb Function OrderByDesc(ByVal FieldName As String) As cDataBase ``` #### Example ```vb ' Sort by ID descending db.Table("users").OrderByDesc("id").RowRead ' Mixed sorting (age descending, name ascending) db.Table("users").OrderByDesc("age").OrderBy("name").RowRead ``` ### OrderByRaw - Custom Sort Clause #### Syntax ```vb Function OrderByRaw(ByVal RawClause As String) As cDataBase ``` #### Example ```vb ' Compound sorting db.Table("users").OrderByRaw("age DESC, name ASC").RowRead ' Function sorting db.Table("users").OrderByRaw("RAND()").RowRead ``` *** ## Grouping Methods ### GroupBy - Group Query Can be called multiple times to stack multiple group fields. #### Syntax ```vb Function GroupBy(ByVal FieldName As String) As cDataBase ``` #### Example ```vb ' Group by department db.Table("users").Columns("dept,COUNT(*) AS cnt").GroupBy("dept").RowRead ' Multi-field grouping db.Table("orders").Columns("year,month,SUM(amount) AS total").GroupBy("year").GroupBy("month").RowRead ``` ### Having - Group Filter Used with GroupBy to filter grouped results. #### Syntax ```vb Function Having(ByVal Condition As String) As cDataBase ``` #### Example ```vb ' Departments with count greater than 5 db.Table("users").Columns("dept,COUNT(*) AS cnt").GroupBy("dept").Having("cnt>5").RowRead ' Departments with average salary greater than 8000 db.Table("users").Columns("dept,AVG(salary) AS avg_sal").GroupBy("dept").Having("avg_sal>8000").RowRead ``` *** ## Join Methods ### Join - INNER JOIN #### Syntax ```vb Function Join(ByVal TableName As String, ByVal OnCondition As String) As cDataBase ``` #### Example ```vb ' Inner join db.Table("orders") _ .Columns("orders.id,users.name,orders.amount") _ .Join("users", "orders.user_id=users.id") _ .RowRead ``` ### LeftJoin - LEFT JOIN #### Syntax ```vb Function LeftJoin(ByVal TableName As String, ByVal OnCondition As String) As cDataBase ``` #### Example ```vb ' Left join (keep all orders, even without matching users) db.Table("orders") _ .Columns("orders.id,users.name") _ .LeftJoin("users", "orders.user_id=users.id") _ .OrderByDesc("orders.id") _ .RowRead ``` ### RightJoin - RIGHT JOIN #### Syntax ```vb Function RightJoin(ByVal TableName As String, ByVal OnCondition As String) As cDataBase ``` #### Example ```vb ' Right join db.Table("orders") _ .RightJoin("users", "orders.user_id=users.id") _ .RowRead ``` ### Multi-Table Join Stacking ```vb ' Three-table join db.Table("orders") _ .Columns("orders.id,users.name,products.title") _ .Join("users", "orders.user_id=users.id") _ .Join("products", "orders.product_id=products.id") _ .Where("orders.amount>?", 100) _ .OrderByDesc("orders.id") _ .RowRead ``` *** ## Column Selection Methods ### Columns - Specify Query Columns Defaults to `SELECT *`, changes to specified columns after calling. Supports comma-separated string or multiple parameter forms. > **Note**: Method name uses `Columns` instead of `Select` to avoid conflict with VB6 reserved keyword `Select Case`. #### Syntax ```vb Function Columns(ParamArray Cols() As Variant) As cDataBase ``` #### Example ```vb ' String form db.Table("users").Columns("id,name,age").RowRead ' Multiple parameter form db.Table("users").Columns("id", "name", "age").RowRead ' With aggregate functions db.Table("users").Columns("dept,COUNT(*) AS cnt").GroupBy("dept").RowRead ' With JOIN db.Table("orders").Columns("orders.id,users.name").Join("users", "orders.uid=users.id").RowRead ``` ### Distinct - Distinct Query #### Syntax ```vb Function Distinct() As cDataBase ``` #### Example ```vb ' Query distinct departments db.Table("users").Distinct.Columns("dept").RowRead ' Query distinct cities db.Table("users").Distinct.Columns("city").Where("age>?", 18).RowRead ``` *** **Last Updated**: 2026-06-26 --- --- url: /en/vbman/database/chain-curd-terminal.md --- # Chained CRUD - Terminal Methods Terminal methods execute the actual database operations. After execution, the builder state is automatically reset (`ResetBuilder`). For architecture details, see [Chained CRUD Overview](./chain-curd). *** ## Field - Set Field Value Used with `RowCreate` and `RowUpdate` to set insert/update field values. ### Syntax ```vb Function Field(ByVal FieldName As String, ByVal Value As Variant) As cDataBase ``` ### Example ```vb ' Set field values for insert db.Table("users").Field("name", "Zhang San").Field("age", 25).RowCreate ' Set field values for update db.Table("users").Where("id=?", 1).Field("name", "Zhang San Updated").Field("age", 26).RowUpdate ``` *** ## RowCreate - Create Row ### Syntax ```vb Function RowCreate() As cDataBase ``` ### Usage Patterns ```vb ' Pattern 1: Chained Field (recommended, one-line insert) With db.Table("users") .Field "name", "Zhang San" .Field "age", 25 .Field "email", "zhang@example.com" .RowCreate End With ' Pattern 2: Traditional Rs editing (suitable for per-field judgment scenarios) With db.Table("users").RowCreate .Rs!name = "Zhang San" .Rs!age = 25 .Rs.Update End With ' Get auto-increment ID after insert With db.Table("users") .Field "name", "Li Si" .RowCreate Debug.Print "New ID: " & db.LastInsertId End With ``` *** ## RowRead - Query Rows ### Syntax ```vb Function RowRead() As cDataBase ``` Query results are stored in `db.Rs` (Recordset), accessible via `db.Rs!FieldName`. ### Example ```vb ' Simple query If db.Table("users").Where("id=?", 1).RowRead Then Debug.Print db.Rs!name End If ' Complex chained query db.Table("users") _ .Columns("id,name,age") _ .Where("age>?", 18) _ .WhereIn("dept", "IT,HR") _ .OrderByDesc("age") _ .Limit(10) _ .RowRead ' Iterate results If db.Table("users").Where("status=?", "active").RowRead Then Do Until db.Rs.EOF Debug.Print db.Rs!name & " - " & db.Rs!age db.Rs.MoveNext Loop End If ``` *** ## RowUpdate - Update Row ### Syntax ```vb Function RowUpdate() As cDataBase ``` ### Usage Patterns ```vb ' Pattern 1: Chained Field (recommended, one-line update) With db.Table("users").Where("id=?", 1) .Field "name", "Zhang San Updated" .Field "age", 26 .RowUpdate End With ' Pattern 2: Traditional Rs editing With db.Table("users").Where("id=?", 1).RowUpdate .Rs!name = "Zhang San Updated" .Rs.Update End With ' Batch update (with WhereIn) With db.Table("users").WhereIn("id", 1, 2, 3) .Field "status", "archived" .RowUpdate End With ``` > **Note**: RowUpdate requires a Where condition to prevent accidental full-table updates. *** ## RowDelete - Delete Row ### Syntax ```vb Function RowDelete() As cDataBase ``` ### Example ```vb ' Delete by ID db.Table("users").Where("id=?", 1).RowDelete ' Batch delete db.Table("users").WhereIn("id", 5, 8, 13).RowDelete ' Conditional delete db.Table("logs").Where("created_at<'2025-01-01'").RowDelete ' Combined condition delete db.Table("users") _ .Where("status=?", "expired") _ .WhereNull("email") _ .RowDelete ``` > **Note**: RowDelete requires a Where condition to prevent accidental full-table deletion. *** **Last Updated**: 2026-06-26 --- --- url: /en/vbman/database/chain-curd.md --- # Chained CRUD Operations This document details the chained query builder of the cDataBase class, providing an elegant ORM-like API without writing complex SQL manually. ## Detailed Documentation | Topic | Description | | --- | --- | | [Condition Methods](./chain-curd-where) | Where, OrWhere, WhereIn, WhereLike, WhereNull, etc. | | [Sort/Group/Join/Selection](./chain-curd-modifiers) | OrderBy, GroupBy, Having, Join, Columns, Distinct | | [Limit & Pagination](./chain-curd-limit-page) | Limit, Offset, Page | | [Terminal Methods](./chain-curd-terminal) | RowCreate, RowRead, RowUpdate, RowDelete, Field | | [Aggregate Methods](./chain-curd-aggregate) | RowCount, RowExists, RowPluck, RowMax/Min/Sum/Avg | | [Examples & Best Practices](./chain-curd-examples) | Practical examples, SQL comparison, FAQ, best practices | *** ## Overview ### What is Chained CRUD Chained CRUD is an elegant database operation approach provided by the cDataBase class. It builds SQL statements progressively through Method Chaining, ultimately executing operations via terminal methods. **Core Advantages**: * **High Readability** - Each chained method corresponds to a SQL clause with clear semantics * **Type Safety** - Method parameters are automatically escaped, reducing SQL injection risk * **Cross-Database Compatibility** - Automatically adapts to MySQL / SQL Server / Access syntax differences * **Zero Handwritten SQL** - Common operations like sorting, grouping, pagination, JOINs require no string concatenation ### Design Philosophy ``` Chained Call Flow: Starting Method → Condition Methods(stackable) → Modifier Methods(stackable) → Terminal Method ───────────── ─────────────── ─────────────── ────────── Table() Where() Columns() RowRead WhereIn() OrderBy() RowCreate WhereLike() GroupBy() RowUpdate OrWhere() Join() RowDelete ... Limit() RowCount Page() RowExists RowPluck RowMax/Min/Sum/Avg ``` *** ## Chained Builder Architecture ### Internal State Variables The chained builder accumulates each clause through a set of private variables. Terminal methods automatically reset the builder state after execution (`ResetBuilder`): | Variable | SQL Clause | Setting Method | | ----------------------- | ------------------- | ---------------------------- | | `pvTableName` | FROM | `Table()` | | `pvSelectFields` | SELECT column list | `Columns()` | | `pvIsDistinct` | SELECT DISTINCT | `Distinct()` | | `pvWhereCondition` | WHERE (AND conditions) | `Where()`, `WhereLike()` | | `pvOrWhereCondition` | WHERE (OR conditions) | `OrWhere()` | | `pvWhereInClauses` | WHERE IN/NOT IN | `WhereIn()`, `WhereNotIn()` | | `pvWhereBetweenClauses` | WHERE BETWEEN | `WhereBetween()` | | `pvWhereNullClauses` | WHERE IS NULL | `WhereNull()`, `WhereNotNull()`| | `pvOrderByClause` | ORDER BY | `OrderBy()`, `OrderByDesc()`, `OrderByRaw()`| | `pvGroupByClause` | GROUP BY | `GroupBy()` | | `pvHavingClause` | HAVING | `Having()` | | `pvJoinClauses` | JOIN | `Join()`, `LeftJoin()`, `RightJoin()`| | `pvLimitValue` | LIMIT | `Limit()` | | `pvOffsetValue` | OFFSET | `Offset()` | | `pvPageNum/Limit` | ADO Pagination | `Page()` | | `pvFields` | INSERT/UPDATE values| `Field()` | ### SQL Assembly Logic Terminal methods call `BuildSelectSql()` to assemble the complete SQL: ```sql SELECT [DISTINCT] {columns} FROM {table} {JOIN clauses} WHERE {Where + WhereIn + WhereBetween + WhereNull} [OR (OrWhere)] GROUP BY {group} HAVING {filter} ORDER BY {sort} LIMIT/OFFSET or ADO pagination ``` *** ## Starting Methods ### Table - Set Operation Table Sets the table name for the current operation. The starting point for all chained CRUD operations. #### Syntax ```vb Function Table(ByVal TableName As String) As cDataBase ``` #### Example ```vb ' Basic usage db.Table("users").RowRead ' With Where query db.Table("users").Where("age>?", 18).RowRead ' With Field insert db.Table("users").Field("name", "Zhang San").Field("age", 25).RowCreate ``` *** ## Complete Method Reference ### Chained Methods (return cDataBase, allowing continued chaining) | Category | Method | Description | SQL Clause | | ----------- | -------------------------- | ------------------- | ------------------------- | | **Start** | `Table(table)` | Set operation table | FROM | | **Condition** | `Where(cond,params...)` | AND condition | WHERE | | | `OrWhere(cond,params...)` | OR condition | WHERE ... OR (...) | | | `WhereIn(field,values)` | IN condition | WHERE field IN (...) | | | `WhereNotIn(field,values)` | NOT IN condition | WHERE field NOT IN (...) | | | `WhereBetween(field,V1,V2)`| BETWEEN condition | WHERE field BETWEEN V1 AND V2| | | `WhereNotBetween(field,V1,V2)`| NOT BETWEEN | WHERE field NOT BETWEEN ...| | | `WhereLike(field,pattern)` | LIKE fuzzy match | WHERE field LIKE 'pattern'| | | `WhereNotLike(field,pattern)`| NOT LIKE | WHERE field NOT LIKE 'pattern'| | | `WhereNull(field)` | IS NULL | WHERE field IS NULL | | | `WhereNotNull(field)` | IS NOT NULL | WHERE field IS NOT NULL | | **Sort** | `OrderBy(field)` | ASC sorting | ORDER BY field ASC | | | `OrderByDesc(field)` | DESC sorting | ORDER BY field DESC | | | `OrderByRaw(clause)` | Custom sorting | ORDER BY clause | | **Group** | `GroupBy(field)` | Grouping | GROUP BY field | | | `Having(condition)` | Group filter | HAVING condition | | **Join** | `Join(table,on)` | INNER JOIN | INNER JOIN table ON on | | | `LeftJoin(table,on)` | LEFT JOIN | LEFT JOIN table ON on | | | `RightJoin(table,on)` | RIGHT JOIN | RIGHT JOIN table ON on | | **Select** | `Columns(cols...)` | Specify query columns| SELECT columns | | | `Distinct()` | Distinct | SELECT DISTINCT | | **Value** | `Field(field,value)` | Set field value | INSERT/UPDATE values | | **Limit** | `Limit(N)` | Limit count | LIMIT N | | | `Offset(N)` | Offset | OFFSET N | | | `Page(num,perpage)` | ADO pagination | Rs.PageSize + AbsolutePage| ### Terminal Methods (execute operation, reset builder) | Method | Return | Description | | ------------------- | ------------ | ------------------------------ | | `RowCreate` | cDataBase | Create new row | | `RowRead` | cDataBase | Query rows (results in Rs) | | `RowUpdate` | cDataBase | Update row | | `RowDelete` | cDataBase | Delete row | | `RowCount` | Long | Count rows | | `RowExists` | Boolean | Check if exists | | `RowPluck(field)` | Collection | Extract single column values | | `RowMax(field)` | Variant | Aggregate MAX | | `RowMin(field)` | Variant | Aggregate MIN | | `RowSum(field)` | Variant | Aggregate SUM | | `RowAvg(field)` | Variant | Aggregate AVG | *** **Last Updated**: 2026-06-26 --- --- url: /en/packages/vbccr/buttons/checkboxw.md description: >- CheckBoxW Control - VBCCR Development Manual, complete API reference based on source code --- # CheckBoxW Control Enhanced CheckBox control with support for visual styles, owner-draw, ImageList icons, and PushLike mode. ## Enumerations ### ChkImageListAlignmentConstants | Constant | Value | Description | |----------|-------|-------------| | ChkImageListAlignmentLeft | 0 | Left alignment | | ChkImageListAlignmentRight | 1 | Right alignment | | ChkImageListAlignmentTop | 2 | Top alignment | | ChkImageListAlignmentBottom | 3 | Bottom alignment | | ChkImageListAlignmentCenter | 4 | Center alignment | ### ChkDrawModeConstants | Constant | Value | Description | |----------|-------|-------------| | ChkDrawModeNormal | 0 | Normal mode, drawn by the system | | ChkDrawModeOwnerDraw | 1 | Owner-draw mode, drawn by code | ## Properties ### VisualStyles ```vb Property Get VisualStyles() As Boolean Property Let VisualStyles(ByVal Value As Boolean) ``` Whether to enable visual styles. ### Appearance ```vb Property Get Appearance() As CCAppearanceConstants Property Let Appearance(ByVal Value As CCAppearanceConstants) ``` Appearance style. See Common Enumerations. ### BackColor ```vb Property Get BackColor() As OLE_COLOR Property Let BackColor(ByVal Value As OLE_COLOR) ``` Background color. ### ForeColor ```vb Property Get ForeColor() As OLE_COLOR Property Let ForeColor(ByVal Value As OLE_COLOR) ``` Foreground color. ### ImageList ```vb Property Get ImageList() As Variant Property Let ImageList(ByVal Value As Variant) Property Set ImageList(ByVal Value As Variant) ``` Associated ImageList control. ### ImageListAlignment ```vb Property Get ImageListAlignment() As ChkImageListAlignmentConstants Property Let ImageListAlignment(ByVal Value As ChkImageListAlignmentConstants) ``` ImageList icon alignment. ### ImageListMargin ```vb Property Get ImageListMargin() As Single Property Let ImageListMargin(ByVal Value As Single) ``` ImageList icon margin. ### Value ```vb Property Get Value() As Integer Property Let Value(ByVal Value As Integer) ``` CheckBox state (0 - unchecked, 1 - checked, 2 - grayed). ### Caption ```vb Property Get Caption() As String Property Let Caption(ByVal Value As String) ``` Caption text. ### Alignment ```vb Property Get Alignment() As CCLeftRightAlignmentConstants Property Let Alignment(ByVal Value As CCLeftRightAlignmentConstants) ``` CheckBox alignment. See Common Enumerations. ### TextAlignment ```vb Property Get TextAlignment() As VBRUN.AlignmentConstants Property Let TextAlignment(ByVal Value As VBRUN.AlignmentConstants) ``` Text alignment. ### PushLike ```vb Property Get PushLike() As Boolean Property Let PushLike(ByVal Value As Boolean) ``` Whether to display as a button style. ### Picture ```vb Property Get Picture() As IPictureDisp Property Let Picture(ByVal Value As IPictureDisp) Property Set Picture(ByVal Value As IPictureDisp) ``` Picture. ### WordWrap ```vb Property Get WordWrap() As Boolean Property Let WordWrap(ByVal Value As Boolean) ``` Whether to enable word wrap. ### Transparent ```vb Property Get Transparent() As Boolean Property Let Transparent(ByVal Value As Boolean) ``` Whether to use a transparent background (effective at run time). ### VerticalAlignment ```vb Property Get VerticalAlignment() As CCVerticalAlignmentConstants Property Let VerticalAlignment(ByVal Value As CCVerticalAlignmentConstants) ``` Vertical alignment. See Common Enumerations. ### Style ```vb Property Get Style() As VBRUN.ButtonConstants Property Let Style(ByVal Value As VBRUN.ButtonConstants) ``` Appearance style (standard or graphical). ### DisabledPicture ```vb Property Get DisabledPicture() As IPictureDisp Property Let DisabledPicture(ByVal Value As IPictureDisp) Property Set DisabledPicture(ByVal Value As IPictureDisp) ``` Disabled state picture. Effective when Style is graphical. ### DownPicture ```vb Property Get DownPicture() As IPictureDisp Property Let DownPicture(ByVal Value As IPictureDisp) Property Set DownPicture(ByVal Value As IPictureDisp) ``` Pressed state picture. Effective when Style is graphical. ### UseMaskColor ```vb Property Get UseMaskColor() As Boolean Property Let UseMaskColor(ByVal Value As Boolean) ``` Whether to use mask color. Effective when Style is graphical. ### MaskColor ```vb Property Get MaskColor() As OLE_COLOR Property Let MaskColor(ByVal Value As OLE_COLOR) ``` Mask color. Effective when Style is graphical. ### DrawMode ```vb Property Get DrawMode() As ChkDrawModeConstants Property Let DrawMode(ByVal Value As ChkDrawModeConstants) ``` Draw mode. ### Pushed ```vb Property Get Pushed() As Boolean ``` Whether the control is in a pressed state. Read-only. ### Hot ```vb Property Get Hot() As Boolean ``` Whether the control is in a hot state (mouse hover). Read-only. ### hWnd ```vb Property Get hWnd() As LongPtr ``` Window handle. ### hWndUserControl ```vb Property Get hWndUserControl() As LongPtr ``` UserControl window handle. ### Font ```vb Property Get Font() As StdFont Property Let Font(ByVal NewFont As StdFont) Property Set Font(ByVal NewFont As StdFont) ``` Font. ### Enabled ```vb Property Get Enabled() As Boolean Property Let Enabled(ByVal Value As Boolean) ``` Whether the control is enabled. ### OLEDropMode ```vb Property Get OLEDropMode() As OLEDropModeConstants Property Let OLEDropMode(ByVal Value As OLEDropModeConstants) ``` OLE drag-drop mode. See Common Enumerations. ### MousePointer ```vb Property Get MousePointer() As CCMousePointerConstants Property Let MousePointer(ByVal Value As CCMousePointerConstants) ``` Mouse pointer. See Common Enumerations. ### MouseIcon ```vb Property Get MouseIcon() As IPictureDisp Property Let MouseIcon(ByVal Value As IPictureDisp) Property Set MouseIcon(ByVal Value As IPictureDisp) ``` Custom mouse icon. ### MouseTrack ```vb Property Get MouseTrack() As Boolean Property Let MouseTrack(ByVal Value As Boolean) ``` Mouse enter/leave tracking. ### Name / Tag / Parent / Container / Left / Top / Width / Height / Visible / ToolTipText / HelpContextID / WhatsThisHelpID / DragIcon / DragMode See standard extender properties. ## Methods ### Refresh ```vb Public Sub Refresh() ``` Forces a repaint. ### OLEDrag ```vb Public Sub OLEDrag() ``` Initiates an OLE drag-drop operation. ### Drag / ZOrder / SetFocus / Move See standard methods. ## Events ### Click ```vb Public Event Click() ``` Single click. ### DblClick ```vb Public Event DblClick() ``` Double click. ### HotChanged ```vb Public Event HotChanged() ``` Fired when the hot state changes. ### OwnerDraw ```vb Public Event OwnerDraw(ByVal ItemAction As Long, ByVal ItemState As Long, ByVal hDC As LongPtr, ByVal Left As Long, ByVal Top As Long, ByVal Right As Long, ByVal Bottom As Long) ``` Owner-draw event. Fired when DrawMode is OwnerDraw. ### KeyDown ```vb Public Event KeyDown(KeyCode As Integer, Shift As Integer) ``` ### KeyUp ```vb Public Event KeyUp(KeyCode As Integer, Shift As Integer) ``` ### KeyPress ```vb Public Event KeyPress(KeyAscii As Integer) ``` ### MouseDown ```vb Public Event MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` ### MouseMove ```vb Public Event MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` ### MouseUp ```vb Public Event MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` ### MouseEnter ```vb Public Event MouseEnter() ``` ### MouseLeave ```vb Public Event MouseLeave() ``` ### OLECompleteDrag / OLEDragDrop / OLEDragOver / OLEGiveFeedback / OLESetData / OLEStartDrag See OLE drag-drop events. ## Code Examples ### Basic Usage ```vb ' Set up a tri-state CheckBox CheckBoxW1.Value = vbChecked ' Checked CheckBoxW2.Value = vbUnchecked ' Unchecked CheckBoxW3.Value = vbGrayed ' Grayed ' PushLike button style CheckBoxW1.PushLike = True ' Associate ImageList Set CheckBoxW1.ImageList = ImageList1 CheckBoxW1.ImageListAlignment = ChkImageListAlignmentLeft ``` ### Owner-Draw Mode ```vb Private Sub CheckBoxW1_OwnerDraw(ByVal ItemAction As Long, ByVal ItemState As Long, _ ByVal hDC As LongPtr, ByVal Left As Long, ByVal Top As Long, _ ByVal Right As Long, ByVal Bottom As Long) ' Draw custom CheckBox here End Sub ``` --- --- url: /zh/vbman/httpclient/methods.md --- # cHttpClient 方法参考 ## 🌐 HTTP 请求方法 ### SendGet 发送 GET 请求。 ```vb Public Function SendGet(ByVal url As String, Optional Body As String) As cHttpClient ``` **参数**: * `url` - 请求地址 * `Body` - 可选，请求体内容 **返回**: 返回自身实例，支持链式调用 **示例**: ```vb Dim http As New cHttpClient ' 简单 GET http.SendGet("https://api.example.com/users") ' 带查询参数的 GET http.RequestDataQuery("page") = "1" http.RequestDataQuery("limit") = "10" http.SendGet("https://api.example.com/users") ``` *** ### SendPost 发送 POST 请求。 ```vb Public Function SendPost(ByVal url As String, Optional Body As String) As cHttpClient ``` **示例**: ```vb ' POST JSON 数据 Dim json As New cJson json.AddItem "name", "张三" Set http.RequestDataJson = json http.SendPost("https://api.example.com/users") ' POST Form 数据 http.RequestDataForm("username") = "admin" http.RequestDataForm("password") = "123456" http.SendPost("https://api.example.com/login") ``` *** ### SendPut 发送 PUT 请求。 ```vb Public Function SendPut(ByVal url As String, Optional Body As String) As cHttpClient ``` *** ### SendDelete 发送 DELETE 请求。 ```vb Public Function SendDelete(ByVal url As String, Optional Body As String) As cHttpClient ``` *** ### SendOptions 发送 OPTIONS 请求。 ```vb Public Function SendOptions(ByVal url As String, Optional Body As String) As cHttpClient ``` *** ### Send 通用发送方法，可指定 HTTP 方法。 ```vb Public Function Send(Method As EnumRequestMethod, ByVal url As String, Optional Body As String) As cHttpClient ``` **参数**: * `Method` - 请求方法枚举值： * `ReqGet` - GET 请求 * `ReqPost` - POST 请求 * `ReqPut` - PUT 请求 * `ReqDelete` - DELETE 请求 * `ReqOptions` - OPTIONS 请求 *** ### Fetch 底层请求方法，Send 系列方法均调用此方法。 ```vb Public Function Fetch(Method As EnumRequestMethod, ByVal url As String, Optional Body As String) As cHttpClient ``` *** ## 🔗 链式调用方法 ### Async 设置请求模式为同步或异步。 ```vb Public Function Async(Bool As Boolean) As cHttpClient ``` **示例**: ```vb ' 异步请求 http.Async(True).SendGet("https://api.example.com/data") ' 同步请求（默认） http.Async(False).SendGet("https://api.example.com/data") ``` *** ### Proxy 设置代理服务器，空字符串表示取消代理配置（直连）。 ```vb Public Function Proxy(ByVal ProxyServer As String, Optional ByVal BypassList As String) As cHttpClient ``` **参数**: * `ProxyServer` - 代理服务器地址，空字符串表示取消代理直连。格式： * `"proxy.example.com:8080"` - 所有协议共用同一代理 * `"http=proxy1:8080;https=proxy2:8443"` - 分别为 HTTP/HTTPS 指定代理 * `BypassList` - 可选，代理绕过地址列表，多个用分号分隔，如 `"localhost;127.0.0.1;*.internal.com"` **说明**: * 应在 `SendGet`/`SendPost` 等请求方法之前调用 * 设置后对所有后续请求生效，直到再次调用 `Proxy` 修改 * 空字符串时使用 `SetProxy 2`（直连，不使用任何代理） **示例**: ```vb Dim http As New cHttpClient ' 使用代理 http.Proxy("proxy.example.com:8080").SendGet("https://api.example.com/data") ' 分别为 HTTP/HTTPS 指定代理 http.Proxy("http=proxy1:8080;https=proxy2:8443").SendGet("...") ' 带绕过列表 http.Proxy("proxy.example.com:8080", "localhost;127.0.0.1;*.internal.com").SendGet("...") ' 取消代理，直连 http.Proxy("").SendGet("https://api.example.com/data") ``` *** ### SetCookies 设置请求 Cookies，支持 `"name=value; name2=value2"` 格式自动解析到 Cookies 字典。 ```vb Public Function SetCookies(ByVal Value As String) As cHttpClient ``` **示例**: ```vb ' 设置 Cookie（自动解析到字典） http.SetCookies("session_id=abc123; user=admin") ' Cookie 会在后续请求中自动携带 http.SendGet("https://api.example.com/profile") ' 也可以直接操作 Cookies 字典 http.Cookies("token") = "xyz789" ``` *** ### SetRequestContentType 设置请求内容类型。 ```vb Public Function SetRequestContentType(ReqType As EnumRequestContentType, Optional ContentType As String) As String ``` **参数**: * `ReqType` - 内容类型枚举： * `ReqContentTypeNone` - 无 * `ReqContentTypeJson` - `application/json` * `ReqContentTypeFormUrlencoded` - `application/x-www-form-urlencoded` * `ReqContentTypeFormMultipart` - `multipart/form-data` * `ReqContentTypeTextPlain` - `text/plain` * `ReqContentTypeTextHtml` - `text/html` **示例**: ```vb http.SetRequestContentType(ReqContentTypeJson) ``` *** ### MapRequestContentType 内容类型映射方法，与 `SetRequestContentType` 相同。 *** ## 📤 响应获取方法 ### ReturnText 获取响应文本内容。 ```vb Public Function ReturnText(Optional IsUtf8 As Boolean = True, Optional IsConvert As Boolean) As String ``` **参数**: * `IsUtf8` - 是否按 UTF-8 解码（默认 True） * `IsConvert` - 是否使用 StrConv 转换（用于解决乱码） **示例**: ```vb Dim text As String text = http.SendGet("https://api.example.com").ReturnText() ' 处理可能的乱码 text = http.ReturnText(False, True) ``` *** ### ReturnJson 获取响应并解析为 JSON 对象。 ```vb Public Function ReturnJson(Optional IsUtf8 As Boolean = True, Optional IsConvert As Boolean) As cJson ``` **示例**: ```vb Dim json As cJson Set json = http.SendGet("https://api.example.com/users").ReturnJson() If json.HasKey("data") Then Debug.Print json.GetItem("data") End If ``` *** ### ReturnBody 获取原始响应字节数组。 ```vb Public Function ReturnBody() As Byte() ``` **示例**: ```vb Dim body() As Byte body = http.SendGet("https://api.example.com/file").ReturnBody() ``` *** ### ReturnStream 获取响应流对象。 ```vb Public Function ReturnStream() As Variant ``` *** ## 🛠️ 工具方法 ### ShowPage 使用默认浏览器打开 URL。 ```vb Public Sub ShowPage(url As String) ``` **示例**: ```vb http.ShowPage("https://www.example.com") ``` *** ## 📊 调试信息 ### DebugInfo 获取调试信息 JSON 对象（需先设置 `DebugStart = True`）。 ```vb Public DebugInfo As cJson ``` **示例**: ```vb http.DebugStart = True http.SendGet("https://api.example.com") ' 查看调试信息 If Not http.DebugInfo.RootIsEmpty Then ' Root 是默认成员，可直接用 Json("key") 访问 Debug.Print http.DebugInfo("Request")("Url") Debug.Print http.DebugInfo("Response")("Status") Debug.Print http.DebugInfo("Error")("Description") End If ``` *** ## 🎯 事件 ### OnResponseFinished 异步请求响应完成时触发。 ```vb Public Event OnResponseFinished() ``` **触发条件**：HTTP 2xx 响应完成时触发。3xx 重定向不触发此事件（由 `OnRedirect` 处理），4xx/5xx 不触发此事件（由 `OnError` 处理）。 **示例**: ```vb Private WithEvents HttpClient As cHttpClient Private Sub Form_Load() Set HttpClient = New cHttpClient End Sub Private Sub HttpClient_OnResponseFinished() Debug.Print "请求完成: " & HttpClient.ReturnText() Debug.Print "状态码: " & HttpClient.StatusCode End Sub ``` *** ### OnError 异步请求发生错误时触发，包括网络错误和 HTTP 4xx/5xx 响应。 ```vb Public Event OnError(ByVal ErrorNumber As Long, ByVal ErrorDescription As String) ``` **说明**: * 网络错误（连接失败等）会触发此事件 * HTTP 4xx/5xx 响应也会触发此事件（不再触发 `OnResponseFinished`） * `ErrorNumber` 为 HTTP 状态码或 WinHttp 错误码 * 超时错误码 12002 会触发 `OnTimeout` 而非此事件 **示例**: ```vb Private Sub HttpClient_OnError(ByVal ErrorNumber As Long, ByVal ErrorDescription As String) Debug.Print "请求失败 [" & ErrorNumber & "]: " & ErrorDescription End Sub ``` *** ### OnResponseStart 异步请求收到响应头时触发。 ```vb Public Event OnResponseStart(ByVal Status As Long, ByVal ContentType As String) ``` **参数**: * `Status` - HTTP 状态码（如 200、404） * `ContentType` - 响应 Content-Type 头的值 **说明**: 内部会解析 `Content-Length` 头用于进度追踪。3xx 状态码时不触发此事件，改为触发 `OnRedirect`。 **示例**: ```vb Private Sub HttpClient_OnResponseStart(ByVal Status As Long, ByVal ContentType As String) Debug.Print "响应开始: Status=" & Status & " Type=" & ContentType End Sub ``` *** ### OnResponseDataAvailable 异步请求收到响应数据时触发，可用于下载进度追踪。 ```vb Public Event OnResponseDataAvailable(Data() As Byte, ByVal BytesReceived As Long, ByVal TotalBytes As Long) ``` **参数**: * `Data` - 本次收到的数据分片 * `BytesReceived` - 累计已接收字节数 * `TotalBytes` - 总字节数（来自 Content-Length，未知时为 -1） **示例**: ```vb Private Sub HttpClient_OnResponseDataAvailable(Data() As Byte, ByVal BytesReceived As Long, ByVal TotalBytes As Long) If TotalBytes > 0 Then Debug.Print "进度: " & BytesReceived & "/" & TotalBytes & " (" & Format(BytesReceived / TotalBytes * 100, "0.0") & "%)" Else Debug.Print "已接收: " & BytesReceived & " 字节" End If End Sub ``` *** ### OnRedirect 异步请求收到 3xx 重定向时触发（需设置 `FollowRedirects = False`）。 ```vb Public Event OnRedirect(ByVal Url As String) ``` **参数**: * `Url` - 重定向目标 URL（来自 Location 响应头） **说明**: * 仅在 `FollowRedirects = False` 时触发 * 3xx 响应不会触发 `OnResponseFinished`，改由 `OnRedirect` 处理 * 可在事件中手动决定是否发起新请求 **示例**: ```vb Dim http As New cHttpClient http.FollowRedirects = False http.Async(True).SendGet "https://api.example.com/old-url" Private Sub http_OnRedirect(ByVal Url As String) Debug.Print "重定向到: " & Url ' 手动发起新请求 http.Async(True).SendGet Url End Sub ``` *** ### OnTimeout 异步请求超时时触发。 ```vb Public Event OnTimeout() ``` **说明**: 当 WinHttp 返回超时错误码（12002）时触发，替代 `OnError` 事件，便于实现重试逻辑。 **示例**: ```vb Private Sub HttpClient_OnTimeout() Debug.Print "请求超时，准备重试..." HttpClient.Async(True).SendGet "https://api.example.com/slow-api" End Sub ``` *** **最后更新**: 2026-07-13 --- --- url: /zh/vbman/httpclient/properties.md --- # cHttpClient 属性参考 ## 📝 请求数据属性 ### RequestDataJson 设置 JSON 格式的请求体数据。 ```vb Public RequestDataJson As New cJson ``` **说明**: 当设置了此属性且 Content-Type 为 JSON 时，请求体会自动序列化为 JSON 字符串。 **示例**: ```vb Dim http As New cHttpClient Dim json As New cJson json.AddItem "username", "admin" json.AddItem "password", "123456" Set http.RequestDataJson = json http.SendPost("https://api.example.com/login") ``` *** ### RequestDataForm 设置 Form 格式的请求体数据（表单数据）。 ```vb Public RequestDataForm As New Dictionary ``` **说明**: 适用于 `application/x-www-form-urlencoded` 类型的请求。 **示例**: ```vb Dim http As New cHttpClient http.RequestDataForm("username") = "admin" http.RequestDataForm("password") = "123456" http.RequestDataForm("remember") = "true" http.SendPost("https://api.example.com/login") ``` *** ### RequestDataQuery 设置 URL 查询参数。 ```vb Public RequestDataQuery As New Dictionary ``` **说明**: 发送请求时会自动追加到 URL 后面。 **示例**: ```vb Dim http As New cHttpClient http.RequestDataQuery("page") = "1" http.RequestDataQuery("limit") = "20" http.RequestDataQuery("sort") = "desc" ' 最终 URL: https://api.example.com/users?page=1&limit=20&sort=desc http.SendGet("https://api.example.com/users") ``` *** ### RequestDataBody **已移除** - 请使用 `RequestDataForm` 替代。 *** ## 📋 请求配置属性 ### RequestHeaders 设置自定义请求头。 ```vb Public RequestHeaders As New Dictionary ``` **示例**: ```vb Dim http As New cHttpClient http.RequestHeaders("Authorization") = "Bearer token123" http.RequestHeaders("X-Custom-Header") = "custom-value" http.RequestHeaders("User-Agent") = "MyApp/1.0" http.SendGet("https://api.example.com/protected") ``` *** ### RequestContentType 设置请求内容类型。 ```vb Public RequestContentType As String ``` **常用值**: * `application/json` - JSON 数据 * `application/x-www-form-urlencoded` - 表单数据（默认） * `multipart/form-data` - 文件上传 * `text/plain` - 纯文本 * `text/html` - HTML 内容 **示例**: ```vb Dim http As New cHttpClient http.RequestContentType = "application/json" ' 或使用便捷方法 http.SetRequestContentType(ReqContentTypeJson) ``` *** ### RequestChartSet 设置请求编码。 ```vb Public RequestChartSet As String ``` **默认值**: `utf-8` **说明**: 影响请求体的编码方式。设置为 UTF-8 时会使用 UTF-8 编码。 *** ### RequestTimeOut 设置请求超时时间（秒）。 ```vb Public RequestTimeOut As Long ``` **默认值**: 30 秒 **说明**: 同步模式下最小等待时间为 30 秒（内部使用局部变量，不会修改您设置的值）。异步模式下通过 WinHttp `SetTimeouts` 设置，超时触发 `OnTimeout` 事件。 **示例**: ```vb Dim http As New cHttpClient http.RequestTimeOut = 60 ' 60秒超时 http.SendGet("https://api.example.com/slow-api") ``` *** ### FollowRedirects 控制是否自动跟随 HTTP 重定向。 ```vb Public Property Get FollowRedirects() As Boolean Public Property Let FollowRedirects(ByVal Value As Boolean) ``` **默认值**: True（自动跟随重定向） **说明**: * 设为 `True` 时（默认），WinHttp 自动跟随 3xx 重定向，上层无感知 * 设为 `False` 时，3xx 响应触发 `OnRedirect` 事件（需异步模式），同时不触发 `OnResponseFinished` * 每次请求后会在 CLEAN 段重置回 `True` **示例**: ```vb Dim http As New cHttpClient http.FollowRedirects = False http.Async(True).SendGet "https://api.example.com/redirect" Private Sub http_OnRedirect(ByVal Url As String) Debug.Print "重定向到: " & Url End Sub ``` *** ## 📥 响应数据属性 ### ResponseRaw 缓存的原始响应内容。 ```vb Public ResponseRaw As Variant ``` *** ### ResponseHeaders 响应头字典。 ```vb Public ResponseHeaders As New Dictionary ``` **示例**: ```vb Dim http As New cHttpClient http.SendGet("https://api.example.com") ' 获取响应头 If http.ResponseHeaders.Exists("Content-Type") Then Debug.Print "内容类型: " & http.ResponseHeaders("Content-Type") End If ' 遍历所有响应头 Dim key As Variant For Each key In http.ResponseHeaders.Keys Debug.Print key & ": " & http.ResponseHeaders(key) Next ``` *** ### Cookies 解析后的 Cookies 字典。 ```vb Public Cookies As New Dictionary ``` **说明**: 自动从响应头 `Set-Cookie` 解析，请求时自动携带已有 Cookie。 **示例**: ```vb Dim http As New cHttpClient http.SendGet("https://api.example.com/login") ' 获取 Cookie If http.Cookies.Exists("session_id") Then Debug.Print "Session ID: " & http.Cookies("session_id") End If ' Cookie 在后续请求中自动携带，无需手动设置 http.SendGet("https://api.example.com/profile") ``` *** ### StatusCode 获取 HTTP 响应状态码。 ```vb Public Property Get StatusCode() As Long ``` **说明**: 异步/同步均可用。异步模式下 4xx/5xx 状态码会触发 `OnError` 事件。 **示例**: ```vb Dim http As New cHttpClient http.SendGet("https://api.example.com") Debug.Print "状态码: " & http.StatusCode ' 如 200 ``` *** ### StatusText 获取 HTTP 响应状态文本。 ```vb Public Property Get StatusText() As String ``` **示例**: ```vb Debug.Print "状态: " & http.StatusText ' 如 "OK" ``` *** ## ⚙️ 调试属性 ### DebugStart 启用调试模式。 ```vb Public DebugStart As Boolean ``` **说明**: 设置为 `True` 后，请求完成后会填充 `DebugInfo` 属性。 **示例**: ```vb Dim http As New cHttpClient http.DebugStart = True On Error Resume Next http.SendGet("https://api.example.com") ' 查看调试信息 If http.DebugInfo.HasKey("Error") Then Debug.Print "错误: " & http.DebugInfo.GetItem("Error").GetItem("Description") End If ``` *** ### LastError 最后发生的错误信息。 ```vb Public LastError As String ``` **示例**: ```vb Dim http As New cHttpClient Dim success As Boolean On Error Resume Next success = http.SendGet("https://invalid-url").ReturnText() <> "" If Not success Then Debug.Print "请求失败: " & http.LastError End If ``` *** **最后更新**: 2026-07-13 --- --- url: /zh/vbman/devlog/HttpClient/2026-07-13-异步事件增强.md --- # cHttpClient 异步事件增强 **日期**: 2026-07-13 **作者**: 伟哥 + 小微 ## 概述 为 cHttpClient 新增 4 个异步事件，支持重定向检测、响应进度追踪和超时识别，使异步模式具备与同步模式同等的可观测性。 ## 新增功能 ### 1. OnRedirect(url As String) * 当 `FollowRedirects = False` 且收到 3xx 状态码时触发 * 从响应头 `Location` 字段提取目标 URL * 需要在 Fetch 前设置 `.FollowRedirects = False`，默认为 True ### 2. OnResponseStart(Status As Long, ContentType As String) * WinHttp 原生事件，透传 Status 和 ContentType * 额外解析 `Content-Length` 头，为进度追踪提供 TotalBytes * 3xx 重定向检测：在禁用自动重定向时，解析 Location 头触发 OnRedirect ### 3. OnResponseDataAvailable(Data() As Byte, BytesReceived As Long, TotalBytes As Long) * WinHttp 原生事件扩展，增加累计已接收字节数和总字节数 * BytesReceived 为累计值（非本次分片大小） * TotalBytes 来自 Content-Length，未知时为 -1 * 可用于下载进度条实现 ### 4. OnTimeout() * WinHttp 错误码 12002 (ERROR\_WINHTTP\_TIMEOUT) 时触发 * 区分于普通 OnError，便于上层做重试逻辑 ### 5. FollowRedirects 属性 * 布尔值，默认 True（保持原有行为） * 设为 False 后，3xx 响应不会自动跟随，而是触发 OnRedirect 事件 * 内部通过 `Inst.Option(6)` 控制 WinHttp 的 EnableRedirects 选项 ## 修改文件 | 文件 | 变更 | |------|------| | `src/HttpClient/cHttpClient.cls` | 新增 4 个 Event 声明、3 个成员变量、FollowRedirects 属性、事件处理实现 | | `src/Collection/Dictionary.cls` | Keys/Items 返回类型从 Variant() 改为 Variant（上一个 commit 的修复） | ## 关键设计决策 1. **OnRedirect 不是 WinHttp 原生事件**：WinHttp 没有 OnRedirect，通过在 OnResponseStart 中检测 3xx + Location 头手动实现 2. **m\_FollowRedirects 默认 True**：不破坏现有代码，新功能 opt-in 3. **异步超时仅 IsAsync 时设置**：同步模式通过 WaitForResponse 控制，避免干扰 4. **OnTimeout 与 OnError 分离**：12002 错误码走 OnTimeout 而非 OnError，便于不同处理策略 5. **进度变量在 Fetch 开头重置**：m\_BytesReceived=0, m\_TotalBytes=-1，CLEAN 段也重置 ## 测试结果 编译 VBMAN.dll 成功（exit code 0），使用独立测试 EXE 验证： ``` === Async Event Test === Time: 2026/7/13 0:03:22 [Test1] Async GET http://httpbin.org/get [OnResponseStart] Status=200 ContentType=application/json [OnResponseDataAvailable] 359/359 (100.0%) [OnResponseFinished] Status=200 BodyLen=359 [Test1] PASS [Test2] Async GET FollowRedirects=False http://httpbin.org/redirect/1 [OnRedirect] -> /get [Test2] PASS ``` * OnResponseStart: 状态码和 ContentType 正确传递 * OnResponseDataAvailable: 进度回调正常，BytesReceived/TotalBytes 计算正确 * OnRedirect: 302 响应中 Location 头正确解析 * OnTimeout: 未在自动测试中触发（需模拟超时场景） ## 遗留事项 * OnTimeout 事件需在模拟超时场景下补充测试 * 3xx 响应在 FollowRedirects=False 时也会触发 OnResponseFinished，上层需检查 StatusCode 做区分 > AI生成 --- --- url: /zh/vbman/httpclient/overview.md --- # cHttpClient 组件概述 ## 简介 `cHttpClient` 是一个基于 WinHTTP 的 HTTP 客户端组件，提供完整的 HTTP 请求功能，支持同步/异步请求、链式调用、JSON 处理、Cookie 管理等特性。同时提供 `cSSEClient` 实现 SSE (Server-Sent Events) 实时消息接收。 ## 特性 | 特性 | 说明 | |------|------| | **HTTP 方法** | 支持 GET/POST/PUT/DELETE/OPTIONS | | **数据格式** | JSON、Form-UrlEncoded、Text 自动处理 | | **同步/异步** | 支持同步和异步请求模式 | | **链式调用** | 流畅的 API 设计，支持链式操作 | | **Cookie 管理** | 自动解析和设置 Cookies，请求时自动携带 | | **状态码** | 提供 `StatusCode`/`StatusText` 属性，异步/同步均可用 | | **异步事件** | OnResponseStart/OnResponseDataAvailable/OnRedirect/OnTimeout | | **重定向控制** | `FollowRedirects` 属性，禁用时触发 `OnRedirect` 事件 | | **下载进度** | 异步数据回调带累计字节数和总字节数，可直接驱动进度条 | | **代理支持** | 支持配置 HTTP/HTTPS 代理服务器，可设置绕过列表 | | **SSL 支持** | 自动忽略 SSL 证书错误 | | **编码处理** | 支持 UTF-8 编码自动转换 | | **调试模式** | 提供详细请求/响应调试信息 | | **SSE 支持** | 独立的 SSE 客户端实现实时消息 | ## 快速开始 ### HTTP GET 请求 ```vb Dim http As New cHttpClient Dim result As String ' 简单 GET 请求 result = http.SendGet("https://api.example.com/users").ReturnText() ' 带查询参数的 GET 请求 result = http.SendGet("https://api.example.com/users") _ .AddQueryParam("page", "1") _ .AddQueryParam("limit", "10") \ .ReturnText() ``` ### HTTP POST 请求 (JSON) ```vb Dim http As New cHttpClient Dim json As cJson Set json = New cJson json.AddItem "name", "张三" json.AddItem "age", 25 Set http.RequestDataJson = json Dim response As cJson Set response = http.SendPost("https://api.example.com/users").ReturnJson() ``` ### HTTP POST 请求 (Form) ```vb Dim http As New cHttpClient http.RequestDataForm("username") = "admin" http.RequestDataForm("password") = "123456" Dim result As String result = http.SendPost("https://api.example.com/login").ReturnText() ``` ### 异步请求 ```vb Private WithEvents HttpClient As cHttpClient Private Sub StartAsyncRequest() Set HttpClient = New cHttpClient HttpClient.Async(True).SendGet("https://api.example.com/data") End Sub Private Sub HttpClient_OnResponseStart(ByVal Status As Long, ByVal ContentType As String) Debug.Print "响应开始: Status=" & Status & " ContentType=" & ContentType End Sub Private Sub HttpClient_OnResponseDataAvailable(Data() As Byte, ByVal BytesReceived As Long, ByVal TotalBytes As Long) If TotalBytes > 0 Then Debug.Print "下载进度: " & BytesReceived & "/" & TotalBytes End If End Sub Private Sub HttpClient_OnResponseFinished() Debug.Print "响应完成: " & HttpClient.ReturnText() Debug.Print "状态码: " & HttpClient.StatusCode End Sub Private Sub HttpClient_OnError(ByVal ErrorNumber As Long, ByVal ErrorDescription As String) Debug.Print "错误: " & ErrorDescription End Sub Private Sub HttpClient_OnRedirect(ByVal Url As String) Debug.Print "重定向到: " & Url End Sub Private Sub HttpClient_OnTimeout() Debug.Print "请求超时" End Sub ``` > **注意**： > > * 异步模式下，HTTP 4xx/5xx 响应触发 `OnError`，3xx 响应触发 `OnRedirect`（需设 `FollowRedirects = False`），均不触发 `OnResponseFinished` > * `OnResponseDataAvailable` 的 `BytesReceived` 为累计值，`TotalBytes` 来自 Content-Length（未知时为 -1） ### 重定向控制 ```vb ' 默认自动跟随重定向 http.Async(True).SendGet("https://api.example.com/old-url") ' 禁用自动重定向，通过事件手动处理 Dim http As New cHttpClient http.FollowRedirects = False http.Async(True).SendGet "https://api.example.com/redirect" ' 在 OnRedirect 事件中获取目标 URL Private Sub http_OnRedirect(ByVal Url As String) Debug.Print "重定向到: " & Url ' 可以选择手动发起新请求 End Sub ``` ### 代理服务器 ```vb Dim http As New cHttpClient ' 使用代理服务器（所有协议共用） http.Proxy("proxy.example.com:8080").SendGet("https://api.example.com/data") ' 分别为 HTTP/HTTPS 指定代理 http.Proxy("http=proxy1:8080;https=proxy2:8443").SendGet("https://api.example.com/data") ' 带绕过列表（localhost 和内网地址不走代理） http.Proxy("proxy.example.com:8080", "localhost;127.0.0.1;*.internal.com").SendGet("...") ' 取消代理配置（直连） http.Proxy("").SendGet("https://api.example.com/data") ``` ### SSE (Server-Sent Events) ```vb Private WithEvents SSE As cSSEClient Private Sub InitializeSSE() Set SSE = New cSSEClient SSE.AutoReconnect = True SSE.ReconnectInterval = 3000 ' 3秒重连间隔 SSE.MaxReconnectAttempts = 10 Call SSE.Connect("https://api.example.com/events") End Sub ' POST 方式连接 SSE（适用于 AI 流式聊天等场景） Private Sub InitializeSSEPost() Set SSE = New cSSEClient SSE.SetHeader("Authorization", "Bearer sk-xxx") _ .SetHeader("Content-Type", "application/json") _ .RequestTimeOut = 120 Call SSE.ConnectPost("https://api.example.com/chat", "{""model"":""gpt-4"",""messages"":[...]}") End Sub Private Sub SSE_OnOpen() Debug.Print "SSE 连接已建立" End Sub Private Sub SSE_OnMessage(EventName As String, Data As String, Id As String) Debug.Print "收到消息: " & EventName & " = " & Data End Sub Private Sub SSE_OnError(Description As String, ErrorNumber As Long) Debug.Print "SSE 错误: " & Description End Sub Private Sub SSE_OnClose() Debug.Print "SSE 连接已关闭" End Sub ``` ## 引用组件 * `Microsoft WinHTTP Services, version 5.1` * `Microsoft Scripting Runtime` * `cJson.cls` * `cTimer.cls` (SSE 需要) ## 文件结构 | 文件 | 说明 | |------|------| | `cHttpClient.cls` | HTTP 客户端主类 | | `cSSEClient.cls` | SSE 客户端实现 | | `mSSEDemo.bas` | SSE 使用示例 | | `SSE_Client_使用文档.md` | SSE 详细使用文档 | *** **最后更新**: 2026-07-13 --- --- url: /en/vbman/httpclient/overview.md --- # cHttpClient Component Overview ## Introduction `cHttpClient` is an HTTP client component based on WinHTTP that provides complete HTTP request functionality, supporting sync/async requests, chainable calls, JSON processing, Cookie management, and more. Also provides `cSSEClient` for SSE (Server-Sent Events) real-time message reception. ## Features | Feature | Description | |---------|-------------| | **HTTP Methods** | Supports GET/POST/PUT/DELETE/OPTIONS | | **Data Formats** | JSON, Form-UrlEncoded, Text auto-processing | | **Sync/Async** | Supports sync and async request modes | | **Chainable API** | Fluent API design with chainable operations | | **Cookie Management** | Auto parse and set Cookies | | **SSL Support** | Auto ignore SSL certificate errors | | **Encoding** | Supports UTF-8 encoding auto-conversion | | **Debug Mode** | Provides detailed request/response debug info | | **SSE Support** | Independent SSE client for real-time messages | ## Quick Start ### HTTP GET Request ```vb Dim http As New cHttpClient Dim result As String ' Simple GET request result = http.SendGet("https://api.example.com/users").ReturnText() ' GET request with query parameters result = http.SendGet("https://api.example.com/users") _ .AddQueryParam("page", "1") _ .AddQueryParam("limit", "10") _ .ReturnText() ``` ### HTTP POST Request (JSON) ```vb Dim http As New cHttpClient Dim json As cJson Set json = New cJson json.AddItem "name", "John" json.AddItem "age", 25 Set http.RequestDataJson = json Dim response As cJson Set response = http.SendPost("https://api.example.com/users").ReturnJson() ``` ### HTTP POST Request (Form) ```vb Dim http As New cHttpClient http.RequestDataForm("username") = "admin" http.RequestDataForm("password") = "123456" Dim result As String result = http.SendPost("https://api.example.com/login").ReturnText() ``` ### Async Request ```vb Private WithEvents HttpClient As cHttpClient Private Sub StartAsyncRequest() Set HttpClient = New cHttpClient HttpClient.Async(True).SendGet("https://api.example.com/data") End Sub Private Sub HttpClient_OnResponseFinished() Debug.Print "Response complete: " & HttpClient.ReturnText() End Sub Private Sub HttpClient_OnError(ByVal ErrorNumber As Long, ByVal ErrorDescription As String) Debug.Print "Error: " & ErrorDescription End Sub ``` ### SSE (Server-Sent Events) ```vb Private WithEvents SSE As cSSEClient Private Sub InitializeSSE() Set SSE = New cSSEClient SSE.AutoReconnect = True SSE.ReconnectInterval = 3000 ' 3 second reconnect interval SSE.MaxReconnectAttempts = 10 Call SSE.Connect("https://api.example.com/events") End Sub Private Sub SSE_OnOpen() Debug.Print "SSE connection established" End Sub Private Sub SSE_OnMessage(EventName As String, Data As String, Id As String) Debug.Print "Received message: " & EventName & " = " & Data End Sub Private Sub SSE_OnError(Description As String, ErrorNumber As Long) Debug.Print "SSE error: " & Description End Sub Private Sub SSE_OnClose() Debug.Print "SSE connection closed" End Sub ``` ## References * `Microsoft WinHTTP Services, version 5.1` * `Microsoft Scripting Runtime` * `cJson.cls` * `cTimer.cls` (required for SSE) ## File Structure | File | Description | |------|-------------| | `cHttpClient.cls` | HTTP client main class | | `cSSEClient.cls` | SSE client implementation | | `mSSEDemo.bas` | SSE usage example | | `SSE_Client_使用文档.md` | SSE detailed documentation | *** **Last Updated**: 2026-05-17 --- --- url: /en/vbman/httpclient/methods.md --- # cHttpClient Methods Reference ## 🌐 HTTP Request Methods ### SendGet Sends GET request. ```vb Public Function SendGet(ByVal url As String, Optional Body As String) As cHttpClient ``` **Parameters:** * `url` - Request URL * `Body` - Optional, request body content **Returns:** Returns self instance for chainable calls **Example:** ```vb Dim http As New cHttpClient ' Simple GET http.SendGet("https://api.example.com/users") ' GET with query parameters http.RequestDataQuery("page") = "1" http.RequestDataQuery("limit") = "10" http.SendGet("https://api.example.com/users") ``` *** ### SendPost Sends POST request. ```vb Public Function SendPost(ByVal url As String, Optional Body As String) As cHttpClient ``` **Example:** ```vb ' POST JSON data Dim json As New cJson json.AddItem "name", "John" Set http.RequestDataJson = json http.SendPost("https://api.example.com/users") ' POST Form data http.RequestDataForm("username") = "admin" http.RequestDataForm("password") = "123456" http.SendPost("https://api.example.com/login") ``` *** ### SendPut Sends PUT request. ```vb Public Function SendPut(ByVal url As String, Optional Body As String) As cHttpClient ``` *** ### SendDelete Sends DELETE request. ```vb Public Function SendDelete(ByVal url As String, Optional Body As String) As cHttpClient ``` *** ### SendOptions Sends OPTIONS request. ```vb Public Function SendOptions(ByVal url As String, Optional Body As String) As cHttpClient ``` *** ### Send General send method, specifies HTTP method. ```vb Public Function Send(Method As EnumRequestMethod, ByVal url As String, Optional Body As String) As cHttpClient ``` **Parameters:** * `Method` - Request method enum value: * `ReqGet` - GET request * `ReqPost` - POST request * `ReqPut` - PUT request * `ReqDelete` - DELETE request * `ReqOptions` - OPTIONS request *** ### Fetch Low-level request method, all Send series methods call this method. ```vb Public Function Fetch(Method As EnumRequestMethod, ByVal url As String, Optional Body As String) As cHttpClient ``` *** ## 🔗 Chainable Call Methods ### Async Sets request mode to sync or async. ```vb Public Function Async(Bool As Boolean) As cHttpClient ``` **Example:** ```vb ' Async request http.Async(True).SendGet("https://api.example.com/data") ' Sync request (default) http.Async(False).SendGet("https://api.example.com/data") ``` *** ### SetCookies Sets request Cookies. ```vb Public Function SetCookies(ByVal Value As String) As cHttpClient ``` **Example:** ```vb http.SetCookies("session_id=abc123; user=admin") ``` *** ### SetRequestContentType Sets request content type. ```vb Public Function SetRequestContentType(ReqType As EnumRequestContentType, Optional ContentType As String) As String ``` **Parameters:** * `ReqType` - Content type enum: * `ReqContentTypeNone` - None * `ReqContentTypeJson` - `application/json` * `ReqContentTypeFormUrlencoded` - `application/x-www-form-urlencoded` * `ReqContentTypeFormMultipart` - `multipart/form-data` * `ReqContentTypeTextPlain` - `text/plain` * `ReqContentTypeTextHtml` - `text/html` **Example:** ```vb http.SetRequestContentType(ReqContentTypeJson) ``` *** ### MapRequestContentType Content type mapping method, same as `SetRequestContentType`. *** ## 📤 Response Retrieval Methods ### ReturnText Gets response text content. ```vb Public Function ReturnText(Optional IsUtf8 As Boolean = True, Optional IsConvert As Boolean) As String ``` **Parameters:** * `IsUtf8` - Whether to decode as UTF-8 (default True) * `IsConvert` - Whether to use StrConv conversion (for fixing garbled text) **Example:** ```vb Dim text As String text = http.SendGet("https://api.example.com").ReturnText() ' Handle possible garbled text text = http.ReturnText(False, True) ``` *** ### ReturnJson Gets response and parses to JSON object. ```vb Public Function ReturnJson(Optional IsUtf8 As Boolean = True, Optional IsConvert As Boolean) As cJson ``` **Example:** ```vb Dim json As cJson Set json = http.SendGet("https://api.example.com/users").ReturnJson() If json.HasKey("data") Then Debug.Print json.GetItem("data") End If ``` *** ### ReturnBody Gets raw response byte array. ```vb Public Function ReturnBody() As Byte() ``` **Example:** ```vb Dim body() As Byte body = http.SendGet("https://api.example.com/file").ReturnBody() ``` *** ### ReturnStream Gets response stream object. ```vb Public Function ReturnStream() As Variant ``` *** ## 🛠️ Utility Methods ### ShowPage Opens URL in default browser. ```vb Public Sub ShowPage(url As String) ``` **Example:** ```vb http.ShowPage("https://www.example.com") ``` *** ## 📊 Debug Info ### DebugInfo Gets debug info JSON object (requires `DebugStart = True` first). ```vb Public DebugInfo As cJson ``` **Example:** ```vb http.DebugStart = True http.SendGet("https://api.example.com") ' View debug info If Not http.DebugInfo.RootIsEmpty Then ' Root is default member, can use Json("key") directly Debug.Print http.DebugInfo("Request")("Url") Debug.Print http.DebugInfo("Response")("Status") Debug.Print http.DebugInfo("Error")("Description") End If ``` *** ## 🎯 Events ### OnResponseFinished Triggers when async request response is complete. ```vb Public Event OnResponseFinished() ``` **Example:** ```vb Private WithEvents HttpClient As cHttpClient Private Sub Form_Load() Set HttpClient = New cHttpClient End Sub Private Sub HttpClient_OnResponseFinished() Debug.Print "Request complete: " & HttpClient.ReturnText() End Sub ``` *** **Last Updated**: 2026-05-17 --- --- url: /en/vbman/httpclient/properties.md --- # cHttpClient Properties Reference ## 📝 Request Data Properties ### RequestDataJson Sets JSON format request body data. ```vb Public RequestDataJson As New cJson ``` **Description:** When this property is set and Content-Type is JSON, the request body will be automatically serialized to JSON string. **Example:** ```vb Dim http As New cHttpClient Dim json As New cJson json.AddItem "username", "admin" json.AddItem "password", "123456" Set http.RequestDataJson = json http.SendPost("https://api.example.com/login") ``` *** ### RequestDataForm Sets Form format request body data (form data). ```vb Public RequestDataForm As New Dictionary ``` **Description:** Suitable for `application/x-www-form-urlencoded` type requests. **Example:** ```vb Dim http As New cHttpClient http.RequestDataForm("username") = "admin" http.RequestDataForm("password") = "123456" http.RequestDataForm("remember") = "true" http.SendPost("https://api.example.com/login") ``` *** ### RequestDataQuery Sets URL query parameters. ```vb Public RequestDataQuery As New Dictionary ``` **Description:** Will be automatically appended to URL when sending request. **Example:** ```vb Dim http As New cHttpClient http.RequestDataQuery("page") = "1" http.RequestDataQuery("limit") = "20" http.RequestDataQuery("sort") = "desc" ' Final URL: https://api.example.com/users?page=1&limit=20&sort=desc http.SendGet("https://api.example.com/users") ``` *** ### RequestDataBody **Deprecated** - Please use `RequestDataForm` instead. *** ## 📋 Request Configuration Properties ### RequestHeaders Sets custom request headers. ```vb Public RequestHeaders As New Dictionary ``` **Example:** ```vb Dim http As New cHttpClient http.RequestHeaders("Authorization") = "Bearer token123" http.RequestHeaders("X-Custom-Header") = "custom-value" http.RequestHeaders("User-Agent") = "MyApp/1.0" http.SendGet("https://api.example.com/protected") ``` *** ### RequestContentType Sets request content type. ```vb Public RequestContentType As String ``` **Common Values:** * `application/json` - JSON data * `application/x-www-form-urlencoded` - Form data (default) * `multipart/form-data` - File upload * `text/plain` - Plain text * `text/html` - HTML content **Example:** ```vb Dim http As New cHttpClient http.RequestContentType = "application/json" ' Or use convenience method http.SetRequestContentType(ReqContentTypeJson) ``` *** ### RequestChartSet Sets request encoding. ```vb Public RequestChartSet As String ``` **Default:** `utf-8` **Description:** Affects request body encoding. When set to UTF-8, will use UTF-8 encoding. *** ### RequestTimeOut Sets request timeout (seconds). ```vb Public RequestTimeOut As Long ``` **Default:** 30 seconds **Description:** Only used in sync request mode. **Example:** ```vb Dim http As New cHttpClient http.RequestTimeOut = 60 ' 60 seconds timeout http.SendGet("https://api.example.com/slow-api") ``` *** ## 📥 Response Data Properties ### ResponseRaw Cached raw response content. ```vb Public ResponseRaw As Variant ``` *** ### ResponseHeaders Response headers dictionary. ```vb Public ResponseHeaders As New Dictionary ``` **Example:** ```vb Dim http As New cHttpClient http.SendGet("https://api.example.com") ' Get response header If http.ResponseHeaders.Exists("Content-Type") Then Debug.Print "Content-Type: " & http.ResponseHeaders("Content-Type") End If ' Iterate all response headers Dim key As Variant For Each key In http.ResponseHeaders.Keys Debug.Print key & ": " & http.ResponseHeaders(key) Next ``` *** ### Cookies Parsed Cookies dictionary. ```vb Public Cookies As New Dictionary ``` **Description:** Auto parsed from response header `Set-Cookie`. **Example:** ```vb Dim http As New cHttpClient http.SendGet("https://api.example.com/login") ' Get Cookie If http.Cookies.Exists("session_id") Then Debug.Print "Session ID: " & http.Cookies("session_id") End If ' Carry Cookie in next request http.SetCookies("session_id=" & http.Cookies("session_id")) http.SendGet("https://api.example.com/profile") ``` *** ## ⚙️ Debug Properties ### DebugStart Enables debug mode. ```vb Public DebugStart As Boolean ``` **Description:** After setting to `True`, `DebugInfo` property will be populated after request completes. **Example:** ```vb Dim http As New cHttpClient http.DebugStart = True On Error Resume Next http.SendGet("https://api.example.com") ' View debug info If http.DebugInfo.HasKey("Error") Then Debug.Print "Error: " & http.DebugInfo.GetItem("Error").GetItem("Description") End If ``` *** ### LastError Last error message. ```vb Public LastError As String ``` **Example:** ```vb Dim http As New cHttpClient Dim success As Boolean On Error Resume Next success = http.SendGet("https://invalid-url").ReturnText() <> "" If Not success Then Debug.Print "Request failed: " & http.LastError End If ``` *** **Last Updated**: 2026-05-17 --- --- url: /zh/vbman/httpserver/methods.md --- # cHttpServer 方法参考 ## 🚀 服务器控制方法 ### Start 启动 HTTP 服务器。 ```vb Public Function Start(Optional Port As Long = 80, Optional WebRoot As String = "", Optional IP As String = "0.0.0.0") As Boolean ``` **参数**: * `Port` - 监听端口（默认 80） * `WebRoot` - 静态文件根目录 * `IP` - 监听 IP 地址（默认 0.0.0.0 表示所有接口） **返回**: 成功返回 True，失败返回 False **示例**: ```vb ' 基本启动 If Server.Start(8080) Then Debug.Print "服务器启动成功" End If ' 带静态文件目录 If Server.Start(8080, "C:\WebRoot") Then Debug.Print "服务器启动成功" End If ' 指定 IP If Server.Start(8080, "C:\WebRoot", "127.0.0.1") Then Debug.Print "本地服务器启动成功" End If ``` *** ### StopMe 停止 HTTP 服务器。 ```vb Public Function StopMe() As Boolean ``` **说明**: 关闭所有连接，释放资源。 **示例**: ```vb Private Sub Form_Unload(Cancel As Integer) Server.StopMe Set Server = Nothing End Sub ``` *** ## 🛣️ 路由相关方法（通过 Router 对象） ### Reg 注册控制器。 ```vb Public Function Reg(ControllerName As String, Controller As Object) As Boolean ``` **参数**: * `ControllerName` - 控制器名称 * `Controller` - 控制器对象实例 **示例**: ```vb ' 注册控制器 Call Server.Router.Reg("User", New cUserController) Call Server.Router.Reg("Api", New cApiController) ``` *** ### Add 添加路由规则。 ```vb Public Function Add(RouteName As String, Handler As String, Optional MethodLimit As EnumRouteMethod = Any_) As Boolean ``` **参数**: * `RouteName` - 路由路径（如 "/user"） * `Handler` - 处理程序（格式："控制器名@方法名"） * `MethodLimit` - HTTP 方法限制： * `Any_` - 任意方法（默认） * `OnlyGet` - 仅 GET * `OnlyPost` - 仅 POST * `OnlyPut` - 仅 PUT * `OnlyDelete` - 仅 DELETE **示例**: ```vb ' 基本路由 Call Server.Router.Add("/", "Home@Index") Call Server.Router.Add("/user", "User@List", OnlyGet) Call Server.Router.Add("/user/create", "User@Create", OnlyPost) Call Server.Router.Add("/user/update", "User@Update", OnlyPut) Call Server.Router.Add("/user/delete", "User@Delete", OnlyDelete) ``` *** ## 📡 事件 ### OnAccept 新连接接入时触发。 ```vb Public Event OnAccept(ClientInfo As cHttpServerClientInfo, Disconnect As Boolean) ``` **参数**: * `ClientInfo` - 客户端信息对象 * `Disconnect` - 设置为 True 可拒绝连接 **示例**: ```vb Private Sub Server_OnAccept(ClientInfo As cHttpServerClientInfo, Disconnect As Boolean) Debug.Print "新连接: " & ClientInfo.IP & ":" & ClientInfo.Port ' IP 黑名单检查 If ClientInfo.IP = "192.168.1.100" Then Disconnect = True ' 拒绝连接 End If End Sub ``` *** ### OnLogs 日志事件。 ```vb Public Event OnLogs(ByVal Level As String, ByVal Content As String) ``` **示例**: ```vb Private Sub Server_OnLogs(ByVal Level As String, ByVal Content As String) Debug.Print "[" & Level & "] " & Content End Sub ``` *** ## 🔒 连接管理 ### MaxConnections 最大并发连接数。 ```vb Public MaxConnections As Long ``` **默认值**: 1000 **说明**: 当连接数达到此上限时，新连接将被拒绝（Disconnect = True）。建议根据服务器内存和业务需求调整。 **示例**: ```vb Server.MaxConnections = 500 ' 启动前设置 ``` *** ### MaxRequestSize 最大请求体字节数。 ```vb Public MaxRequestSize As Long ``` **默认值**: 10485760 (10MB) **说明**: 当请求体超过此大小时，连接将被断开并返回 413 状态码。设为 0 表示不限制（不推荐）。 **示例**: ```vb Server.MaxRequestSize = 5242880 ' 5MB ``` *** ### IdleTimeoutSeconds 空闲连接超时秒数。 ```vb Public IdleTimeoutSeconds As Long ``` **默认值**: 120 **说明**: 客户端在此时间内没有发送数据，服务端将主动关闭连接并释放资源。设为 0 表示不检测空闲连接（不推荐用于生产环境）。服务器内置定时器默认每 30 秒自动清理空闲连接，无需外部定时器。也可手动调用 `CleanupIdleConnections()`。 **示例**: ```vb Server.IdleTimeoutSeconds = 60 ' 1 分钟 ``` *** ### ConnectionCount 当前活跃连接数（只读）。 ```vb Public Property Get ConnectionCount() As Long ``` **示例**: ```vb Debug.Print "当前连接数: " & Server.ConnectionCount ``` *** ### CleanupIdleConnections 手动清理空闲连接。 ```vb Public Sub CleanupIdleConnections() ``` **说明**: 遍历连接池，关闭超过 `IdleTimeoutSeconds` 未活动的连接，断开循环引用并释放资源。 > 服务器启动后内置定时器会自动定期调用此方法，通常无需手动调用。 **示例**: ```vb ' 手动触发清理（通常不需要，内置定时器已自动处理） Call Server.CleanupIdleConnections Debug.Print "连接数: " & Server.ConnectionCount ``` *** ### CleanupExpiredSessions 手动清理过期的 Session。 ```vb Public Sub CleanupExpiredSessions() ``` **说明**: 根据存储类型清理过期 Session： * 内存模式：遍历 Session 字典，删除过期项并释放资源 * 文件模式：扫描 Session 目录，删除过期 JSON 文件 * 数据库模式：执行 DELETE 语句删除过期记录 > 服务器启动后内置定时器会自动定期调用此方法，通常无需手动调用。 **示例**: ```vb ' 手动触发清理（通常不需要，内置定时器已自动处理） Call Server.CleanupExpiredSessions ``` *** ### CleanupTimerInterval 内置清理定时器间隔（毫秒）。 ```vb Public Property Get CleanupTimerInterval() As Long Public Property Let CleanupTimerInterval(ByVal value As Long) ``` **默认值**: 30000 (30 秒) **说明**: 服务器启动后自动创建定时器，每隔此时间自动执行 `CleanupIdleConnections` 和 `CleanupExpiredSessions`。设为 0 可禁用内置定时器（不推荐）。服务器运行中修改间隔会自动重启定时器生效。 **示例**: ```vb Server.CleanupTimerInterval = 15000 ' 15 秒清理一次 ' 服务器运行中也可以修改，立即生效 Server.CleanupTimerInterval = 60000 ' 改为 60 秒 ``` *** ## 📄 默认文档配置 ### AddDefaultDocument 添加自定义默认文档。 ```vb Public Sub AddDefaultDocument(FileName As String) ``` **参数**: * `FileName` - 默认文档文件名（如 "home.html"） **说明**: 在 Start 前调用。内置默认文档列表为 `index.html → index.htm → default.html → default.htm`，自定义文档追加到列表末尾。重复添加会自动忽略。 **示例**: ```vb Server.AddDefaultDocument "home.html" Server.AddDefaultDocument "start.html" Server.WebRoot("C:\WebRoot").Start 8080 ' 查找顺序: index.html → index.htm → default.html → default.htm → home.html → start.html ``` *** ## 💾 静态文件缓存 ### MaxCacheFileSize 单文件缓存上限（字节）。 ```vb Public Property Get MaxCacheFileSize() As Long Public Property Let MaxCacheFileSize(ByVal value As Long) ``` **默认值**: 1048576 (1MB) **说明**: 静态文件内容缓存的单文件大小上限。首次访问且文件大小 ≤ 此上限时自动加入内存缓存（懒缓存机制）。超出此上限的文件始终从磁盘读取，但仍享受 ETag/304 协商缓存。设为 0 可禁用内容缓存。可在 Start 前或运行中随时修改。 **示例**: ```vb Server.MaxCacheFileSize = 2097152 ' 2MB Server.MaxCacheFileSize = 0 ' 禁用内容缓存（仅保留ETag/304） ``` *** ### CacheTTLSeconds 缓存 TTL（秒）。 ```vb Public Property Get CacheTTLSeconds() As Long Public Property Let CacheTTLSeconds(ByVal value As Long) ``` **默认值**: 300 (5 分钟) **说明**: 缓存条目的存活时间。过期后不会立即删除，而是下次访问时检查 ETag 是否变化再决定刷新或续期。设为 0 表示永不过期（仅通过 ETag 感知文件更新）。可在 Start 前或运行中随时修改。 **示例**: ```vb Server.CacheTTLSeconds = 600 ' 10 分钟 Server.CacheTTLSeconds = 0 ' 永不过期 ``` *** ### RefreshCache 刷新目录结构缓存。 ```vb Public Sub RefreshCache() ``` **说明**: 部署新文件/新目录到 WebRoot 后手动调用，刷新服务器的目录结构缓存（rootFiles/rootDirs）。不影响文件内容缓存，内容缓存通过 ETag 自动感知文件更新。 **示例**: ```vb ' 部署新文件后刷新 Server.RefreshCache ``` *** ### ClearFileCache 清空所有文件内容缓存。 ```vb Public Sub ClearFileCache() ``` **说明**: 强制清空所有内存中的文件内容缓存，下次访问时重新从磁盘读取。适用于需要强制释放内存的场景。大多数情况下只需 `RefreshCache`，内容缓存会通过 ETag 自动感知文件更新。 **示例**: ```vb ' 强制清空内容缓存 Server.ClearFileCache ``` *** ## 📊 性能统计（Statistics） ### Statistics 对象 `cHttpServerStatistics` 是服务器级性能统计容器，通过 `Server.Statistics` 或 `ctx.Statistics` 访问。所有字段为 `Public Long`，递增操作零开销。 ```vb Public Statistics As cHttpServerStatistics ``` **请求统计字段**: | 字段 | 类型 | 说明 | | ----------------- | ---- | -------------- | | `TotalRequests` | Long | 累计请求总数 | | `GetRequests` | Long | GET 请求数 | | `PostRequests` | Long | POST 请求数 | | `PutRequests` | Long | PUT 请求数 | | `DeleteRequests` | Long | DELETE 请求数 | | `OptionsRequests` | Long | OPTIONS 请求数 | | `HeadRequests` | Long | HEAD 请求数 | | `PatchRequests` | Long | PATCH 请求数 | | `OtherRequests` | Long | 其他方法请求数 | **状态码统计字段**: | 字段 | 类型 | 说明 | | ----------- | ---- | ---------- | | `Status1xx` | Long | 1xx 响应数 | | `Status2xx` | Long | 2xx 响应数 | | `Status3xx` | Long | 3xx 响应数 | | `Status4xx` | Long | 4xx 响应数 | | `Status5xx` | Long | 5xx 响应数 | **连接统计字段**: | 字段 | 类型 | 说明 | | -------------------------- | ---- | -------------------------------- | | `TotalConnectionsAccepted` | Long | 累计接受连接总数 | | `RejectedConnections` | Long | 因 MaxConnections 被拒绝的连接数 | | `PeakConnections` | Long | 峰值并发连接数 | | `IdleConnectionsCleaned` | Long | 因空闲超时被清理的连接数 | **错误统计字段**: | 字段 | 类型 | 说明 | | --------------------- | ---- | -------------------------- | | `RequestErrors` | Long | 请求处理异常次数 | | `RequestSizeRejected` | Long | 413 Payload Too Large 次数 | | `SSEEntryErrors` | Long | SSE Entry 失败次数 | **流量统计字段**: | 字段 | 类型 | 说明 | | -------------------- | ---- | -------------- | | `TotalBytesReceived` | Long | 累计接收字节数 | | `TotalBytesSent` | Long | 累计发送字节数 | **SSE/Session/时间统计字段**: | 字段 | 类型 | 说明 | | ------------------------ | ---- | ----------------------- | | `SSEConnectionsAccepted` | Long | SSE 连接总数 | | `TotalSessionsCreated` | Long | 累计创建的 Session 总数 | | `StartTime` | Date | 服务器启动时间 | **计算属性**: | 属性 | 类型 | 说明 | | --------------- | --------------------- | -------------------- | | `UptimeSeconds` | Long (Property Get) | 服务器运行时长（秒） | | `AverageQPS` | Double (Property Get) | 每秒平均请求数 | **方法**: | 方法 | 说明 | | --------- | ---------------------------------------- | | `Reset()` | 重置所有统计计数器，StartTime 重置为 Now | **示例**: ```vb ' 在控制器中读取统计 Public Sub GetStats(ctx As cHttpServerContext) Dim stats As cHttpServerStatistics Set stats = ctx.Statistics Dim result As New Dictionary result("total_requests") = stats.TotalRequests result("get_requests") = stats.GetRequests result("post_requests") = stats.PostRequests result("status_2xx") = stats.Status2xx result("status_4xx") = stats.Status4xx result("status_5xx") = stats.Status5xx result("peak_connections") = stats.PeakConnections result("uptime_seconds") = stats.UptimeSeconds result("average_qps") = stats.AverageQPS ctx.Response.Json result, 0, "Success" End Sub ' 也可以通过 Server 直接访问 Debug.Print "Total: " & Server.Statistics.TotalRequests Debug.Print "QPS: " & Server.Statistics.AverageQPS ' 重置统计 Server.Statistics.Reset ``` *** ## 🔧 控制器方法编写规范 控制器方法接收一个上下文参数，包含请求和响应对象： ```vb Public Sub ActionName(ctx As cHttpServerContext) ' ctx.Request - 请求对象 ' ctx.Response - 响应对象 ' ctx.Session - Session 对象 ' ctx.Cookies - Cookies 对象 ' ctx.Db - 数据库对象（如果配置了） End Sub ``` **示例控制器**: ```vb ' cUserController.cls Option Explicit ' GET /user Public Sub List(ctx As cHttpServerContext) Dim users As New Dictionary users("items") = Array("张三", "李四", "王五") users("total") = 3 ctx.Response.Json users, 0, "Success" End Sub ' POST /user/create Public Sub Create(ctx As cHttpServerContext) ' 获取 POST 数据 Dim username As String username = ctx.Request.Form("username") ' 获取 JSON 数据 ' username = ctx.Request.Json.GetItem("username") ctx.Response.Json Nothing, 0, "创建成功" End Sub ' GET /user?id=1 Public Sub Detail(ctx As cHttpServerContext) Dim id As String id = ctx.Request.QueryString("id") Dim user As New Dictionary user("id") = id user("name") = "张三" ctx.Response.Json user End Sub ``` *** ## 📦 上下文对象属性 ### cHttpServerContext | 属性 | 类型 | 说明 | | ------------ | --------------------- | -------------------------------- | | `Request` | cHttpServerRequest | 请求对象 | | `Response` | cHttpServerResponse | 响应对象 | | `Session` | cHttpServerSession | Session 对象 | | `Cookies` | cHttpServerCookies | Cookies 对象 | | `Db` | cDataBase | 数据库对象 | | `Server` | cHttpServerSvr | 服务器配置 | | `ClientInfo` | cHttpServerClientInfo | 客户端信息 | | `Statistics` | cHttpServerStatistics | 性能统计对象（服务器级单例引用） | *** **最后更新**: 2026-06-22 --- --- url: /zh/vbman/httpserver/overview.md --- # cHttpServer 组件概述 ## 简介 `cHttpServer` 是一个基于 VB6 的 HTTP 服务器组件，提供完整的 Web 服务器功能，支持路由、Session、Cookie、静态文件服务、SSE (Server-Sent Events)、跨域处理等特性。 ## 特性 | 特性 | 说明 | | ---------------- | --------------------------------------------------- | | **HTTP 服务** | 支持 GET/POST/PUT/DELETE/OPTIONS 方法 | | **路由系统** | 支持手动路由注册、参数路由 `{param}` 和自动路由 | | **Session 管理** | 支持内存、文件系统、数据库三种存储方式 | | **Cookie 处理** | 完整的 Cookie 解析和设置 | | **静态文件** | 自动提供静态文件服务，内置默认文档、目录重定向 | | **静态文件缓存** | 懒内容缓存 + ETag/304 协商缓存，自动感知文件更新 | | **SSE 支持** | Server-Sent Events 实时推送 | | **跨域处理** | 内置 CORS 跨域支持 | | **HTTPS/TLS** | 链式函数配置 TLS 证书，支持 PFX/PEM/Windows证书存储 | | **MVC 架构** | 支持控制器-视图-模式开发 | | **粘包处理** | 自动处理 TCP 粘包问题 | | **连接管理** | 最大连接数限制、空闲超时清理、请求体大小限制 | ## 架构概览 ``` ┌─────────────────────────────────────────────────────────┐ │ cHttpServer │ │ ┌─────────────┐ ┌─────────────┐ ┌─────────────┐ │ │ │ Router │ │ Session │ │ SSE │ │ │ │ (路由系统) │ │ (会话管理) │ │(实时推送) │ │ │ └─────────────┘ └─────────────┘ └─────────────┘ │ │ ┌─────────────┐ ┌─────────────┐ ┌─────────────┐ │ │ │ Request │ │ Response │ │ Context │ │ │ │ (请求对象) │ │ (响应对象) │ │ (上下文) │ │ │ └─────────────┘ └─────────────┘ └─────────────┘ │ └─────────────────────────────────────────────────────────┘ ``` ## 快速开始 ### 最小 HTTP 服务器 ```vb Private WithEvents Server As cHttpServer Private Sub Form_Load() Set Server = New cHttpServer ' 注册控制器 Call Server.Router.Reg("Home", New cHomeController) ' 精确路由 Call Server.Router.Add("/", "Home@Index") Call Server.Router.Add("/user", "Home@User", OnlyGet) ' 参数路由 Call Server.Router.Add("/api/user/{id}", "Home@GetUser", OnlyGet) Call Server.Router.Add("/api/user/{userId}/post/{postId}", "Home@GetPost", OnlyGet) ' 启动服务器 If Server.WebRoot("C:\WebRoot").Start(8080) Then Debug.Print "服务器启动成功: http://localhost:8080" Else Debug.Print "启动失败: " & Server.LastError End If End Sub Private Sub Form_Unload(Cancel As Integer) Server.StopMe End Sub ' 控制器示例 Public Sub Index(ctx As cHttpServerContext) ctx.Response.Html "

    Hello World!

    " End Sub Public Sub GetUser(ctx As cHttpServerContext) ' 通过参数路由获取 id Dim id As String id = ctx.Request.RouteParams("id") ctx.Response.Json Array("userId" & id) End Sub Public Sub GetPost(ctx As cHttpServerContext) ' 多参数路由 Dim uid As String, pid As String uid = ctx.Request.RouteParams("userId") pid = ctx.Request.RouteParams("postId") ctx.Response.Json Array(uid, pid) End Sub Public Sub Api(ctx As cHttpServerContext) Dim data As New Dictionary data("message") = "Success" data("time") = Now ctx.Response.Json data, 0, "OK" End Sub ``` ### Session 配置 ```vb Private Sub Form_Load() Set Server = New cHttpServer ' 配置 Session 存储方式 Server.SessionStorageType = SessionStorageFileSystem ' 文件存储 Server.SessionStoragePath = "C:\Sessions" ' 存储路径 Server.SessionCookieName = "MY_SESSIONID" ' Cookie 名称 ' 或使用数据库存储 ' Server.SessionStorageType = SessionStorageDatabase ' Server.SessionStoragePath = "sessions_table" Call Server.WebRoot("C:\WebRoot").Start(8080) End Sub ``` ### 连接管理配置 ```vb Private Sub Form_Load() Set Server = New cHttpServer ' 生产环境建议配置 Server.MaxConnections = 500 ' 最大并发连接数（默认 1000） Server.MaxRequestSize = 5242880 ' 最大请求体 5MB（默认 10MB） Server.IdleTimeoutSeconds = 60 ' 空闲超时 60 秒（默认 120） Server.CleanupTimerInterval = 15000 ' 每 15 秒自动清理（默认 30 秒） Call Server.WebRoot("C:\WebRoot").Start(8080) End Sub ' 监控当前连接数 Debug.Print "当前连接数: " & Server.ConnectionCount ' 注：内置定时器会自动清理空闲连接和过期 Session，无需外部定时器 Call Server.CleanupIdleConnections ``` ### HTTPS 配置 ```vb ' 使用 PEM 证书启动 HTTPS Server.TlsCertFile("C:\certs\fullchain.pem|C:\certs\privkey.pem").Start 443 ' 使用 PFX 证书 + WebRoot Server.TlsCertFile("C:\certs\server.pfx", "password").WebRoot("C:\www").Start 443 ' HTTP + HTTPS 双端口 Dim httpSvr As New cHttpServer httpSvr.WebRoot("C:\www").Start 80 Dim httpsSvr As New cHttpServer httpsSvr.TlsCertFile("C:\certs\server.pfx", "pwd").WebRoot("C:\www").Start 443 ``` 详见 [TLS/HTTPS 支持](./tls.md) | [证书模式详解](../tls/overview.md) ### 跨域配置 ```vb Private Sub Form_Load() Set Server = New cHttpServer ' 启用跨域 Server.CrossDomain.Enable = True Server.CrossDomain.AllowOrigin = "*" Server.CrossDomain.AllowMethods = "GET, POST, PUT, DELETE" Server.CrossDomain.AllowHeaders = "Content-Type, Authorization" Server.CrossDomain.AllowCredentials = True Call Server.Start(8080) End Sub ``` ## 文件结构 | 文件 | 说明 | | ------------------------------- | ----------------------------------- | | `cHttpServer.cls` | 主服务器类 | | `cHttpServerRouter.cls` | 路由器（支持精确匹配和参数路由） | | `cHttpServerRouteItem.cls` | 路由项（参数路由模式解析与匹配） | | `cHttpServerRequest.cls` | 请求对象 | | `cHttpServerResponse.cls` | 响应对象（含 ETag/304/懒缓存） | | `cHttpServerSession.cls` | Session 管理 | | `cHttpServerCookies.cls` | Cookie 管理 | | `cHttpServerContext.cls` | 上下文对象 | | `cHttpServerClientInfo.cls` | 客户端信息 | | `cHttpServerFileCacheEntry.cls` | 静态文件缓存条目（内容+ETag+时间） | | `cHttpServerRouteBefore.cls` | 前置路由 | | `cHttpServerRouterAfter.cls` | 后置路由 | | `cHttpCrossDomain.cls` | 跨域处理 | | `cClientCallback.cls` | 连接回调（Socket 事件、缓冲区管理） | ## 引用组件 * `cTlsReMaster.cls` - TLS/网络通信 * `cJson.cls` - JSON 处理 * `cScriptEngine.cls` - 脚本引擎 * `cDataBase.cls` - 数据库（可选） * `cSSE.cls` - SSE 支持 ## 连接管理属性 | 属性 | 类型 | 默认值 | 说明 | | ---------------------- | ----------- | --------------- | ---------------------------------------------------------- | | `MaxConnections` | Long | 1000 | 最大并发连接数，超限拒绝新连接 | | `MaxRequestSize` | Long | 10485760 (10MB) | 最大请求体字节数，超限断开连接 | | `IdleTimeoutSeconds` | Long | 120 | 空闲连接超时秒数，0 表示不检测 | | `ConnectionCount` | Long (只读) | - | 当前活跃连接数 | | `CleanupTimerInterval` | Long | 30000 (30秒) | 内置清理定时器间隔（毫秒），自动清理空闲连接和过期 Session | | `MaxCacheFileSize` | Long | 1048576 (1MB) | 静态文件单文件缓存上限字节，0=禁用内容缓存 | | `CacheTTLSeconds` | Long | 300 (5分钟) | 缓存TTL秒数，过期后检查ETag决定刷新 | | 方法 | 说明 | | ------------------------------ | ------------------------------------ | | `AddDefaultDocument(FileName)` | 添加自定义默认文档 | | `RefreshCache()` | 刷新目录结构缓存（部署新文件后调用） | | `ClearFileCache()` | 清空所有文件内容缓存（强制释放内存） | 详细说明参见 [方法参考](./methods.md) | [安全实践](./security.md) *** **最后更新**: 2026-06-22 --- --- url: /en/vbman/httpserver/overview.md --- # cHttpServer Component Overview ## Introduction `cHttpServer` is an HTTP server component based on VB6 that provides complete Web server functionality, supporting routing, session, cookie, static file service, SSE (Server-Sent Events), CORS handling, and more. ## Features | Feature | Description | | ------------------------- | ---------------------------------------------------------------------------------------- | | **HTTP Service** | Supports GET/POST/PUT/DELETE/OPTIONS methods | | **Router System** | Supports manual route registration, parameter routing `{param}`, and auto routing | | **Session Management** | Supports memory, file system, database storage | | **Cookie Handling** | Complete cookie parsing and setting | | **Static Files** | Auto serve static files, built-in default documents and directory redirect | | **Static File Cache** | Lazy content cache + ETag/304 negotiated cache, auto-sense file updates | | **SSE Support** | Server-Sent Events real-time push | | **CORS Handling** | Built-in CORS support | | **HTTPS/TLS** | Chain-function TLS certificate configuration, supports PFX/PEM/Windows certificate store | | **MVC Architecture** | Supports controller-view-model development | | **Packet Coalescing** | Auto handles TCP packet coalescing | | **Connection Management** | Max connections limit, idle timeout cleanup, request body size limit | ## Architecture Overview ``` ┌─────────────────────────────────────────────────────────┐ │ cHttpServer │ │ ┌─────────────┐ ┌─────────────┐ ┌─────────────┐ │ │ │ Router │ │ Session │ │ SSE │ │ │ │ (Router) │ │ (Session) │ │(Real-time) │ │ │ └─────────────┘ └─────────────┘ └─────────────┘ │ │ ┌─────────────┐ ┌─────────────┐ ┌─────────────┐ │ │ │ Request │ │ Response │ │ Context │ │ │ │(Request Obj)│ │ (Response) │ │ (Context) │ │ │ └─────────────┘ └─────────────┘ └─────────────┘ │ └─────────────────────────────────────────────────────────┘ ``` ## Quick Start ### Minimal HTTP Server ```vb Private WithEvents Server As cHttpServer Private Sub Form_Load() Set Server = New cHttpServer ' Register controller Call Server.Router.Reg("Home", New cHomeController) ' Exact routes Call Server.Router.Add("/", "Home@Index") Call Server.Router.Add("/user", "Home@User", OnlyGet) ' Parameter routes Call Server.Router.Add("/api/user/{id}", "Home@GetUser", OnlyGet) Call Server.Router.Add("/api/user/{userId}/post/{postId}", "Home@GetPost", OnlyGet) ' Start server If Server.WebRoot("C:\WebRoot").Start(8080) Then Debug.Print "Server started: http://localhost:8080" Else Debug.Print "Start failed: " & Server.LastError End If End Sub Private Sub Form_Unload(Cancel As Integer) Server.StopMe End Sub ' Controller example Public Sub Index(ctx As cHttpServerContext) ctx.Response.Html "

    Hello World!

    " End Sub Public Sub GetUser(ctx As cHttpServerContext) ' Get id via parameter route Dim id As String id = ctx.Request.RouteParams("id") ctx.Response.Json Array("userId" & id) End Sub Public Sub GetPost(ctx As cHttpServerContext) ' Multi-parameter route Dim uid As String, pid As String uid = ctx.Request.RouteParams("userId") pid = ctx.Request.RouteParams("postId") ctx.Response.Json Array(uid, pid) End Sub Public Sub Api(ctx As cHttpServerContext) Dim data As New Dictionary data("message") = "Success" data("time") = Now ctx.Response.Json data, 0, "OK" End Sub ``` ### Session Configuration ```vb Private Sub Form_Load() Set Server = New cHttpServer ' Configure Session storage type Server.SessionStorageType = SessionStorageFileSystem ' File storage Server.SessionStoragePath = "C:\Sessions" ' Storage path Server.SessionCookieName = "MY_SESSIONID" ' Cookie name ' Or use database storage ' Server.SessionStorageType = SessionStorageDatabase ' Server.SessionStoragePath = "sessions_table" Call Server.WebRoot("C:\WebRoot").Start(8080) End Sub ``` ### Connection Management Configuration ```vb Private Sub Form_Load() Set Server = New cHttpServer ' Recommended production configuration Server.MaxConnections = 500 ' Max concurrent connections (default 1000) Server.MaxRequestSize = 5242880 ' Max request body 5MB (default 10MB) Server.IdleTimeoutSeconds = 60 ' Idle timeout 60 seconds (default 120) Server.CleanupTimerInterval = 15000 ' Auto cleanup every 15 seconds (default 30 seconds) Call Server.WebRoot("C:\WebRoot").Start(8080) End Sub ' Monitor current connection count Debug.Print "Current connections: " & Server.ConnectionCount ' Note: Built-in timer automatically cleans up idle connections and expired sessions, no external timer needed Call Server.CleanupIdleConnections ``` ### HTTPS Configuration ```vb ' Start HTTPS with PEM certificates Server.TlsCertFile("C:\certs\fullchain.pem|C:\certs\privkey.pem").Start 443 ' Start HTTPS with PFX certificate + WebRoot Server.TlsCertFile("C:\certs\server.pfx", "password").WebRoot("C:\www").Start 443 ' HTTP + HTTPS dual port Dim httpSvr As New cHttpServer httpSvr.WebRoot("C:\www").Start 80 Dim httpsSvr As New cHttpServer httpsSvr.TlsCertFile("C:\certs\server.pfx", "pwd").WebRoot("C:\www").Start 443 ``` See [TLS/HTTPS Support](./tls.md) | [Certificate Modes](../tls/overview.md) ### CORS Configuration ```vb Private Sub Form_Load() Set Server = New cHttpServer ' Enable CORS Server.CrossDomain.Enable = True Server.CrossDomain.AllowOrigin = "*" Server.CrossDomain.AllowMethods = "GET, POST, PUT, DELETE" Server.CrossDomain.AllowHeaders = "Content-Type, Authorization" Server.CrossDomain.AllowCredentials = True Call Server.Start(8080) End Sub ``` ## File Structure | File | Description | | ------------------------------- | --------------------------------------------------------- | | `cHttpServer.cls` | Main server class | | `cHttpServerRouter.cls` | Router (supports exact matching and parameter routing) | | `cHttpServerRouteItem.cls` | Route item (parameter route pattern parsing and matching) | | `cHttpServerRequest.cls` | Request object | | `cHttpServerResponse.cls` | Response object (with ETag/304/lazy cache) | | `cHttpServerSession.cls` | Session management | | `cHttpServerCookies.cls` | Cookie management | | `cHttpServerContext.cls` | Context object | | `cHttpServerClientInfo.cls` | Client info | | `cHttpServerFileCacheEntry.cls` | Static file cache entry (content+ETag+time) | | `cHttpServerRouteBefore.cls` | Before route | | `cHttpServerRouterAfter.cls` | After route | | `cHttpCrossDomain.cls` | CORS handling | | `cClientCallback.cls` | Connection callback (Socket events, buffer management) | ## References * `cTlsReMaster.cls` - TLS/Network communication * `cJson.cls` - JSON handling * `cScriptEngine.cls` - Script engine * `cDataBase.cls` - Database (optional) * `cSSE.cls` - SSE support ## Connection Management Properties | Property | Type | Default | Description | | ---------------------- | ---------------- | --------------- | --------------------------------------------------------------------------------------- | | `MaxConnections` | Long | 1000 | Max concurrent connections, reject new when exceeded | | `MaxRequestSize` | Long | 10485760 (10MB) | Max request body size in bytes, disconnect when exceeded | | `IdleTimeoutSeconds` | Long | 120 | Idle connection timeout in seconds, 0 means no checking | | `ConnectionCount` | Long (read-only) | - | Current active connection count | | `CleanupTimerInterval` | Long | 30000 (30s) | Built-in cleanup timer interval (ms), auto cleans idle connections and expired sessions | | `MaxCacheFileSize` | Long | 1048576 (1MB) | Static file single-file cache limit in bytes, 0=disable content cache | | `CacheTTLSeconds` | Long | 300 (5min) | Cache TTL in seconds, check ETag after expiry to decide refresh | | Method | Description | | ------------------------------ | ------------------------------------------------------------------ | | `AddDefaultDocument(FileName)` | Add custom default document | | `RefreshCache()` | Refresh directory structure cache (call after deploying new files) | | `ClearFileCache()` | Clear all file content cache (force release memory) | See [Methods Reference](./methods.md) | [Security Practices](./security.md) *** **Last Updated**: 2026-06-22 --- --- url: /en/vbman/httpserver/methods.md --- # cHttpServer Methods Reference ## 🚀 Server Control Methods ### Start Starts HTTP server. ```vb Public Function Start(Optional Port As Long = 80, Optional WebRoot As String = "", Optional IP As String = "0.0.0.0") As Boolean ``` **Parameters:** * `Port` - Listen port (default 80) * `WebRoot` - Static file root directory * `IP` - Listen IP address (default 0.0.0.0 means all interfaces) **Returns:** Returns True on success, False on failure **Example:** ```vb ' Basic start If Server.Start(8080) Then Debug.Print "Server started successfully" End If ' With static file directory If Server.Start(8080, "C:\WebRoot") Then Debug.Print "Server started successfully" End If ' Specify IP If Server.Start(8080, "C:\WebRoot", "127.0.0.1") Then Debug.Print "Local server started successfully" End If ``` *** ### StopMe Stops HTTP server. ```vb Public Function StopMe() As Boolean ``` **Description:** Closes all connections, releases resources. **Example:** ```vb Private Sub Form_Unload(Cancel As Integer) Server.StopMe Set Server = Nothing End Sub ``` *** ## 🛣️ Route-Related Methods (via Router Object) ### Reg Registers a controller. ```vb Public Function Reg(ControllerName As String, Controller As Object) As Boolean ``` **Parameters:** * `ControllerName` - Controller name * `Controller` - Controller object instance **Example:** ```vb ' Register controllers Call Server.Router.Reg("User", New cUserController) Call Server.Router.Reg("Api", New cApiController) ``` *** ### Add Adds route rule. ```vb Public Function Add(RouteName As String, Handler As String, Optional MethodLimit As EnumRouteMethod = Any_) As Boolean ``` **Parameters:** * `RouteName` - Route path (e.g., "/user") * `Handler` - Handler (format: "ControllerName@MethodName") * `MethodLimit` - HTTP method limit: * `Any_` - Any method (default) * `OnlyGet` - GET only * `OnlyPost` - POST only * `OnlyPut` - PUT only * `OnlyDelete` - DELETE only **Example:** ```vb ' Basic routes Call Server.Router.Add("/", "Home@Index") Call Server.Router.Add("/user", "User@List", OnlyGet) Call Server.Router.Add("/user/create", "User@Create", OnlyPost) Call Server.Router.Add("/user/update", "User@Update", OnlyPut) Call Server.Router.Add("/user/delete", "User@Delete", OnlyDelete) ``` *** ## 📡 Events ### OnAccept Triggers when new connection is accepted. ```vb Public Event OnAccept(ClientInfo As cHttpServerClientInfo, Disconnect As Boolean) ``` **Parameters:** * `ClientInfo` - Client info object * `Disconnect` - Set to True to reject connection **Example:** ```vb Private Sub Server_OnAccept(ClientInfo As cHttpServerClientInfo, Disconnect As Boolean) Debug.Print "New connection: " & ClientInfo.IP & ":" & ClientInfo.Port ' IP blacklist check If ClientInfo.IP = "192.168.1.100" Then Disconnect = True ' Reject connection End If End Sub ``` *** ### OnLogs Log event. ```vb Public Event OnLogs(ByVal Level As String, ByVal Content As String) ``` **Example:** ```vb Private Sub Server_OnLogs(ByVal Level As String, ByVal Content As String) Debug.Print "[" & Level & "] " & Content End Sub ``` *** ## 🔒 Connection Management ### MaxConnections Maximum concurrent connections. ```vb Public MaxConnections As Long ``` **Default:** 1000 **Description:** When the number of connections reaches this limit, new connections will be rejected (Disconnect = True). Adjust according to server memory and business requirements. **Example:** ```vb Server.MaxConnections = 500 ' Set before starting ``` *** ### MaxRequestSize Maximum request body size in bytes. ```vb Public MaxRequestSize As Long ``` **Default:** 10485760 (10MB) **Description:** When the request body exceeds this size, the connection will be closed and a 413 status code returned. Set to 0 for no limit (not recommended). **Example:** ```vb Server.MaxRequestSize = 5242880 ' 5MB ``` *** ### IdleTimeoutSeconds Idle connection timeout in seconds. ```vb Public IdleTimeoutSeconds As Long ``` **Default:** 120 **Description:** If the client does not send data within this time, the server will actively close the connection and release resources. Set to 0 to disable idle checking (not recommended for production). The built-in timer automatically cleans up idle connections every 30 seconds by default, no external timer needed. You can also manually call `CleanupIdleConnections()`. **Example:** ```vb Server.IdleTimeoutSeconds = 60 ' 1 minute ``` *** ### ConnectionCount Current active connection count (read-only). ```vb Public Property Get ConnectionCount() As Long ``` **Example:** ```vb Debug.Print "Current connections: " & Server.ConnectionCount ``` *** ### CleanupIdleConnections Manually clean up idle connections. ```vb Public Sub CleanupIdleConnections() ``` **Description:** Iterates through the connection pool, closes connections inactive beyond `IdleTimeoutSeconds`, breaks circular references, and releases resources. > The server's built-in timer automatically calls this method periodically after startup, manual invocation is typically unnecessary. **Example:** ```vb ' Manual cleanup (usually not needed, built-in timer handles it) Call Server.CleanupIdleConnections Debug.Print "Connections: " & Server.ConnectionCount ``` *** ### CleanupExpiredSessions Manually clean up expired sessions. ```vb Public Sub CleanupExpiredSessions() ``` **Description:** Cleans up expired sessions based on storage type: * Memory mode: Iterate session dictionary, delete expired items and release resources * File mode: Scan session directory, delete expired JSON files * Database mode: Execute DELETE statement to remove expired records > The server's built-in timer automatically calls this method periodically after startup, manual invocation is typically unnecessary. **Example:** ```vb ' Manual cleanup (usually not needed, built-in timer handles it) Call Server.CleanupExpiredSessions ``` *** ### CleanupTimerInterval Built-in cleanup timer interval (milliseconds). ```vb Public Property Get CleanupTimerInterval() As Long Public Property Let CleanupTimerInterval(ByVal value As Long) ``` **Default:** 30000 (30 seconds) **Description:** After the server starts, a timer is automatically created that executes `CleanupIdleConnections` and `CleanupExpiredSessions` at this interval. Set to 0 to disable the built-in timer (not recommended). Changing the interval while the server is running will automatically restart the timer. **Example:** ```vb Server.CleanupTimerInterval = 15000 ' Clean up every 15 seconds ' Can also be modified while server is running, takes effect immediately Server.CleanupTimerInterval = 60000 ' Change to 60 seconds ``` *** ## 📄 Default Document Configuration ### AddDefaultDocument Add custom default document. ```vb Public Sub AddDefaultDocument(FileName As String) ``` **Parameters:** * `FileName` - Default document filename (e.g., "home.html") **Description:** Call before Start. Built-in default document list is `index.html → index.htm → default.html → default.htm`, custom documents are appended to the end. Duplicate additions are automatically ignored. **Example:** ```vb Server.AddDefaultDocument "home.html" Server.AddDefaultDocument "start.html" Server.WebRoot("C:\WebRoot").Start 8080 ' Lookup order: index.html → index.htm → default.html → default.htm → home.html → start.html ``` *** ## 💾 Static File Cache ### MaxCacheFileSize Single file cache limit (bytes). ```vb Public Property Get MaxCacheFileSize() As Long Public Property Let MaxCacheFileSize(ByVal value As Long) ``` **Default:** 1048576 (1MB) **Description:** The single file size limit for static file content cache. On first access, if file size ≤ this limit, it's automatically added to memory cache (lazy cache mechanism). Files exceeding this limit are always read from disk, but still enjoy ETag/304 negotiated cache. Set to 0 to disable content cache. Can be modified before Start or at runtime. **Example:** ```vb Server.MaxCacheFileSize = 2097152 ' 2MB Server.MaxCacheFileSize = 0 ' Disable content cache (keep ETag/304 only) ``` *** ### CacheTTLSeconds Cache TTL (seconds). ```vb Public Property Get CacheTTLSeconds() As Long Public Property Let CacheTTLSeconds(ByVal value As Long) ``` **Default:** 300 (5 minutes) **Description:** The lifetime of cache entries. After expiry, entries are not immediately deleted; instead, on next access, the ETag is checked to determine whether to refresh or renew. Set to 0 for never expire (file updates sensed only via ETag). Can be modified before Start or at runtime. **Example:** ```vb Server.CacheTTLSeconds = 600 ' 10 minutes Server.CacheTTLSeconds = 0 ' Never expire ``` *** ### RefreshCache Refresh directory structure cache. ```vb Public Sub RefreshCache() ``` **Description:** Manually call after deploying new files/directories to WebRoot to refresh the server's directory structure cache (rootFiles/rootDirs). Does not affect file content cache, which senses file updates via ETag automatically. **Example:** ```vb ' Refresh after deploying new files Server.RefreshCache ``` *** ### ClearFileCache Clear all file content cache. ```vb Public Sub ClearFileCache() ``` **Description:** Force clear all in-memory file content cache, next access will re-read from disk. Suitable for scenarios requiring forced memory release. In most cases, only `RefreshCache` is needed, content cache senses file updates via ETag automatically. **Example:** ```vb ' Force clear content cache Server.ClearFileCache ``` *** ## 📊 Performance Statistics (Statistics) ### Statistics Object `cHttpServerStatistics` is the server-level performance statistics container, accessible via `Server.Statistics` or `ctx.Statistics`. All fields are `Public Long`, with zero-overhead increment operations. ```vb Public Statistics As cHttpServerStatistics ``` **Request Statistics Fields**: | Field | Type | Description | | ----------------- | ---- | -------------------------- | | `TotalRequests` | Long | Cumulative total requests | | `GetRequests` | Long | GET request count | | `PostRequests` | Long | POST request count | | `PutRequests` | Long | PUT request count | | `DeleteRequests` | Long | DELETE request count | | `OptionsRequests` | Long | OPTIONS request count | | `HeadRequests` | Long | HEAD request count | | `PatchRequests` | Long | PATCH request count | | `OtherRequests` | Long | Other method request count | **Status Code Statistics Fields**: | Field | Type | Description | | ----------- | ---- | ------------------ | | `Status1xx` | Long | 1xx response count | | `Status2xx` | Long | 2xx response count | | `Status3xx` | Long | 3xx response count | | `Status4xx` | Long | 4xx response count | | `Status5xx` | Long | 5xx response count | **Connection Statistics Fields**: | Field | Type | Description | | -------------------------- | ---- | ------------------------------------------ | | `TotalConnectionsAccepted` | Long | Cumulative total connections accepted | | `RejectedConnections` | Long | Connections rejected due to MaxConnections | | `PeakConnections` | Long | Peak concurrent connections | | `IdleConnectionsCleaned` | Long | Connections cleaned due to idle timeout | **Error Statistics Fields**: | Field | Type | Description | | --------------------- | ---- | ----------------------------- | | `RequestErrors` | Long | Request processing exceptions | | `RequestSizeRejected` | Long | 413 Payload Too Large count | | `SSEEntryErrors` | Long | SSE Entry failure count | **Traffic Statistics Fields**: | Field | Type | Description | | -------------------- | ---- | ------------------------- | | `TotalBytesReceived` | Long | Cumulative bytes received | | `TotalBytesSent` | Long | Cumulative bytes sent | **SSE/Session/Time Statistics Fields**: | Field | Type | Description | | ------------------------ | ---- | --------------------------------- | | `SSEConnectionsAccepted` | Long | Total SSE connections | | `TotalSessionsCreated` | Long | Cumulative total sessions created | | `StartTime` | Date | Server start time | **Computed Properties**: | Property | Type | Description | | --------------- | --------------------- | --------------------------- | | `UptimeSeconds` | Long (Property Get) | Server uptime in seconds | | `AverageQPS` | Double (Property Get) | Average requests per second | **Methods**: | Method | Description | | --------- | ----------------------------------------------------- | | `Reset()` | Reset all statistics counters, StartTime reset to Now | **Example:** ```vb ' Read statistics in controller Public Sub GetStats(ctx As cHttpServerContext) Dim stats As cHttpServerStatistics Set stats = ctx.Statistics Dim result As New Dictionary result("total_requests") = stats.TotalRequests result("get_requests") = stats.GetRequests result("post_requests") = stats.PostRequests result("status_2xx") = stats.Status2xx result("status_4xx") = stats.Status4xx result("status_5xx") = stats.Status5xx result("peak_connections") = stats.PeakConnections result("uptime_seconds") = stats.UptimeSeconds result("average_qps") = stats.AverageQPS ctx.Response.Json result, 0, "Success" End Sub ' Also accessible via Server directly Debug.Print "Total: " & Server.Statistics.TotalRequests Debug.Print "QPS: " & Server.Statistics.AverageQPS ' Reset statistics Server.Statistics.Reset ``` *** ## 🔧 Controller Method Writing Specification Controller methods receive one context parameter containing request and response objects: ```vb Public Sub ActionName(ctx As cHttpServerContext) ' ctx.Request - Request object ' ctx.Response - Response object ' ctx.Session - Session object ' ctx.Cookies - Cookies object ' ctx.Db - Database object (if configured) End Sub ``` **Example Controller:** ```vb ' cUserController.cls Option Explicit ' GET /user Public Sub List(ctx As cHttpServerContext) Dim users As New Dictionary users("items") = Array("John", "Jane", "Bob") users("total") = 3 ctx.Response.Json users, 0, "Success" End Sub ' POST /user/create Public Sub Create(ctx As cHttpServerContext) ' Get POST data Dim username As String username = ctx.Request.Form("username") ' Get JSON data ' username = ctx.Request.Json.GetItem("username") ctx.Response.Json Nothing, 0, "Created successfully" End Sub ' GET /user?id=1 Public Sub Detail(ctx As cHttpServerContext) Dim id As String id = ctx.Request.QueryString("id") Dim user As New Dictionary user("id") = id user("name") = "John" ctx.Response.Json user End Sub ``` *** ## 📦 Context Object Properties ### cHttpServerContext | Property | Type | Description | | ------------ | --------------------- | ---------------------------------------------------------------- | | `Request` | cHttpServerRequest | Request object | | `Response` | cHttpServerResponse | Response object | | `Session` | cHttpServerSession | Session object | | `Cookies` | cHttpServerCookies | Cookies object | | `Db` | cDataBase | Database object | | `Server` | cHttpServerSvr | Server config | | `ClientInfo` | cHttpServerClientInfo | Client info | | `Statistics` | cHttpServerStatistics | Performance statistics object (server-level singleton reference) | *** **Last Updated**: 2026-06-22 --- --- url: /zh/vbman/httpserver/tls.md --- # cHttpServer TLS/HTTPS 支持 ## 概述 `cHttpServer` 支持通过链式函数配置 TLS 证书，将 HTTP 服务升级为 HTTPS。底层使用 `cTlsReMaster`（基于 cTlsSocket），支持 TLS 1.2/1.3。 ## 链式函数 ### TlsCertFile — 证书文件模式 最常用方式，支持 PFX/P12 和 PEM 格式。 ```vb Public Function TlsCertFile( _ ByVal CertFile As String, _ Optional ByVal Password As String, _ Optional ByVal AlpnProtocols As String = "http/1.1") As cHttpServer ``` **参数：** | 参数 | 类型 | 必要 | 说明 | |------|------|------|------| | `CertFile` | String | 是 | 证书文件路径。PFX/P12 或 PEM 格式，PEM 支持用 `\|` 分隔多文件 | | `Password` | String | 否 | 证书密码，PEM 无加密私钥时留空 | | `AlpnProtocols` | String | 否 | ALPN 协议协商，默认 `"http/1.1"`，HTTP/2 可设为 `"h2,http/1.1"` | **CertFile 格式：** * PFX/P12：`"C:\certs\server.pfx"` * PEM 单文件：`"C:\certs\server.pem"`（含证书和私钥） * PEM 多文件：`"C:\certs\fullchain.pem|C:\certs\privkey.pem"` ### TlsCertSubject — Windows 证书存储模式 从 Windows 系统证书库查找证书，适合企业环境。 ```vb Public Function TlsCertSubject( _ ByVal CertSubject As String, _ Optional ByVal AlpnProtocols As String = "http/1.1") As cHttpServer ``` **参数：** | 参数 | 类型 | 必要 | 说明 | |------|------|------|------| | `CertSubject` | String | 是 | 证书主题名称（如 `"www.example.com"`） | | `AlpnProtocols` | String | 否 | ALPN 协议协商，默认 `"http/1.1"` | ### TlsCertMemory — 内存证书集合模式 高级用法，从内存中的 Collection 加载证书。 ```vb Public Function TlsCertMemory( _ ByVal Certificates As Collection, _ ByVal PrivateKey As Collection, _ Optional ByVal AlpnProtocols As String = "http/1.1") As cHttpServer ``` ## Start 方法 改造后只保留端口和 IP 参数： ```vb Public Function Start(Optional Port As Long = 80, Optional IP As String = "0.0.0.0") As Boolean ``` ## 使用示例 ### PEM 证书（Let's Encrypt 最常见） ```vb Server.TlsCertFile("C:\certs\fullchain.pem|C:\certs\privkey.pem").Start 443 ``` ### PFX 带密码 ```vb Server.TlsCertFile("C:\certs\server.pfx", "my-password").WebRoot("C:\www").Start 443 ``` ### Windows 证书存储 ```vb Server.TlsCertSubject("www.example.com").Start 443 ``` ### 纯 HTTP（不调用任何 Tls 函数） ```vb Server.WebRoot("C:\www").Start 80 ``` ### HTTP + HTTPS 双端口 ```vb ' HTTP Dim httpSvr As New cHttpServer httpSvr.WebRoot("C:\www").Start 80 ' HTTPS Dim httpsSvr As New cHttpServer httpsSvr.TlsCertFile("C:\certs\server.pfx", "pwd").WebRoot("C:\www").Start 443 ``` ### 条件启用 ```vb If Config.EnableHTTPS Then If Config.CertFromStore Then Server.TlsCertSubject Config.CertSubject Else Server.TlsCertFile Config.CertPath, Config.CertPwd End If End If Server.WebRoot(Config.WebRoot).Start Config.Port, Config.BindIP ``` ## 内部机制 ### TLS 模式枚举 ```vb Private Enum EnumTlsMode TlsNone ' 未启用 TLS（默认） TlsModeCertFile ' 证书文件 TlsModeSubject ' Windows 证书存储 TlsModeMemory ' 内存证书集合 End Enum ``` * 调用任一 `Tls` 函数 = 设置对应枚举值 * `Start()` 根据枚举值选择 TCP 或 TLS 协议 * `StopMe()` 重置枚举为 `TlsNone`，清空所有 TLS/WebRoot 中间变量 ### 向后兼容 不调用任何 Tls 函数时，行为与改造前完全一致： * `Start(Port, IP)` — 纯 HTTP * `WebRoot()` 链式函数替代了原来 `Start` 的 `WebRoot` 参数 ::: warning 版本变更 自 **vbman 1.0.0.419** 起，`Start()` 不再接受 `WebRoot` 参数，请使用链式函数 `WebRoot()` 配置静态文件目录。 ::: ## 证书来源说明 三种证书模式的详细介绍，参见 [TLS 证书配置总览](../tls/overview.md)： | 证书模式 | 详见 | |----------|------| | TlsCertFile（证书文件） | [证书文件模式](../tls/certfile.md) | | TlsCertSubject（Windows 证书存储） | [Windows 证书存储模式](../tls/certsubject.md) | | TlsCertMemory（内存证书集合） | [内存证书集合模式](../tls/certmemory.md) | 底层 `InitServerTls` 按以下优先级检测： 1. 内存集合 (`Certificates` + `PrivateKey`) 2. 证书文件 (`CertFile`) 3. Windows 证书存储 (`CertSubject`) ## 注意事项 1. **证书链完整性**：PEM 格式需包含 fullchain（服务器证书 + 中间证书） 2. **ALPN 协商**：默认 `"http/1.1"`，如需 HTTP/2 支持设为 `"h2,http/1.1"` 3. **错误处理**：证书文件不存在/密码错误/证书过期时，`Start` 返回 False 并设置 `LastError` 4. **StopMe 重置**：停止后重新 Start 为纯 HTTP，无需手动清除 TLS 配置 5. **TLS 对 HTTP 协议解析完全透明**：其他 HttpServer 类文件无需任何改动 --- --- url: /en/vbman/httpserver/tls.md --- # cHttpServer TLS/HTTPS Support ## Overview `cHttpServer` supports TLS certificate configuration through chained functions, upgrading HTTP service to HTTPS. Underlying uses `cTlsReMaster` (based on cTlsSocket), supports TLS 1.2/1.3. ## Chained Functions ### TlsCertFile — Certificate File Mode Most commonly used method, supports PFX/P12 and PEM formats. ```vb Public Function TlsCertFile( _ ByVal CertFile As String, _ Optional ByVal Password As String, _ Optional ByVal AlpnProtocols As String = "http/1.1") As cHttpServer ``` **Parameters:** | Parameter | Type | Required | Description | |-----------|------|----------|-------------| | `CertFile` | String | Yes | Certificate file path. PFX/P12 or PEM format, PEM supports `\|` separated multiple files | | `Password` | String | No | Certificate password, leave empty for PEM with unencrypted private key | | `AlpnProtocols` | String | No | ALPN protocol negotiation, default `"http/1.1"`, set to `"h2,http/1.1"` for HTTP/2 | **CertFile Format:** * PFX/P12: `"C:\certs\server.pfx"` * PEM single file: `"C:\certs\server.pem"` (contains certificate and private key) * PEM multiple files: `"C:\certs\fullchain.pem|C:\certs\privkey.pem"` ### TlsCertSubject — Windows Certificate Store Mode Lookup certificate from Windows system certificate store, suitable for enterprise environments. ```vb Public Function TlsCertSubject( _ ByVal CertSubject As String, _ Optional ByVal AlpnProtocols As String = "http/1.1") As cHttpServer ``` **Parameters:** | Parameter | Type | Required | Description | |-----------|------|----------|-------------| | `CertSubject` | String | Yes | Certificate subject name (e.g., `"www.example.com"`) | | `AlpnProtocols` | String | No | ALPN protocol negotiation, default `"http/1.1"` | ### TlsCertMemory — Memory Certificate Collection Mode Advanced usage, load certificates from Collection in memory. ```vb Public Function TlsCertMemory( _ ByVal Certificates As Collection, _ ByVal PrivateKey As Collection, _ Optional ByVal AlpnProtocols As String = "http/1.1") As cHttpServer ``` ## Start Method After refactoring, only retains port and IP parameters: ```vb Public Function Start(Optional Port As Long = 80, Optional IP As String = "0.0.0.0") As Boolean ``` ## Usage Examples ### PEM Certificate (Let's Encrypt Most Common) ```vb Server.TlsCertFile("C:\certs\fullchain.pem|C:\certs\privkey.pem").Start 443 ``` ### PFX with Password ```vb Server.TlsCertFile("C:\certs\server.pfx", "my-password").WebRoot("C:\www").Start 443 ``` ### Windows Certificate Store ```vb Server.TlsCertSubject("www.example.com").Start 443 ``` ### Pure HTTP (No TLS Functions Called) ```vb Server.WebRoot("C:\www").Start 80 ``` ### HTTP + HTTPS Dual Ports ```vb ' HTTP Dim httpSvr As New cHttpServer httpSvr.WebRoot("C:\www").Start 80 ' HTTPS Dim httpsSvr As New cHttpServer httpsSvr.TlsCertFile("C:\certs\server.pfx", "pwd").WebRoot("C:\www").Start 443 ``` ### Conditional Enable ```vb If Config.EnableHTTPS Then If Config.CertFromStore Then Server.TlsCertSubject Config.CertSubject Else Server.TlsCertFile Config.CertPath, Config.CertPwd End If End If Server.WebRoot(Config.WebRoot).Start Config.Port, Config.BindIP ``` ## Internal Mechanism ### TLS Mode Enum ```vb Private Enum EnumTlsMode TlsNone ' TLS not enabled (default) TlsModeCertFile ' Certificate file TlsModeSubject ' Windows Certificate Store TlsModeMemory ' Memory certificate collection End Enum ``` * Calling any `Tls` function = Set corresponding enum value * `Start()` selects TCP or TLS protocol based on enum value * `StopMe()` resets enum to `TlsNone`, clears all TLS/WebRoot intermediate variables ### Backward Compatibility When no TLS functions are called, behavior is completely consistent with before refactoring: * `Start(Port, IP)` — Pure HTTP * `WebRoot()` chained function replaces the original `Start` method's `WebRoot` parameter ::: warning Version Change Starting from **vbman 1.0.0.419**, the `Start()` method no longer accepts a `WebRoot` parameter. Please use the chained function `WebRoot()` to configure the static files directory. ::: ## Certificate Source Documentation Detailed introduction to three certificate modes, see [TLS Certificate Configuration Overview](../tls/overview.md): | Certificate Mode | Details | |------------------|---------| | TlsCertFile (Certificate File) | [Certificate File Mode](../tls/certfile.md) | | TlsCertSubject (Windows Certificate Store) | [Windows Certificate Store Mode](../tls/certsubject.md) | | TlsCertMemory (Memory Certificate Collection) | [Memory Certificate Collection Mode](../tls/certmemory.md) | Underlying `InitServerTls` detects in the following priority: 1. Memory collection (`Certificates` + `PrivateKey`) 2. Certificate file (`CertFile`) 3. Windows Certificate Store (`CertSubject`) ## Notes 1. **Certificate Chain Completeness**: PEM format needs to contain fullchain (server certificate + intermediate certificate) 2. **ALPN Negotiation**: Default `"http/1.1"`, set to `"h2,http/1.1"` for HTTP/2 support 3. **Error Handling**: When certificate file doesn't exist/password error/certificate expired, `Start` returns False and sets `LastError` 4. **StopMe Reset**: After stopping, restarting as pure HTTP, no need to manually clear TLS configuration 5. **TLS is completely transparent to HTTP protocol parsing**: Other HttpServer class files need no changes --- --- url: /zh/vbman/httpserver/context.md --- # cHttpServerContext 上下文对象 ## 简介 `cHttpServerContext` 是 HttpServer 框架的核心对象，贯穿整个请求生命周期。它封装了 HTTP 请求处理所需的全部信息和功能，作为中间件和控制器之间数据传递的载体。 ``` 请求生命周期中的 Context: Request Arrive │ ▼ ┌─────────────────────────────────────────────────────────────┐ │ cHttpServerContext │ │ ┌─────────────┐ ┌─────────────┐ ┌─────────────┐ │ │ │ Request │ │ Session │ │ Response │ │ │ │ (请求信息) │ │ (会话数据) │ │ (响应构建) │ │ │ └─────────────┘ └─────────────┘ └─────────────┘ │ │ ┌─────────────┐ ┌─────────────┐ ┌─────────────┐ │ │ │ Cookies │ │ Db │ │ Client │ │ │ │ (Cookie) │ │ (数据库) │ │ (客户端) │ │ │ └─────────────┘ └─────────────┘ └─────────────┘ │ │ ┌─────────────┐ ┌─────────────┐ │ │ │ SSE │ │ UserData │ (自定义数据传递) │ │ │(实时推送) │ │ (扩展存储) │ │ │ └─────────────┘ └─────────────┘ │ └─────────────────────────────────────────────────────────────┘ │ ▼ Middleware -> Controller -> Response ``` ## 核心属性 ### Request - 请求对象 包含客户端发送的所有请求信息。 ```vb Public Request As cHttpServerRequest ``` **常用访问方式**: ```vb ' 获取请求方法 Dim method As String method = ctx.Request.MethodName ' "GET" / "POST" / "PUT" / "DELETE" ' 获取请求路径 Dim path As String path = ctx.Request.PathInfo ' "/user/list" ' 获取查询参数 Dim page As String page = ctx.Request.QueryString("page") ' 获取表单数据 Dim username As String username = ctx.Request.Form("username") ' 获取 JSON 数据 Dim name As String name = ctx.Request.Json.GetItem("name") ' 智能获取（自动从 Query/Form/Json 查找） Dim value As Variant value = ctx.Request("keyword") ' 获取请求头 Dim token As String token = ctx.Request.Header("Authorization") ``` *** ### Response - 响应对象 用于构建和发送 HTTP 响应。 ```vb Public Response As cHttpServerResponse ``` **常用方法**: ```vb ' 返回文本 ctx.Response.Text "Hello World" ' 返回 HTML ctx.Response.Html "

    标题

    " ' 返回 JSON ctx.Response.Json data, 0, "Success" ' 返回文件 ctx.Response.File "/path/to/file.pdf" ' 返回错误状态 ctx.Response.State404 "页面不存在" ctx.Response.State500 "服务器内部错误" ctx.Response.State401 "未授权" ``` *** ### Session - 会话对象 管理用户会话数据，支持内存、文件、数据库三种存储方式。 ```vb Public Session As cHttpServerSession ``` **常用操作**: ```vb ' 存储数据 ctx.Session("user_id") = "123" ctx.Session("username") = "张三" ' 读取数据 Dim userId As String userId = ctx.Session("user_id") ' 检查存在性 If ctx.Session.Exists("user_id") Then ' 用户已登录 End If ' 设置超时（分钟） ctx.Session.TimeOut = 60 ' 删除数据 ctx.Session.Remove("temp_data") ' 清空会话 ctx.Session.Clear ' 放弃会话（退出登录） ctx.Session.Abandon ``` **登录验证示例**: ```vb Public Sub CheckLogin(ctx As cHttpServerContext) If Not ctx.Session.Exists("user_id") Then ctx.Response.State401 "请先登录" ctx.Abort ' 终止后续处理 End If End Sub ``` *** ### Cookies - Cookie 对象 管理请求和响应中的 Cookie。 ```vb Public Cookies As cHttpServerCookies ``` **读取请求 Cookie**: ```vb If ctx.Cookies.Exists("remember") Then Dim token As String token = ctx.Cookies.Cookie("remember").Value End If ``` **设置响应 Cookie**: ```vb With ctx.Cookies.Cookie("session_id") .Value = GenerateToken() .Expires = DateAdd("h", 2, Now) .HttpOnly = True .Secure = True .Path = "/" .SameSite = "Strict" End With ``` *** ### Db - 数据库对象 提供数据库访问能力。 ```vb Public Db As cDataBase ``` **查询示例**: ```vb ' 简单查询 If ctx.Db.Sql("SELECT * FROM users WHERE id=?") _ .Param("id", userId, adVarChar) _ .Fetch Then Dim user As Dictionary Set user = ctx.Db.Rows(1) End If ' 插入数据 ctx.Db.Sql("INSERT INTO logs (action, time) VALUES (?, NOW())") _ .Param("action", "login", adVarChar) _ .ExecParam ' 事务处理 ctx.Db.TransBegin ' ... 执行多个 SQL ... ctx.Db.TransCommit ``` *** ### ClientInfo - 客户端信息 包含连接客户端的信息。 ```vb Public ClientInfo As cHttpServerClientInfo ``` **属性**: ```vb Dim ip As String ip = ctx.ClientInfo.IP ' "192.168.1.100" Dim port As Long port = ctx.ClientInfo.Port ' 52341 Dim hSocket As Long hSocket = ctx.ClientInfo.hSocket ' 套接字句柄 Dim connectTime As Date connectTime = ctx.ClientInfo.ConnectAt ``` **应用场景**: ```vb ' IP 黑名单检查 Public Sub CheckIP(ctx As cHttpServerContext) Dim blacklist As Variant blacklist = Array("192.168.1.100", "10.0.0.50") If InArray(ctx.ClientInfo.IP, blacklist) Then ctx.Response.State403 "IP 已被封禁" ctx.Abort End If End Sub ' 记录访问日志 Public Sub LogAccess(ctx As cHttpServerContext) Dim log As String log = Now & " | " & ctx.ClientInfo.IP & " | " & ctx.Request.PathInfo Call WriteLog(log) End Sub ``` *** ### Server - 服务器配置 访问服务器配置信息。 ```vb Public Server As cHttpServerSvr ``` **属性**: ```vb Dim webRoot As String webRoot = ctx.Server.WebRoot ' "C:\WebRoot" Dim port As Long port = ctx.Server.Port ' 8080 Dim ip As String ip = ctx.Server.IP ' "0.0.0.0" ``` **检查静态文件**: ```vb If ctx.Server.IsStaticFile("/image/logo.png") Then ctx.Response.File "/image/logo.png" End If ``` *** ### SSE - 实时推送 Server-Sent Events 实时推送对象（cSSEContext 代理）。 ```vb Public SSE As cSSEContext ``` **使用示例**: ```vb ' 使用 SendPack 快捷发送（推荐） ctx.SSE.SendPack "notification", "系统公告", ctx.ClientInfo.hSocket ' 使用 Data + Send 自定义数据结构 ctx.SSE.Data.Add "type", "alert" ctx.SSE.Data.Add "message", "系统维护通知" ctx.SSE.Send ctx.ClientInfo.hSocket ' 广播给所有客户端（不传 hSocket） ctx.SSE.SendPack "notification", "系统公告" ' 链式调用发送给指定用户 ctx.SSE.ToUser("admin").SendPack "private", "欢迎回来" ' 查看在线客户端数量 If ctx.SSE.ClientCount > 0 Then ' 有 SSE 客户端在线 End If ``` *** ### TimeUse - 耗时统计 用于统计请求处理耗时。 ```vb Public TimeUse As New cTimeUse ``` **使用示例**: ```vb Public Sub SlowOperation(ctx As cHttpServerContext) ctx.TimeUse.Start ' ... 执行耗时操作 ... Sleep 2000 ctx.TimeUse.End_ Debug.Print "操作耗时: " & ctx.TimeUse.Elapsed & " ms" ' 输出: 操作耗时: 2000 ms End Sub ``` *** ### UserData - 用户数据存储 用于在请求生命周期内传递自定义数据。 ```vb Public UserData As New Dictionary ``` **中间件与控制器间传递数据**: ```vb ' === 中间件中设置 === Public Sub AuthMiddleware(ctx As cHttpServerContext) ' 验证 Token 后存储用户信息 ctx.UserData("user_id") = "123" ctx.UserData("username") = "张三" ctx.UserData("role") = "admin" End Sub ' === 控制器中使用 === Public Sub GetData(ctx As cHttpServerContext) ' 获取中间件设置的数据 Dim userId As String userId = ctx.UserData("user_id") ' 根据角色返回不同数据 If ctx.UserData("role") = "admin" Then ' 返回完整数据 Else ' 返回部分数据 End If End Sub ``` *** ### Statistics - 性能统计 服务器级性能统计对象引用，与 `Server.Statistics` 指向同一实例。 ```vb Public Statistics As cHttpServerStatistics ``` **说明**: Statistics 是服务器级单例，仅在 Context 中保存引用，`ReleaseRequest` 和 `Release` 不会释放它。 **使用示例**: ```vb ' 在控制器中读取统计 Public Sub GetStats(ctx As cHttpServerContext) Debug.Print "总请求: " & ctx.Statistics.TotalRequests Debug.Print "GET: " & ctx.Statistics.GetRequests Debug.Print "POST: " & ctx.Statistics.PostRequests Debug.Print "2xx: " & ctx.Statistics.Status2xx Debug.Print "5xx: " & ctx.Statistics.Status5xx Debug.Print "峰值连接: " & ctx.Statistics.PeakConnections Debug.Print "QPS: " & ctx.Statistics.AverageQPS Debug.Print "运行时间: " & ctx.Statistics.UptimeSeconds & "s" End Sub ``` **完整字段列表**: | 字段 | 类型 | 说明 | | ------------------------------------------------------------------------------------------------------------------------------------------ | --------------------- | -------------------------------- | | `TotalRequests` | Long | 累计请求总数 | | `GetRequests` / `PostRequests` / `PutRequests` / `DeleteRequests` / `OptionsRequests` / `HeadRequests` / `PatchRequests` / `OtherRequests` | Long | 按方法分类计数 | | `Status1xx` ~ `Status5xx` | Long | 按状态码区间计数 | | `TotalConnectionsAccepted` | Long | 累计接受连接总数 | | `RejectedConnections` | Long | 因 MaxConnections 被拒绝的连接数 | | `PeakConnections` | Long | 峰值并发连接数 | | `IdleConnectionsCleaned` | Long | 因空闲超时被清理的连接数 | | `RequestErrors` | Long | 请求处理异常次数 | | `RequestSizeRejected` | Long | 413 Payload Too Large 次数 | | `SSEConnectionsAccepted` | Long | SSE 连接总数 | | `TotalSessionsCreated` | Long | 累计创建的 Session 总数 | | `TotalBytesReceived` / `TotalBytesSent` | Long | 累计流量（字节） | | `StartTime` | Date | 服务器启动时间 | | `UptimeSeconds` | Long (Property Get) | 运行时长（秒） | | `AverageQPS` | Double (Property Get) | 每秒平均请求数 | | `Reset()` | Sub | 重置所有计数器 | *** ## 控制方法 ### Abort - 终止请求 终止后续所有处理（中间件、控制器）。 ```vb Public Sub Abort() ``` **示例**: ```vb Public Sub CheckAuth(ctx As cHttpServerContext) If Not IsValidToken(ctx) Then ctx.Response.State401 "未授权" ctx.Abort ' 终止后续处理 End If End Sub ``` *** ### SkipNextMiddleWare - 跳过后续中间件 跳过剩余的中间件，直接进入控制器。 ```vb Public Sub SkipNextMiddleWare() ``` **示例**: ```vb Public Sub CacheMiddleware(ctx As cHttpServerContext) ' 检查缓存命中 If CacheExists(ctx.Request.PathInfo) Then ctx.Response.Text GetCache(ctx.Request.PathInfo) ctx.SkipNextMiddleWare ' 跳过其他中间件 End If End Sub ``` *** ## 完整请求处理示例 ```vb ' cOrderController.cls Option Explicit ' GET /api/orders Public Sub List(ctx As cHttpServerContext) ' 1. 性能统计开始 ctx.TimeUse.Start ' 2. 权限检查（从中间件传递的数据） Dim userId As String userId = ctx.UserData("user_id") If userId = "" Then ctx.Response.State401 "请先登录" ctx.Abort Exit Sub End If ' 3. 获取请求参数 Dim page As Long, limit As Long page = CLng(ctx.Request.QueryString("page")) limit = CLng(ctx.Request.QueryString("limit")) ' 4. 数据库查询 Dim sql As String sql = "SELECT * FROM orders WHERE user_id=? ORDER BY created_at DESC LIMIT ?,?" If Not ctx.Db.Sql(sql) _ .Param("user_id", userId, adVarChar) _ .Param("offset", (page - 1) * limit, adInteger) _ .Param("limit", limit, adInteger) _ .Fetch Then ctx.Response.State500 "查询失败" Exit Sub End If ' 5. 构建响应 Dim result As New Dictionary result("items") = ctx.Db.Rows result("page") = page result("total") = ctx.Db.Count("orders WHERE user_id='" & userId & "'") ctx.Response.Json result, 0, "Success" ' 6. 记录访问日志 Call WriteLog(ctx.ClientInfo.IP & " 查询了订单列表") ' 7. 性能统计结束 ctx.TimeUse.End_ Debug.Print "请求处理耗时: " & ctx.TimeUse.Elapsed & "ms" End Sub ' POST /api/orders Public Sub Create(ctx As cHttpServerContext) ' 1. 获取当前用户 Dim userId As String userId = ctx.UserData("user_id") ' 2. 获取请求数据 Dim productId As String, quantity As Long productId = ctx.Request.Json.GetItem("product_id") quantity = ctx.Request.Json.GetItem("quantity") ' 3. 开启事务 If Not ctx.Db.TransBegin Then ctx.Response.State500 "系统错误" Exit Sub End If On Error GoTo Rollback ' 4. 检查库存 Dim stock As Long stock = GetProductStock(ctx.Db, productId) If stock < quantity Then ctx.Response.Json Nothing, 1, "库存不足" GoTo Rollback End If ' 5. 创建订单 Dim orderId As String orderId = GenerateOrderId() ctx.Db.Sql("INSERT INTO orders (id, user_id, product_id, quantity) VALUES (?, ?, ?, ?)") _ .Param("id", orderId, adVarChar) _ .Param("user_id", userId, adVarChar) _ .Param("product_id", productId, adVarChar) _ .Param("quantity", quantity, adInteger) _ .ExecParam ' 6. 扣减库存 ctx.Db.Sql("UPDATE products SET stock = stock - ? WHERE id = ?") _ .Param("quantity", quantity, adInteger) _ .Param("product_id", productId, adVarChar) _ .ExecParam ' 7. 提交事务 ctx.Db.TransCommit ' 8. 返回结果 Dim result As New Dictionary result("order_id") = orderId ctx.Response.Json result, 0, "订单创建成功" ' 9. 发送实时通知 ctx.SSE.SendPack "order_created", "{\"order_id\":\"" & orderId & "\"}", ctx.ClientInfo.hSocket Exit Sub Rollback: ctx.Db.TransRollback End Sub ``` *** ## Context 生命周期 ``` ┌────────────────────────────────────────────────────────────────┐ │ 请求开始 │ │ 创建 Context 对象 │ └────────────────────────────────────────────────────────────────┘ │ ▼ ┌────────────────────────────────────────────────────────────────┐ │ 1. 解析请求 │ │ - ctx.Request 填充数据 │ │ - ctx.ClientInfo 填充客户端信息 │ │ - ctx.Cookies 解析请求 Cookie │ │ - ctx.Session 加载会话数据 │ └────────────────────────────────────────────────────────────────┘ │ ▼ ┌────────────────────────────────────────────────────────────────┐ │ 2. 执行前置中间件 (可读写 ctx.UserData) │ │ - 中间件可以访问和修改 Context 的所有属性 │ │ - 可调用 ctx.Abort 终止请求 │ │ - 可调用 ctx.SkipNextMiddleWare 跳过剩余中间件 │ │ - 通过 ctx.UserData("key") = value 传递数据给后续流程 │ └────────────────────────────────────────────────────────────────┘ │ ctx.UserData 向下传递 ▼ ┌────────────────────────────────────────────────────────────────┐ │ 3. 执行控制器 (可读写 ctx.UserData) │ │ - 读取 ctx.Request 获取请求数据 │ │ - 使用 ctx.Db 操作数据库 │ │ - 操作 ctx.Session 管理会话 │ │ - 设置 ctx.Cookies 写入响应 Cookie │ │ - 调用 ctx.Response 发送响应 │ │ - 使用 ctx.SSE 发送实时消息（如需要） │ │ - 读取 ctx.UserData 获取中间件传递的数据 │ │ - 通过 ctx.UserData 传递数据给后置处理 │ └────────────────────────────────────────────────────────────────┘ │ ctx.UserData 向下传递 ▼ ┌────────────────────────────────────────────────────────────────┐ │ 4. 执行后置处理 (可读取 ctx.UserData) │ │ - 保存 ctx.Session 到持久化存储 │ │ - 发送响应 Cookie │ │ - 执行后置中间件 │ │ - 读取 ctx.UserData 进行日志记录、统计等 │ └────────────────────────────────────────────────────────────────┘ │ ▼ ┌────────────────────────────────────────────────────────────────┐ │ 请求结束 │ │ 释放 Context 对象 │ └────────────────────────────────────────────────────────────────┘ ``` *** **最后更新**: 2026-05-17 --- --- url: /en/vbman/httpserver/context.md --- # cHttpServerContext Context Object ## Overview `cHttpServerContext` is the core object of the HttpServer framework, spanning the entire request lifecycle. It encapsulates all information and functionality needed for HTTP request processing, serving as the carrier for data transfer between middleware and controllers. ``` Context in Request Lifecycle: Request Arrive │ ▼ ┌─────────────────────────────────────────────────────────────┐ │ cHttpServerContext │ │ ┌─────────────┐ ┌─────────────┐ ┌─────────────┐ │ │ │ Request │ │ Session │ │ Response │ │ │ │ (Request) │ │ (Session) │ │ (Response) │ │ │ └─────────────┘ └─────────────┘ └─────────────┘ │ │ ┌─────────────┐ ┌─────────────┐ ┌─────────────┐ │ │ │ Cookies │ │ Db │ │ Client │ │ │ │ (Cookies) │ │ (Database) │ │ (Client) │ │ │ └─────────────┘ └─────────────┘ └─────────────┘ │ │ ┌─────────────┐ ┌─────────────┐ │ │ │ SSE │ │ UserData │ (Custom Data Pass) │ │ │ (Push) │ │(Extension) │ │ │ └─────────────┘ └─────────────┘ │ └─────────────────────────────────────────────────────────────┘ │ ▼ Middleware -> Controller -> Response ``` ## Core Properties ### Request - Request Object Contains all request information sent by the client. ```vb Public Request As cHttpServerRequest ``` **Common Usage**: ```vb ' Get request method Dim method As String method = ctx.Request.MethodName ' "GET" / "POST" / "PUT" / "DELETE" ' Get request path Dim path As String path = ctx.Request.PathInfo ' "/user/list" ' Get query parameters Dim page As String page = ctx.Request.QueryString("page") ' Get form data Dim username As String username = ctx.Request.Form("username") ' Get JSON data Dim name As String name = ctx.Request.Json.GetItem("name") ' Smart get (auto search Query/Form/Json) Dim value As Variant value = ctx.Request("keyword") ' Get request headers Dim token As String token = ctx.Request.Header("Authorization") ``` *** ### Response - Response Object Used to build and send HTTP responses. ```vb Public Response As cHttpServerResponse ``` **Common Methods**: ```vb ' Return text ctx.Response.Text "Hello World" ' Return HTML ctx.Response.Html "

    Title

    " ' Return JSON ctx.Response.Json data, 0, "Success" ' Return file ctx.Response.File "/path/to/file.pdf" ' Return error status ctx.Response.State404 "Page not found" ctx.Response.State500 "Internal server error" ctx.Response.State401 "Unauthorized" ``` *** ### Session - Session Object Manages user session data, supporting memory, file, and database storage. ```vb Public Session As cHttpServerSession ``` **Common Operations**: ```vb ' Store data ctx.Session("user_id") = "123" ctx.Session("username") = "John" ' Read data Dim userId As String userId = ctx.Session("user_id") ' Check existence If ctx.Session.Exists("user_id") Then ' User is logged in End If ' Set timeout (minutes) ctx.Session.TimeOut = 60 ' Remove data ctx.Session.Remove("temp_data") ' Clear session ctx.Session.Clear ' Abandon session (logout) ctx.Session.Abandon ``` **Login Verification Example**: ```vb Public Sub CheckLogin(ctx As cHttpServerContext) If Not ctx.Session.Exists("user_id") Then ctx.Response.State401 "Please login first" ctx.Abort ' Stop subsequent processing End If End Sub ``` *** ### Cookies - Cookie Object Manages cookies in requests and responses. ```vb Public Cookies As cHttpServerCookies ``` **Reading Request Cookies**: ```vb If ctx.Cookies.Exists("remember") Then Dim token As String token = ctx.Cookies.Cookie("remember").Value End If ``` **Setting Response Cookies**: ```vb With ctx.Cookies.Cookie("session_id") .Value = GenerateToken() .Expires = DateAdd("h", 2, Now) .HttpOnly = True .Secure = True .Path = "/" .SameSite = "Strict" End With ``` *** ### Db - Database Object Provides database access capability. ```vb Public Db As cDataBase ``` **Query Examples**: ```vb ' Simple query If ctx.Db.Sql("SELECT * FROM users WHERE id=?") _ .Param("id", userId, adVarChar) _ .Fetch Then Dim user As Dictionary Set user = ctx.Db.Rows(1) End If ' Insert data ctx.Db.Sql("INSERT INTO logs (action, time) VALUES (?, NOW())") _ .Param("action", "login", adVarChar) _ .ExecParam ' Transaction processing ctx.Db.TransBegin ' ... Execute multiple SQL ... ctx.Db.TransCommit ``` *** ### ClientInfo - Client Information Contains information about the connected client. ```vb Public ClientInfo As cHttpServerClientInfo ``` **Properties**: ```vb Dim ip As String ip = ctx.ClientInfo.IP ' "192.168.1.100" Dim port As Long port = ctx.ClientInfo.Port ' 52341 Dim hSocket As Long hSocket = ctx.ClientInfo.hSocket ' Socket handle Dim connectTime As Date connectTime = ctx.ClientInfo.ConnectAt ``` **Use Cases**: ```vb ' IP blacklist check Public Sub CheckIP(ctx As cHttpServerContext) Dim blacklist As Variant blacklist = Array("192.168.1.100", "10.0.0.50") If InArray(ctx.ClientInfo.IP, blacklist) Then ctx.Response.State403 "IP has been blocked" ctx.Abort End If End Sub ' Log access Public Sub LogAccess(ctx As cHttpServerContext) Dim log As String log = Now & " | " & ctx.ClientInfo.IP & " | " & ctx.Request.PathInfo Call WriteLog(log) End Sub ``` *** ### Server - Server Configuration Access server configuration information. ```vb Public Server As cHttpServerSvr ``` **Properties**: ```vb Dim webRoot As String webRoot = ctx.Server.WebRoot ' "C:\WebRoot" Dim port As Long port = ctx.Server.Port ' 8080 Dim ip As String ip = ctx.Server.IP ' "0.0.0.0" ``` **Check Static Files**: ```vb If ctx.Server.IsStaticFile("/image/logo.png") Then ctx.Response.File "/image/logo.png" End If ``` *** ### SSE - Real-time Push Server-Sent Events real-time push object (cSSEContext proxy). ```vb Public SSE As cSSEContext ``` **Usage Example**: ```vb ' Use SendPack for quick send (recommended) ctx.SSE.SendPack "notification", "System announcement", ctx.ClientInfo.hSocket ' Use Data + Send for custom data structure ctx.SSE.Data.Add "type", "alert" ctx.SSE.Data.Add "message", "System maintenance notice" ctx.SSE.Send ctx.ClientInfo.hSocket ' Broadcast to all clients (omit hSocket) ctx.SSE.SendPack "notification", "System announcement" ' Chain call to send to specific user ctx.SSE.ToUser("admin").SendPack "private", "Welcome back" ' Check online client count If ctx.SSE.ClientCount > 0 Then ' SSE clients are online End If ``` *** ### TimeUse - Performance Statistics Used to track request processing time. ```vb Public TimeUse As New cTimeUse ``` **Usage Example**: ```vb Public Sub SlowOperation(ctx As cHttpServerContext) ctx.TimeUse.Start ' ... Perform time-consuming operation ... Sleep 2000 ctx.TimeUse.End_ Debug.Print "Operation time: " & ctx.TimeUse.Elapsed & " ms" ' Output: Operation time: 2000 ms End Sub ``` *** ### UserData - User Data Storage Used to pass custom data within the request lifecycle. ```vb Public UserData As New Dictionary ``` **Passing Data Between Middleware and Controller**: ```vb ' === In Middleware === Public Sub AuthMiddleware(ctx As cHttpServerContext) ' After validating Token, store user info ctx.UserData("user_id") = "123" ctx.UserData("username") = "John" ctx.UserData("role") = "admin" End Sub ' === In Controller === Public Sub GetData(ctx As cHttpServerContext) ' Get data set by middleware Dim userId As String userId = ctx.UserData("user_id") ' Return different data based on role If ctx.UserData("role") = "admin" Then ' Return full data Else ' Return partial data End If End Sub ``` *** ### Statistics - Performance Statistics Server-level performance statistics object reference, pointing to the same instance as `Server.Statistics`. ```vb Public Statistics As cHttpServerStatistics ``` **Note**: Statistics is a server-level singleton, only a reference is kept in Context. `ReleaseRequest` and `Release` will not release it. **Usage Example**: ```vb ' Read statistics in controller Public Sub GetStats(ctx As cHttpServerContext) Debug.Print "Total requests: " & ctx.Statistics.TotalRequests Debug.Print "GET: " & ctx.Statistics.GetRequests Debug.Print "POST: " & ctx.Statistics.PostRequests Debug.Print "2xx: " & ctx.Statistics.Status2xx Debug.Print "5xx: " & ctx.Statistics.Status5xx Debug.Print "Peak connections: " & ctx.Statistics.PeakConnections Debug.Print "QPS: " & ctx.Statistics.AverageQPS Debug.Print "Uptime: " & ctx.Statistics.UptimeSeconds & "s" End Sub ``` **Complete Field List**: | Field | Type | Description | | ------------------------------------------------------------------------------------------------------------------------------------------ | --------------------- | ------------------------------------------ | | `TotalRequests` | Long | Cumulative total requests | | `GetRequests` / `PostRequests` / `PutRequests` / `DeleteRequests` / `OptionsRequests` / `HeadRequests` / `PatchRequests` / `OtherRequests` | Long | Count by method | | `Status1xx` ~ `Status5xx` | Long | Count by status code range | | `TotalConnectionsAccepted` | Long | Cumulative total connections accepted | | `RejectedConnections` | Long | Connections rejected due to MaxConnections | | `PeakConnections` | Long | Peak concurrent connections | | `IdleConnectionsCleaned` | Long | Connections cleaned due to idle timeout | | `RequestErrors` | Long | Request processing exceptions | | `RequestSizeRejected` | Long | 413 Payload Too Large count | | `SSEConnectionsAccepted` | Long | Total SSE connections | | `TotalSessionsCreated` | Long | Cumulative total sessions created | | `TotalBytesReceived` / `TotalBytesSent` | Long | Cumulative traffic (bytes) | | `StartTime` | Date | Server start time | | `UptimeSeconds` | Long (Property Get) | Uptime in seconds | | `AverageQPS` | Double (Property Get) | Average requests per second | | `Reset()` | Sub | Reset all counters | *** ## Control Methods ### Abort - Terminate Request Terminates all subsequent processing (middleware, controller). ```vb Public Sub Abort() ``` **Example**: ```vb Public Sub CheckAuth(ctx As cHttpServerContext) If Not IsValidToken(ctx) Then ctx.Response.State401 "Unauthorized" ctx.Abort ' Stop subsequent processing End If End Sub ``` *** ### SkipNextMiddleWare - Skip Subsequent Middleware Skips remaining middleware, goes directly to controller. ```vb Public Sub SkipNextMiddleWare() ``` **Example**: ```vb Public Sub CacheMiddleware(ctx As cHttpServerContext) ' Check cache hit If CacheExists(ctx.Request.PathInfo) Then ctx.Response.Text GetCache(ctx.Request.PathInfo) ctx.SkipNextMiddleWare ' Skip other middleware End If End Sub ``` *** ## Complete Request Handling Example ```vb ' cOrderController.cls Option Explicit ' GET /api/orders Public Sub List(ctx As cHttpServerContext) ' 1. Start performance tracking ctx.TimeUse.Start ' 2. Permission check (data from middleware) Dim userId As String userId = ctx.UserData("user_id") If userId = "" Then ctx.Response.State401 "Please login first" ctx.Abort Exit Sub End If ' 3. Get request parameters Dim page As Long, limit As Long page = CLng(ctx.Request.QueryString("page")) limit = CLng(ctx.Request.QueryString("limit")) ' 4. Database query Dim sql As String sql = "SELECT * FROM orders WHERE user_id=? ORDER BY created_at DESC LIMIT ?,?" If Not ctx.Db.Sql(sql) _ .Param("user_id", userId, adVarChar) _ .Param("offset", (page - 1) * limit, adInteger) _ .Param("limit", limit, adInteger) _ .Fetch Then ctx.Response.State500 "Query failed" Exit Sub End If ' 5. Build response Dim result As New Dictionary result("items") = ctx.Db.Rows result("page") = page result("total") = ctx.Db.Count("orders WHERE user_id='" & userId & "'") ctx.Response.Json result, 0, "Success" ' 6. Log access Call WriteLog(ctx.ClientInfo.IP & " queried order list") ' 7. End performance tracking ctx.TimeUse.End_ Debug.Print "Request processing time: " & ctx.TimeUse.Elapsed & "ms" End Sub ' POST /api/orders Public Sub Create(ctx As cHttpServerContext) ' 1. Get current user Dim userId As String userId = ctx.UserData("user_id") ' 2. Get request data Dim productId As String, quantity As Long productId = ctx.Request.Json.GetItem("product_id") quantity = ctx.Request.Json.GetItem("quantity") ' 3. Start transaction If Not ctx.Db.TransBegin Then ctx.Response.State500 "System error" Exit Sub End If On Error GoTo Rollback ' 4. Check stock Dim stock As Long stock = GetProductStock(ctx.Db, productId) If stock < quantity Then ctx.Response.Json Nothing, 1, "Insufficient stock" GoTo Rollback End If ' 5. Create order Dim orderId As String orderId = GenerateOrderId() ctx.Db.Sql("INSERT INTO orders (id, user_id, product_id, quantity) VALUES (?, ?, ?, ?)") _ .Param("id", orderId, adVarChar) _ .Param("user_id", userId, adVarChar) _ .Param("product_id", productId, adVarChar) _ .Param("quantity", quantity, adInteger) _ .ExecParam ' 6. Deduct stock ctx.Db.Sql("UPDATE products SET stock = stock - ? WHERE id = ?") _ .Param("quantity", quantity, adInteger) _ .Param("product_id", productId, adVarChar) _ .ExecParam ' 7. Commit transaction ctx.Db.TransCommit ' 8. Return result Dim result As New Dictionary result("order_id") = orderId ctx.Response.Json result, 0, "Order created successfully" ' 9. Send real-time notification ctx.SSE.SendPack "order_created", "{\"order_id\":\"" & orderId & "\"}", ctx.ClientInfo.hSocket Exit Sub Rollback: ctx.Db.TransRollback End Sub ``` *** ## Context Lifecycle ``` ┌────────────────────────────────────────────────────────────────┐ │ Request Start │ │ Create Context Object │ └────────────────────────────────────────────────────────────────┘ │ ▼ ┌────────────────────────────────────────────────────────────────┐ │ 1. Parse Request │ │ - Fill ctx.Request with data │ │ - Fill ctx.ClientInfo with client information │ │ - Parse request Cookies to ctx.Cookies │ │ - Load session data to ctx.Session │ └────────────────────────────────────────────────────────────────┘ │ ▼ ┌────────────────────────────────────────────────────────────────┐ │ 2. Execute Pre-Middleware (can read/write ctx.UserData) │ │ - Middleware can access and modify all Context properties │ │ - Can call ctx.Abort to terminate request │ │ - Can call ctx.SkipNextMiddleWare to skip remaining │ │ - Pass data to subsequent flow via ctx.UserData("key") │ └────────────────────────────────────────────────────────────────┘ │ ctx.UserData passes down ▼ ┌────────────────────────────────────────────────────────────────┐ │ 3. Execute Controller (can read/write ctx.UserData) │ │ - Read ctx.Request to get request data │ │ - Use ctx.Db to operate database │ │ - Operate ctx.Session to manage sessions │ │ - Set ctx.Cookies to write response cookies │ │ - Call ctx.Response to send response │ │ - Use ctx.SSE to send real-time messages if needed │ │ - Read ctx.UserData to get data from middleware │ │ - Pass data to post-processing via ctx.UserData │ └────────────────────────────────────────────────────────────────┘ │ ctx.UserData passes down ▼ ┌────────────────────────────────────────────────────────────────┐ │ 4. Execute Post-Processing (can read ctx.UserData) │ │ - Save ctx.Session to persistent storage │ │ - Send response cookies │ │ - Execute post-middleware │ │ - Read ctx.UserData for logging, statistics, etc. │ └────────────────────────────────────────────────────────────────┘ │ ▼ ┌────────────────────────────────────────────────────────────────┐ │ Request End │ │ Release Context Object │ └────────────────────────────────────────────────────────────────┘ ``` *** **Last Updated**: 2026-05-17 --- --- url: /zh/vbman/httpserver/request.md --- # cHttpServerRequest 请求对象 ## 简介 `cHttpServerRequest` 封装了 HTTP 请求的所有信息，包括请求方法、URL、头部、参数、表单数据、JSON 数据等。 ## 属性 ### Method 请求方法枚举值。 ```vb Public Method As EnumRequestMethod ``` **取值**: * `ReqPost` = 1 * `ReqGet` = 2 * `ReqPut` = 3 * `ReqDelete` = 4 * `ReqOptions` = 5 **示例**: ```vb If ctx.Request.Method = ReqPost Then Debug.Print "POST 请求" End If ``` *** ### MethodName 请求方法名称字符串。 ```vb Public MethodName As String ``` **示例**: ```vb Debug.Print "方法: " & ctx.Request.MethodName ' 输出: GET 或 POST 等 ``` *** ### HttpVersion HTTP 版本。 ```vb Public HttpVersion As String ``` **示例**: ```vb Debug.Print "HTTP 版本: " & ctx.Request.HttpVersion ' 输出: HTTP/1.1 ``` *** ### url 完整请求 URL（已解码）。 ```vb Public url As String ``` **示例**: ```vb Debug.Print "URL: " & ctx.Request.url ' 输出: /user/list?page=1&limit=10 ``` *** ### PathInfo 请求路径（不含查询参数）。 ```vb Public PathInfo As String ``` **示例**: ```vb ' 请求 /user/list?page=1 Debug.Print "路径: " & ctx.Request.PathInfo ' 输出: /user/list ``` *** ### PathInfoList 路径段集合（`cCollection` 类型），将 URL 路径按 `/` 分割后的每一段存入集合，键和值都是段名，支持按索引和按键访问。 ```vb Public PathInfoList As New cCollection ``` **示例**: ```vb ' 请求 GET /api/user/list?page=1 ctx.Request.PathInfoList(1) ' → "api" ctx.Request.PathInfoList.Count ' → 3 ctx.Request.PathInfoList.Exists("api") ' → True ``` 👉 完整用法见 [参数路由与路径段解析](./route-params.md#二pathinfolist-路径段集合) *** ### PathInfoController 自动路由解析的控制器名。 ```vb Public PathInfoController As String ``` **示例**: ```vb ' 请求 /User/List Debug.Print "控制器: " & ctx.Request.PathInfoController ' 输出: User ``` *** ### PathInfoAction 自动路由解析的方法名。 ```vb Public PathInfoAction As String ``` **示例**: ```vb ' 请求 /User/List Debug.Print "方法: " & ctx.Request.PathInfoAction ' 输出: List ``` *** ### QueryInfo 查询参数字符串。 ```vb Public QueryInfo As String ``` **示例**: ```vb ' 请求 /user?page=1&limit=10 Debug.Print "查询: " & ctx.Request.QueryInfo ' 输出: page=1&limit=10 ``` *** ### QueryString 查询参数字典。 ```vb Public QueryString As New Dictionary ``` **示例**: ```vb ' GET /user?id=123&name=张三 Dim id As String id = ctx.Request.QueryString("id") Dim name As String name = ctx.Request.QueryString("name") ``` *** ### RouteParams 路由参数字典。当使用参数路由（如 `/api/user/{id}`）匹配成功后，URL 中的参数值会存入此字典。 ```vb Public RouteParams As New Dictionary ``` **示例**: ```vb ' 路由：/api/user/{id}，请求：GET /api/user/123 Dim userId As String userId = ctx.Request.RouteParams("id") ' → "123" ' 检查参数是否存在 If ctx.Request.RouteParams.Exists("id") Then ... ``` 👉 完整用法见 [参数路由与路径段解析](./route-params.md#12-控制器中获取参数) *** ### Form POST 表单数据字典。 ```vb Public Form As New Dictionary ``` **示例**: ```vb ' POST 表单: username=admin&password=123 Dim username As String username = ctx.Request.Form("username") Dim password As String password = ctx.Request.Form("password") ``` *** ### Json JSON 数据对象。 ```vb Public Json As New cJson ``` **示例**: ```vb ' POST JSON: {"name":"张三","age":25} Dim name As String name = ctx.Request.Json.GetItem("name") Dim age As Long age = ctx.Request.Json.GetItem("age") ``` *** ### Header 请求头部字典。 ```vb Public Header As New Dictionary ``` **示例**: ```vb ' 获取 User-Agent If ctx.Request.Header.Exists("User-Agent") Then Debug.Print ctx.Request.Header("User-Agent") End If ' 获取 Authorization Dim token As String token = ctx.Request.Header("Authorization") ``` *** ### HeaderRaw 原始请求头字符串。 ```vb Public HeaderRaw As String ``` *** ### HeaderUserAgent User-Agent 快捷访问。 ```vb Public HeaderUserAgent As String ``` *** ### HeaderAccept Accept 头部快捷访问。 ```vb Public HeaderAccept As String ``` *** ### HeaderHost Host 头部。 ```vb Public HeaderHost As String ``` *** ### HeaderHostDomain 域名部分。 ```vb Public HeaderHostDomain As String ``` *** ### HeaderHostPort 端口部分。 ```vb Public HeaderHostPort As Long ``` *** ### HeaderContentType Content-Type 头部。 ```vb Public HeaderContentType As String ``` *** ### HeaderContentLength Content-Length 头部。 ```vb Public HeaderContentLength As Long ``` *** ### RawBodyText 原始请求体文本。 ```vb Public Property Get RawBodyText() As String ``` *** ### RawBodyBin 原始请求体字节数组。 ```vb Public Property Get RawBodyBin() As Byte() ``` *** ### Item (默认属性) 智能获取参数值（从 QueryString、Form、Json 按顺序查找）。 ```vb Public Property Get Item(ByVal key) As Variant ``` **示例**: ```vb ' 自动从 query/form/json 获取参数 Dim value As Variant value = ctx.Request("username") value = ctx.Request("page") ``` *** **最后更新**: 2026-06-11 --- --- url: /en/vbman/httpserver/request.md --- # cHttpServerRequest Request Object ## Overview `cHttpServerRequest` encapsulates all information of an HTTP request, including request method, URL, headers, parameters, form data, JSON data, etc. ## Properties ### Method Request method enum value. ```vb Public Method As EnumRequestMethod ``` **Values**: * `ReqPost` = 1 * `ReqGet` = 2 * `ReqPut` = 3 * `ReqDelete` = 4 * `ReqOptions` = 5 **Example**: ```vb If ctx.Request.Method = ReqPost Then Debug.Print "POST request" End If ``` *** ### MethodName Request method name string. ```vb Public MethodName As String ``` **Example**: ```vb Debug.Print "Method: " & ctx.Request.MethodName ' Output: GET or POST etc. ``` *** ### HttpVersion HTTP version. ```vb Public HttpVersion As String ``` **Example**: ```vb Debug.Print "HTTP Version: " & ctx.Request.HttpVersion ' Output: HTTP/1.1 ``` *** ### Url Full request URL (decoded). ```vb Public Url As String ``` **Example**: ```vb Debug.Print "URL: " & ctx.Request.Url ' Output: /user/list?page=1&limit=10 ``` *** ### PathInfo Request path (without query parameters). ```vb Public PathInfo As String ``` **Example**: ```vb ' Request /user/list?page=1 Debug.Print "Path: " & ctx.Request.PathInfo ' Output: /user/list ``` *** ### PathInfoList Path segment collection (`cCollection` type). Each segment of the URL path split by `/` is stored in the collection, where both key and value are the segment name, supporting access by index and by key. ```vb Public PathInfoList As New cCollection ``` **Example**: ```vb ' Request GET /api/user/list?page=1 ctx.Request.PathInfoList(1) ' → "api" ctx.Request.PathInfoList.Count ' → 3 ctx.Request.PathInfoList.Exists("api") ' → True ``` 👉 For full usage, see [Parameter Routing & Path Segment Parsing](./route-params.md#2-pathinfolist-path-segment-collection) *** ### PathInfoController Controller name from automatic route parsing. ```vb Public PathInfoController As String ``` **Example**: ```vb ' Request /User/List Debug.Print "Controller: " & ctx.Request.PathInfoController ' Output: User ``` *** ### PathInfoAction Action method name from automatic route parsing. ```vb Public PathInfoAction As String ``` **Example**: ```vb ' Request /User/List Debug.Print "Action: " & ctx.Request.PathInfoAction ' Output: List ``` *** ### QueryInfo Query string. ```vb Public QueryInfo As String ``` **Example**: ```vb ' Request /user?page=1&limit=10 Debug.Print "Query: " & ctx.Request.QueryInfo ' Output: page=1&limit=10 ``` *** ### QueryString Query parameter dictionary. ```vb Public QueryString As New Dictionary ``` **Example**: ```vb ' GET /user?id=123&name=John Dim id As String id = ctx.Request.QueryString("id") Dim name As String name = ctx.Request.QueryString("name") ``` *** ### RouteParams Route parameter dictionary. When a parameter route (e.g., `/api/user/{id}`) matches successfully, the parameter values from the URL are stored in this dictionary. ```vb Public RouteParams As New Dictionary ``` **Example**: ```vb ' Route: /api/user/{id}, Request: GET /api/user/123 Dim userId As String userId = ctx.Request.RouteParams("id") ' → "123" ' Check if parameter exists If ctx.Request.RouteParams.Exists("id") Then ... ``` 👉 For full usage, see [Parameter Routing & Path Segment Parsing](./route-params.md#12-getting-parameters-in-controllers) *** ### Form POST form data dictionary. ```vb Public Form As New Dictionary ``` **Example**: ```vb ' POST form: username=admin&password=123 Dim username As String username = ctx.Request.Form("username") Dim password As String password = ctx.Request.Form("password") ``` *** ### Json JSON data object. ```vb Public Json As New cJson ``` **Example**: ```vb ' POST JSON: {"name":"John","age":25} Dim name As String name = ctx.Request.Json.GetItem("name") Dim age As Long age = ctx.Request.Json.GetItem("age") ``` *** ### Header Request header dictionary. ```vb Public Header As New Dictionary ``` **Example**: ```vb ' Get User-Agent If ctx.Request.Header.Exists("User-Agent") Then Debug.Print ctx.Request.Header("User-Agent") End If ' Get Authorization Dim token As String token = ctx.Request.Header("Authorization") ``` *** ### HeaderRaw Raw request header string. ```vb Public HeaderRaw As String ``` *** ### HeaderUserAgent User-Agent shortcut access. ```vb Public HeaderUserAgent As String ``` *** ### HeaderAccept Accept header shortcut access. ```vb Public HeaderAccept As String ``` *** ### HeaderHost Host header. ```vb Public HeaderHost As String ``` *** ### HeaderHostDomain Domain part. ```vb Public HeaderHostDomain As String ``` *** ### HeaderHostPort Port part. ```vb Public HeaderHostPort As Long ``` *** ### HeaderContentType Content-Type header. ```vb Public HeaderContentType As String ``` *** ### HeaderContentLength Content-Length header. ```vb Public HeaderContentLength As Long ``` *** ### RawBodyText Raw request body text. ```vb Public Property Get RawBodyText() As String ``` *** ### RawBodyBin Raw request body byte array. ```vb Public Property Get RawBodyBin() As Byte() ``` *** ### Item (Default Property) Smart parameter value getter (searches QueryString, Form, Json in order). ```vb Public Property Get Item(ByVal key) As Variant ``` **Example**: ```vb ' Auto-get parameter from query/form/json Dim value As Variant value = ctx.Request("username") value = ctx.Request("page") ``` *** **Last Updated**: 2026-06-11 --- --- url: /zh/vbman/httpserver/response.md --- # cHttpServerResponse 响应对象 ## 简介 `cHttpServerResponse` 用于构建和发送 HTTP 响应，支持文本、HTML、JSON、文件等多种响应类型。 ## 响应方法 ### Text 发送纯文本响应。 ```vb Public Sub Text(Data As String) ``` **参数**: * `Data` - 响应文本内容 **示例**: ```vb ctx.Response.Text "Hello, World!" ``` *** ### Html 发送 HTML 响应。 ```vb Public Sub Html(Data As String) ``` **参数**: * `Data` - HTML 内容 **示例**: ```vb ctx.Response.Html "

    Hello

    Welcome to my site

    " ``` *** ### Json 发送 JSON 响应。 ```vb Public Sub Json(Data As Variant, Optional Code As Long = -1, Optional msg As String, Optional Count As Long, Optional Whitespace As Variant) ``` **参数**: * `Data` - 要序列化为 JSON 的数据（Dictionary、Array 等） * `Code` - 状态码（默认 -1 表示不包装） * `msg` - 消息文本 * `Count` - 数据总数（用于分页） * `Whitespace` - JSON 格式化选项 **示例**: ```vb ' 简单 JSON Dim data As New Dictionary data("name") = "张三" data("age") = 25 ctx.Response.Json data ' 包装格式（API 标准响应） ' 输出: {"code": 0, "msg": "Success", "data": {...}, "count": 1} ctx.Response.Json data, 0, "Success", 1 ' 格式化输出 ctx.Response.Json data, , , , True ``` *** ### File 发送文件响应（内置 ETag + 304 协商缓存 + 懒内容缓存）。 ```vb Public Sub File(Path As String) ``` **参数**: * `Path` - 文件路径（相对于 WebRoot） **说明**: * 自动计算 ETag（基于文件修改时间 + 大小）并设置 `ETag`、`Last-Modified` 响应头 * 浏览器发送 `If-None-Match` 且匹配时返回 `304 Not Modified`（零传输） * 文件大小 ≤ `MaxCacheFileSize` 时自动加入内存缓存（懒缓存），后续访问直接内存输出跳过磁盘 I/O * 超出缓存上限的文件仍从磁盘读取，但享受 ETag/304 协商缓存 * 文件在磁盘更新后 ETag 自动变化，旧缓存自动失效 * 路径对应目录时，自动查找默认文档（index.html 等）；无默认文档返回 403 **示例**: ```vb ' 发送静态文件（自动带缓存头） ctx.Response.File "/css/style.css" ' 访问目录（自动查找 index.html） ctx.Response.File "/" ' 大文件（超出缓存上限，始终从磁盘读取，但有 ETag/304） ctx.Response.File "/videos/demo.mp4" ``` **缓存机制详解**: ``` 请求 → 计算 ETag（FSO元数据，不读文件内容） ├─> If-None-Match 匹配 → 304（零传输） ├─> 缓存命中 + ETag 未变 → 内存输出（跳过磁盘） ├─> 缓存命中 + ETag 变化 → 重新读取 + 更新缓存 └─> 无缓存 → 磁盘读取 + 懒缓存（≤上限才加入） ``` 详见 [静态文件服务 - 缓存控制](./static-files.md#缓存控制) *** ## 状态码方法 ### State 发送自定义状态码响应。 ```vb Public Sub State(Code As Long, Text As String, Optional Say As String = "未知状态") ``` *** ### State400 400 Bad Request。 ```vb Public Sub State400(Optional Say As String) ``` **示例**: ```vb If Not IsValidParams Then ctx.Response.State400 "参数错误" End If ``` *** ### State401 401 Unauthorized。 ```vb Public Sub State401(Optional Say As String) ``` **示例**: ```vb If Not IsAuthenticated Then ctx.Response.State401 "请先登录" End If ``` *** ### State403 403 Forbidden。 ```vb Public Sub State403(Optional Say As String) ``` **示例**: ```vb If Not HasPermission Then ctx.Response.State403 "没有权限" End If ``` *** ### State404 404 Not Found。 ```vb Public Sub State404(Optional Say As String) ``` **示例**: ```vb If Not UserExists(userId) Then ctx.Response.State404 "用户不存在" End If ``` *** ### State413 413 Payload Too Large。 ```vb Public Sub State413(Optional Say As String = "Request Entity Too Large") ``` **说明**: 当请求体超过 `Server.MaxRequestSize` 限制时自动返回此状态码。也可手动调用。 **示例**: ```vb ' 检查上传文件大小 If FileSize > MaxAllowedSize Then ctx.Response.State413 "文件大小超过限制" End If ``` *** ### State500 500 Internal Server Error。 ```vb Public Sub State500(Optional Say As String) ``` **示例**: ```vb On Error GoTo ErrorHandler ' ... 业务逻辑 Exit Sub ErrorHandler: ctx.Response.State500 Err.Description ``` *** ### State502 502 Gateway Error。 ```vb Public Sub State502(Optional Say As String) ``` *** ## 配置属性 ### Header 自定义响应头部字典。 ```vb Public Header As New Dictionary ``` **示例**: ```vb ctx.Response.Header("X-Custom-Header") = "CustomValue" ctx.Response.Header("Cache-Control") = "no-cache" ``` *** ### CharSet 字符编码（默认 utf-8）。 ```vb Public CharSet As String ``` **示例**: ```vb ctx.Response.CharSet = "gb2312" ``` *** ### ContentType 内容类型。 ```vb Public ContentType As String ``` **示例**: ```vb ctx.Response.ContentType = "application/xml" ``` *** ### Status HTTP 状态码字符串。 ```vb Public Status As String ``` *** ### JsonPackFieldNameCode JSON 包装字段名 - 状态码。 ```vb Public JsonPackFieldNameCode As String ``` **默认值**: `"code"` *** ### JsonPackFieldNameMsg JSON 包装字段名 - 消息。 ```vb Public JsonPackFieldNameMsg As String ``` **默认值**: `"msg"` *** ### JsonPackFieldNameData JSON 包装字段名 - 数据。 ```vb Public JsonPackFieldNameData As String ``` **默认值**: `"data"` *** ### JsonPackFieldNameCount JSON 包装字段名 - 总数。 ```vb Public JsonPackFieldNameCount As String ``` **默认值**: `"count"` **示例**: ```vb ' 自定义 JSON 响应字段名 ctx.Response.JsonPackFieldNameCode = "status" ctx.Response.JsonPackFieldNameMsg = "message" ctx.Response.JsonPackFieldNameData = "result" ctx.Response.JsonPackFieldNameCount = "total" ' 输出: {"status": 0, "message": "OK", "result": {...}, "total": 10} ctx.Response.Json data, 0, "OK", 10 ``` *** ## 兼容 ASP 的属性 | 属性 | 说明 | | ----------------- | ------------ | | `Buffer` | 缓冲输出 | | `CacheControl` | 缓存控制 | | `CodePage` | 代码页 | | `Expires` | 过期时间 | | `ExpiresAbsolute` | 绝对过期时间 | | `LCID` | 区域标识 | *** **最后更新**: 2026-06-22 --- --- url: /en/vbman/httpserver/response.md --- # cHttpServerResponse Response Object ## Overview `cHttpServerResponse` is used to build and send HTTP responses, supporting text, HTML, JSON, files, and other response types. ## Response Methods ### Text Send plain text response. ```vb Public Sub Text(Data As String) ``` **Parameters**: * `Data` - Response text content **Example**: ```vb ctx.Response.Text "Hello, World!" ``` *** ### Html Send HTML response. ```vb Public Sub Html(Data As String) ``` **Parameters**: * `Data` - HTML content **Example**: ```vb ctx.Response.Html "

    Hello

    Welcome to my site

    " ``` *** ### Json Send JSON response. ```vb Public Sub Json(Data As Variant, Optional Code As Long = -1, Optional msg As String, Optional Count As Long, Optional Whitespace As Variant) ``` **Parameters**: * `Data` - Data to serialize to JSON (Dictionary, Array, etc.) * `Code` - Status code (default -1 means no wrapper) * `msg` - Message text * `Count` - Total data count (for pagination) * `Whitespace` - JSON formatting option **Example**: ```vb ' Simple JSON Dim data As New Dictionary data("name") = "John" data("age") = 25 ctx.Response.Json data ' Wrapped format (API standard response) ' Output: {"code": 0, "msg": "Success", "data": {...}, "count": 1} ctx.Response.Json data, 0, "Success", 1 ' Formatted output ctx.Response.Json data, , , , True ``` *** ### File Send file response (with built-in ETag + 304 negotiated cache + lazy content cache). ```vb Public Sub File(Path As String) ``` **Parameters**: * `Path` - File path (relative to WebRoot) **Description**: * Auto-calculates ETag (based on file modification time + size) and sets `ETag`, `Last-Modified` response headers * When browser sends `If-None-Match` that matches, returns `304 Not Modified` (zero transfer) * When file size ≤ `MaxCacheFileSize`, auto-adds to memory cache (lazy cache), subsequent access outputs from memory skipping disk I/O * Files exceeding cache limit are still read from disk, but enjoy ETag/304 negotiated cache * When file is updated on disk, ETag auto-changes and old cache auto-invalidates * When path corresponds to a directory, auto-searches default documents (index.html etc); returns 403 if no default document found **Example**: ```vb ' Send static file (auto with cache headers) ctx.Response.File "/css/style.css" ' Access directory (auto-searches index.html) ctx.Response.File "/" ' Large file (exceeds cache limit, always read from disk, but with ETag/304) ctx.Response.File "/videos/demo.mp4" ``` **Cache Mechanism Details**: ``` Request → Calculate ETag (FSO metadata, no file content read) ├─> If-None-Match matches → 304 (zero transfer) ├─> Cache hit + ETag unchanged → Memory output (skip disk) ├─> Cache hit + ETag changed → Re-read + update cache └─> No cache → Disk read + lazy cache (only add if ≤ limit) ``` See [Static File Serving - Cache Control](./static-files.md#cache-control) *** ## Status Code Methods ### State Send custom status code response. ```vb Public Sub State(Code As Long, Text As String, Optional Say As String = "Unknown status") ``` *** ### State400 400 Bad Request. ```vb Public Sub State400(Optional Say As String) ``` **Example**: ```vb If Not IsValidParams Then ctx.Response.State400 "Invalid parameters" End If ``` *** ### State401 401 Unauthorized. ```vb Public Sub State401(Optional Say As String) ``` **Example**: ```vb If Not IsAuthenticated Then ctx.Response.State401 "Please login first" End If ``` *** ### State403 403 Forbidden. ```vb Public Sub State403(Optional Say As String) ``` **Example**: ```vb If Not HasPermission Then ctx.Response.State403 "No permission" End If ``` *** ### State404 404 Not Found. ```vb Public Sub State404(Optional Say As String) ``` **Example**: ```vb If Not UserExists(userId) Then ctx.Response.State404 "User not found" End If ``` *** ### State413 413 Payload Too Large. ```vb Public Sub State413(Optional Say As String = "Request Entity Too Large") ``` **Description**: This status code is automatically returned when the request body exceeds the `Server.MaxRequestSize` limit. Can also be called manually. **Example**: ```vb ' Check upload file size If FileSize > MaxAllowedSize Then ctx.Response.State413 "File size exceeds limit" End If ``` *** ### State500 500 Internal Server Error. ```vb Public Sub State500(Optional Say As String) ``` **Example**: ```vb On Error GoTo ErrorHandler ' ... Business logic Exit Sub ErrorHandler: ctx.Response.State500 Err.Description ``` *** ### State502 502 Gateway Error. ```vb Public Sub State502(Optional Say As String) ``` *** ## Configuration Properties ### Header Custom response header dictionary. ```vb Public Header As New Dictionary ``` **Example**: ```vb ctx.Response.Header("X-Custom-Header") = "CustomValue" ctx.Response.Header("Cache-Control") = "no-cache" ``` *** ### CharSet Character encoding (default utf-8). ```vb Public CharSet As String ``` **Example**: ```vb ctx.Response.CharSet = "gb2312" ``` *** ### ContentType Content type. ```vb Public ContentType As String ``` **Example**: ```vb ctx.Response.ContentType = "application/xml" ``` *** ### Status HTTP status string. ```vb Public Status As String ``` *** ### JsonPackFieldNameCode JSON wrapper field name - status code. ```vb Public JsonPackFieldNameCode As String ``` **Default**: `"code"` *** ### JsonPackFieldNameMsg JSON wrapper field name - message. ```vb Public JsonPackFieldNameMsg As String ``` **Default**: `"msg"` *** ### JsonPackFieldNameData JSON wrapper field name - data. ```vb Public JsonPackFieldNameData As String ``` **Default**: `"data"` *** ### JsonPackFieldNameCount JSON wrapper field name - total count. ```vb Public JsonPackFieldNameCount As String ``` **Default**: `"count"` **Example**: ```vb ' Custom JSON response field names ctx.Response.JsonPackFieldNameCode = "status" ctx.Response.JsonPackFieldNameMsg = "message" ctx.Response.JsonPackFieldNameData = "result" ctx.Response.JsonPackFieldNameCount = "total" ' Output: {"status": 0, "message": "OK", "result": {...}, "total": 10} ctx.Response.Json data, 0, "OK", 10 ``` *** ## ASP-compatible Properties | Property | Description | | ----------------- | ------------------------ | | `Buffer` | Output buffering | | `CacheControl` | Cache control | | `CodePage` | Code page | | `Expires` | Expiration time | | `ExpiresAbsolute` | Absolute expiration time | | `LCID` | Locale identifier | *** **Last Updated**: 2026-06-22 --- --- url: /zh/vbman/httpserver/statistics.md --- # cHttpServerStatistics 性能统计 ## 简介 `cHttpServerStatistics` 是 HttpServer 的服务器级性能统计容器，通过 `Public Long` 字段实现零开销递增——无 Dictionary 查找、无 Property 调用，适合高频热路径埋点。 全局唯一实例，在 `cHttpServer.Class_Initialize` 中创建，通过两种途径访问： ```vb ' 方式一：通过 Server 对象（服务端生命周期内始终可用） Server.Statistics.TotalRequests ' 方式二：通过请求上下文（控制器/中间件中使用更自然） ctx.Statistics.TotalRequests ``` 两者指向同一个对象实例，`ctx.Statistics` 仅在 `ProcessHttpRequest` 中做了 `Set .Statistics = Statistics` 引用赋值，无额外开销。 > **生命周期说明**：Statistics 是服务器级单例，`cHttpServerContext.ReleaseRequest` 和 `Release` 均不释放此引用。 *** ## 字段一览 ### 请求统计 | 字段 | 类型 | 说明 | | ----------------- | ---- | ---------------------------- | | `TotalRequests` | Long | 累计请求总数（含正常和异常） | | `GetRequests` | Long | GET 请求数 | | `PostRequests` | Long | POST 请求数 | | `PutRequests` | Long | PUT 请求数 | | `DeleteRequests` | Long | DELETE 请求数 | | `OptionsRequests` | Long | OPTIONS 请求数 | | `HeadRequests` | Long | HEAD 请求数 | | `PatchRequests` | Long | PATCH 请求数 | | `OtherRequests` | Long | 上述以外方法的请求数 | 方法分类由 `IncrementByMethod` 内部完成，基于 `cHttpServerRequest.EnumRequestMethod` 枚举值： | 枚举值 | 常量名 | 递增字段 | | :----: | ------------ | --------------- | | 1 | `ReqPost` | PostRequests | | 2 | `ReqGet` | GetRequests | | 3 | `ReqPut` | PutRequests | | 4 | `ReqDelete` | DeleteRequests | | 5 | `ReqOptions` | OptionsRequests | | 6 | Head | HeadRequests | | 7 | Patch | PatchRequests | | 其他 | — | OtherRequests | ### 状态码统计 | 字段 | 类型 | 说明 | | ----------- | ---- | --------------------------- | | `Status1xx` | Long | 1xx 响应数（Informational） | | `Status2xx` | Long | 2xx 响应数（Success） | | `Status3xx` | Long | 3xx 响应数（Redirection） | | `Status4xx` | Long | 4xx 响应数（Client Error） | | `Status5xx` | Long | 5xx 响应数（Server Error） | 状态码区间由 `IncrementByStatusCode` 内部完成，对传入的实际状态码整除 100 取百位分组。 > **前提**：`cHttpServerResponse.StatusCode` 字段在 `SendHeader` 中赋值。如果响应未走到 `SendHeader`（如连接已断开），StatusCode 为 0，此时不计入任何区间。 ### 连接统计 | 字段 | 类型 | 说明 | | -------------------------- | ---- | -------------------------------------------------- | | `TotalConnectionsAccepted` | Long | 累计接受的连接总数 | | `RejectedConnections` | Long | 因 `MaxConnections` 限制被拒绝的连接数 | | `PeakConnections` | Long | 峰值并发连接数 | | `IdleConnectionsCleaned` | Long | 因空闲超时被 `CleanupIdleConnections` 清理的连接数 | ### 错误统计 | 字段 | 类型 | 说明 | | --------------------- | ---- | --------------------------------------------------- | | `RequestErrors` | Long | 请求处理异常次数（`ProcessHttpRequest` 中 EH 路径） | | `RequestSizeRejected` | Long | 413 Payload Too Large 次数 | | `SSEEntryErrors` | Long | SSE Entry 失败次数（预留字段，当前版本未埋点） | ### 流量统计 | 字段 | 类型 | 说明 | | -------------------- | ---- | -------------- | | `TotalBytesReceived` | Long | 累计接收字节数 | | `TotalBytesSent` | Long | 累计发送字节数 | > **当前状态**：字段已预留，尚未在 `cClientCallback.OnDataArrival` 和 `cHttpServerResponse.SendBodyByte` 中埋点。高流量场景下精确字节数采集可能影响性能，按需开启。 ### SSE 统计 | 字段 | 类型 | 说明 | | ------------------------ | ---- | ------------ | | `SSEConnectionsAccepted` | Long | SSE 连接总数 | ### Session 统计 | 字段 | 类型 | 说明 | | ---------------------- | ---- | ------------------------------------------------------------ | | `TotalSessionsCreated` | Long | 累计创建的 Session 总数（仅 `Session.HasID` 的有效 Session） | ### 时间统计 | 字段 | 类型 | 说明 | | ----------- | ---- | -------------------------------------------- | | `StartTime` | Date | 服务器启动时间（`Start` 方法中赋值为 `Now`） | *** ## 计算属性 ### UptimeSeconds 服务器运行时长（秒）。 ```vb Public Property Get UptimeSeconds() As Long ``` 若 `StartTime = 0`（未启动），返回 0。 ### AverageQPS 每秒平均请求数。 ```vb Public Property Get AverageQPS() As Double ``` 计算方式：`TotalRequests / UptimeSeconds`。运行时长为 0 时返回 0。 *** ## Friend 方法 以下方法供 `cHttpServer` 内部调用，外部无需直接使用。 ### IncrementByMethod 按请求方法枚举值递增对应计数器。 ```vb Friend Sub IncrementByMethod(ByVal MethodValue As Long) ``` 映射关系见上方"请求统计"章节的枚举值表。 ### IncrementByStatusCode 按实际状态码递增对应区间计数器。 ```vb Friend Sub IncrementByStatusCode(ByVal StatusCode As Long) ``` 对 `StatusCode \ 100` 整除取百位，映射到 Status1xx~Status5xx。 ### UpdatePeakConnections 更新峰值连接数（仅在当前值大于历史峰值时更新）。 ```vb Friend Sub UpdatePeakConnections(ByVal CurrentCount As Long) ``` *** ## Reset 方法 重置所有统计计数器为 0，`StartTime` 重置为 `Now`。 ```vb Public Sub Reset() ``` **示例**： ```vb ' 每天零点重置统计 Server.Statistics.Reset ``` *** ## 埋点位置对照表 | 触发位置 | 统计字段 | 说明 | | ------------------------ | -------------------------------------------------------------- | ------------------------ | | `ConnectionRequest` 事件 | TotalConnectionsAccepted, PeakConnections, RejectedConnections | 新连接接入时 | | `Start` 方法 | StartTime = Now | 服务器启动时记录时间基线 | | 413 路径（请求体超限） | RequestSizeRejected | OnDataArrival 检测超限 | | SSE Entry 路径 | SSEConnectionsAccepted | SSE 长连接建立时 | | `Router.Entry` 之后 | TotalRequests, IncrementByMethod, IncrementByStatusCode | 路由完成后统计 | | `Session.HasID` 为 True | TotalSessionsCreated | 有效 Session 创建时 | | EH 错误处理路径 | RequestErrors, TotalRequests | 异常也计入 TotalRequests | | `CleanupIdleConnections` | IdleConnectionsCleaned | 定时器或手动清理时 | *** ## 使用示例 ### 监控接口 在控制器中暴露统计数据的 API 端点： ```vb ' GET /api/stats Public Sub GetStats(ctx As cHttpServerContext) Dim s As cHttpServerStatistics Set s = ctx.Statistics Dim result As New Dictionary ' 请求指标 result("total_requests") = s.TotalRequests result("get_requests") = s.GetRequests result("post_requests") = s.PostRequests ' 状态码分布 result("status_2xx") = s.Status2xx result("status_4xx") = s.Status4xx result("status_5xx") = s.Status5xx ' 连接指标 result("current_connections") = ctx.Server.Parent.ConnectionCount result("peak_connections") = s.PeakConnections result("rejected_connections") = s.RejectedConnections ' 性能指标 result("uptime_seconds") = s.UptimeSeconds result("average_qps") = s.AverageQPS result("request_errors") = s.RequestErrors ctx.Response.Json result, 0, "OK" End Sub ``` ### 错误率告警 ```vb ' 在中间件中检查错误率 Public Sub ErrorRateCheck(ctx As cHttpServerContext) Dim s As cHttpServerStatistics Set s = ctx.Statistics If s.TotalRequests > 100 Then Dim errorRate As Double errorRate = (s.Status5xx + s.RequestErrors) / s.TotalRequests If errorRate > 0.1 Then ' 5xx + 异常占比超过 10%，记录告警 Call WriteAlertLog("错误率过高: " & Format(errorRate, "0.00%")) End If End If End Sub ``` ### 运行时间面板 ```vb Public Sub Dashboard(ctx As cHttpServerContext) Dim s As cHttpServerStatistics Set s = ctx.Statistics Dim html As String html = "

    服务器状态

    " html = html & "

    运行时间: " & s.UptimeSeconds & " 秒

    " html = html & "

    总请求: " & s.TotalRequests & "

    " html = html & "

    平均 QPS: " & Format(s.AverageQPS, "0.00") & "

    " html = html & "

    峰值连接: " & s.PeakConnections & "

    " ctx.Response.Html html End Sub ``` *** ## Long 溢出注意事项 VB6 的 `Long` 类型为 32 位有符号整数，上限 `2,147,483,647`。 | 场景 | QPS | 溢出时间 | | -------- | ------ | -------- | | 低流量 | 10 | ~6.8 年 | | 中流量 | 100 | ~249 天 | | 高流量 | 1,000 | ~24.9 天 | | 极高流量 | 10,000 | ~2.5 天 | **建议**： * 高流量场景（QPS > 1000）下，定期调用 `Reset` 或在达到阈值时记录快照后重置 * 监控接口读取时先检查 `TotalRequests` 是否接近上限，接近时主动告警 * 如需更长区间累计，可在外部维护 `Double` 类型的累加器，定期从 `TotalRequests` 读取增量 *** ## 依赖关系 ``` cHttpServer │ ├── Public Statistics As cHttpServerStatistics ← 服务器持有实例 │ ├── Public Long 字段 × 20+ │ ├── Property Get UptimeSeconds / AverageQPS │ ├── Friend Sub IncrementByMethod / IncrementByStatusCode / UpdatePeakConnections │ └── Public Sub Reset │ └── ProcessHttpRequest └── ctx.Statistics ──→ 同一实例引用 ``` `cHttpServerResponse` 新增 `Public StatusCode As Long` 字段，在 `SendHeader` 中赋值，为 `IncrementByStatusCode` 提供数据源。 *** **最后更新**: 2026-06-13 --- --- url: /en/vbman/httpserver/statistics.md --- # cHttpServerStatistics Performance Statistics ## Overview `cHttpServerStatistics` is the server-level performance statistics container for HttpServer, implementing zero-overhead increment through `Public Long` fields — no Dictionary lookups, no Property calls, suitable for high-frequency hot path instrumentation. The globally unique instance is created in `cHttpServer.Class_Initialize` and accessible via two paths: ```vb ' Method 1: Via Server object (available throughout server lifecycle) Server.Statistics.TotalRequests ' Method 2: Via request context (more natural in controllers/middleware) ctx.Statistics.TotalRequests ``` Both point to the same object instance. `ctx.Statistics` only performs a `Set .Statistics = Statistics` reference assignment in `ProcessHttpRequest`, with no additional overhead. > **Lifecycle Note**: Statistics is a server-level singleton. Neither `cHttpServerContext.ReleaseRequest` nor `Release` releases this reference. *** ## Field Overview ### Request Statistics | Field | Type | Description | | ----------------- | ---- | ------------------------------------------------------------ | | `TotalRequests` | Long | Cumulative total requests (including normal and exceptional) | | `GetRequests` | Long | GET request count | | `PostRequests` | Long | POST request count | | `PutRequests` | Long | PUT request count | | `DeleteRequests` | Long | DELETE request count | | `OptionsRequests` | Long | OPTIONS request count | | `HeadRequests` | Long | HEAD request count | | `PatchRequests` | Long | PATCH request count | | `OtherRequests` | Long | Request count for methods other than above | Method classification is done internally by `IncrementByMethod`, based on `cHttpServerRequest.EnumRequestMethod` enum values: | Enum Value | Constant Name | Incremented Field | | :--------: | ------------- | ----------------- | | 1 | `ReqPost` | PostRequests | | 2 | `ReqGet` | GetRequests | | 3 | `ReqPut` | PutRequests | | 4 | `ReqDelete` | DeleteRequests | | 5 | `ReqOptions` | OptionsRequests | | 6 | Head | HeadRequests | | 7 | Patch | PatchRequests | | Other | — | OtherRequests | ### Status Code Statistics | Field | Type | Description | | ----------- | ---- | ---------------------------------- | | `Status1xx` | Long | 1xx response count (Informational) | | `Status2xx` | Long | 2xx response count (Success) | | `Status3xx` | Long | 3xx response count (Redirection) | | `Status4xx` | Long | 4xx response count (Client Error) | | `Status5xx` | Long | 5xx response count (Server Error) | Status code range classification is done internally by `IncrementByStatusCode`, grouping by the hundreds digit of the actual status code. > **Prerequisite**: `cHttpServerResponse.StatusCode` field is assigned in `SendHeader`. If the response doesn't reach `SendHeader` (e.g., connection already closed), StatusCode is 0 and not counted in any range. ### Connection Statistics | Field | Type | Description | | -------------------------- | ---- | ------------------------------------------------------------------- | | `TotalConnectionsAccepted` | Long | Cumulative total connections accepted | | `RejectedConnections` | Long | Connections rejected due to `MaxConnections` limit | | `PeakConnections` | Long | Peak concurrent connections | | `IdleConnectionsCleaned` | Long | Connections cleaned by `CleanupIdleConnections` due to idle timeout | ### Error Statistics | Field | Type | Description | | --------------------- | ---- | ----------------------------------------------------------------------------- | | `RequestErrors` | Long | Request processing exceptions (EH path in `ProcessHttpRequest`) | | `RequestSizeRejected` | Long | 413 Payload Too Large count | | `SSEEntryErrors` | Long | SSE Entry failure count (reserved field, not instrumented in current version) | ### Traffic Statistics | Field | Type | Description | | -------------------- | ---- | ------------------------- | | `TotalBytesReceived` | Long | Cumulative bytes received | | `TotalBytesSent` | Long | Cumulative bytes sent | > **Current Status**: Fields are reserved but not yet instrumented in `cClientCallback.OnDataArrival` and `cHttpServerResponse.SendBodyByte`. Precise byte counting in high-traffic scenarios may impact performance; enable as needed. ### SSE Statistics | Field | Type | Description | | ------------------------ | ---- | --------------------- | | `SSEConnectionsAccepted` | Long | Total SSE connections | ### Session Statistics | Field | Type | Description | | ---------------------- | ---- | ---------------------------------------------------------------------------- | | `TotalSessionsCreated` | Long | Cumulative total sessions created (only valid sessions with `Session.HasID`) | ### Time Statistics | Field | Type | Description | | ----------- | ---- | ---------------------------------------------------- | | `StartTime` | Date | Server start time (assigned `Now` in `Start` method) | *** ## Computed Properties ### UptimeSeconds Server uptime in seconds. ```vb Public Property Get UptimeSeconds() As Long ``` Returns 0 if `StartTime = 0` (not started). ### AverageQPS Average requests per second. ```vb Public Property Get AverageQPS() As Double ``` Calculation: `TotalRequests / UptimeSeconds`. Returns 0 when uptime is 0. *** ## Friend Methods The following methods are for internal `cHttpServer` use; external code does not need to call them directly. ### IncrementByMethod Increment the corresponding counter by request method enum value. ```vb Friend Sub IncrementByMethod(ByVal MethodValue As Long) ``` See the enum value table in the "Request Statistics" section above for mapping. ### IncrementByStatusCode Increment the corresponding range counter by actual status code. ```vb Friend Sub IncrementByStatusCode(ByVal StatusCode As Long) ``` Divides `StatusCode \ 100` to get the hundreds digit, mapping to Status1xx~Status5xx. ### UpdatePeakConnections Update peak connections (only updates when current value exceeds historical peak). ```vb Friend Sub UpdatePeakConnections(ByVal CurrentCount As Long) ``` *** ## Reset Method Reset all statistics counters to 0, `StartTime` reset to `Now`. ```vb Public Sub Reset() ``` **Example**: ```vb ' Reset statistics daily at midnight Server.Statistics.Reset ``` *** ## Instrumentation Location Reference | Trigger Location | Statistics Fields | Description | | -------------------------------- | -------------------------------------------------------------- | ---------------------------------------- | | `ConnectionRequest` event | TotalConnectionsAccepted, PeakConnections, RejectedConnections | On new connection | | `Start` method | StartTime = Now | Record time baseline on server start | | 413 path (request body exceeded) | RequestSizeRejected | OnDataArrival detects limit exceeded | | SSE Entry path | SSEConnectionsAccepted | When SSE long connection established | | After `Router.Entry` | TotalRequests, IncrementByMethod, IncrementByStatusCode | Statistics after routing completes | | `Session.HasID` is True | TotalSessionsCreated | When valid Session created | | EH error handling path | RequestErrors, TotalRequests | Exceptions also counted in TotalRequests | | `CleanupIdleConnections` | IdleConnectionsCleaned | On timer or manual cleanup | *** ## Usage Examples ### Monitoring Endpoint Expose a statistics API endpoint in a controller: ```vb ' GET /api/stats Public Sub GetStats(ctx As cHttpServerContext) Dim s As cHttpServerStatistics Set s = ctx.Statistics Dim result As New Dictionary ' Request metrics result("total_requests") = s.TotalRequests result("get_requests") = s.GetRequests result("post_requests") = s.PostRequests ' Status code distribution result("status_2xx") = s.Status2xx result("status_4xx") = s.Status4xx result("status_5xx") = s.Status5xx ' Connection metrics result("current_connections") = ctx.Server.Parent.ConnectionCount result("peak_connections") = s.PeakConnections result("rejected_connections") = s.RejectedConnections ' Performance metrics result("uptime_seconds") = s.UptimeSeconds result("average_qps") = s.AverageQPS result("request_errors") = s.RequestErrors ctx.Response.Json result, 0, "OK" End Sub ``` ### Error Rate Alerting ```vb ' Check error rate in middleware Public Sub ErrorRateCheck(ctx As cHttpServerContext) Dim s As cHttpServerStatistics Set s = ctx.Statistics If s.TotalRequests > 100 Then Dim errorRate As Double errorRate = (s.Status5xx + s.RequestErrors) / s.TotalRequests If errorRate > 0.1 Then ' 5xx + exceptions exceed 10%, log alert Call WriteAlertLog("Error rate too high: " & Format(errorRate, "0.00%")) End If End If End Sub ``` ### Runtime Dashboard ```vb Public Sub Dashboard(ctx As cHttpServerContext) Dim s As cHttpServerStatistics Set s = ctx.Statistics Dim html As String html = "

    Server Status

    " html = html & "

    Uptime: " & s.UptimeSeconds & " seconds

    " html = html & "

    Total Requests: " & s.TotalRequests & "

    " html = html & "

    Average QPS: " & Format(s.AverageQPS, "0.00") & "

    " html = html & "

    Peak Connections: " & s.PeakConnections & "

    " ctx.Response.Html html End Sub ``` *** ## Long Overflow Considerations VB6 `Long` type is a 32-bit signed integer with an upper limit of `2,147,483,647`. | Scenario | QPS | Overflow Time | | ----------------- | ------ | ------------- | | Low traffic | 10 | ~6.8 years | | Medium traffic | 100 | ~249 days | | High traffic | 1,000 | ~24.9 days | | Very high traffic | 10,000 | ~2.5 days | **Recommendations**: * In high-traffic scenarios (QPS > 1000), periodically call `Reset` or record a snapshot when approaching the threshold and then reset * When reading from the monitoring endpoint, first check if `TotalRequests` is approaching the limit, and proactively alert * For longer accumulation periods, maintain a `Double` type accumulator externally, periodically reading increments from `TotalRequests` *** ## Dependencies ``` cHttpServer │ ├── Public Statistics As cHttpServerStatistics ← Server holds instance │ ├── Public Long fields × 20+ │ ├── Property Get UptimeSeconds / AverageQPS │ ├── Friend Sub IncrementByMethod / IncrementByStatusCode / UpdatePeakConnections │ └── Public Sub Reset │ └── ProcessHttpRequest └── ctx.Statistics ──→ Same instance reference ``` `cHttpServerResponse` adds `Public StatusCode As Long` field, assigned in `SendHeader`, providing data source for `IncrementByStatusCode`. *** **Last Updated**: 2026-06-13 --- --- url: /zh/vbman/tools/image.md --- # cImage - 图片数据互转类 ## 概述 `cImage` 提供了 `Byte()` ↔ `Base64` ↔ `StdPicture` 三种图片数据格式的互转功能，采用链式调用设计，一行代码即可完成复杂转换。 通过 `VBMAN.Image` 全局静态实例直接使用，无需手动实例化。 ## 核心特性 * **链式调用**: 流畅的 API 设计，一行代码完成转换 + 输出 * **三种格式互转**: 字节数组、Base64 字符串、StdPicture 对象之间自由转换 * **Data URI 支持**: 自动解析 `data:image/jpeg;base64,...` 格式 * **MIME 类型检测**: 通过文件魔数自动识别 JPEG/PNG/GIF/BMP/WebP/ICO * **控件直赋**: `ShowTo` 方法直接将图片显示到 Image/PictureBox 控件 * **默认成员**: `Data` 方法为默认成员，支持 `VBMAN.Image.(base64Str)` 简写 ## 调用方式 ```vb ' 全局静态实例（推荐） VBMAN.Image.Data(base64Str).ReturnPicture ' 简写法（利用默认成员） VBMAN.Image.(base64Str).ReturnPicture ' 独立实例 Dim img As New cImage Set Image1.Picture = img.Data(bytesArr).ReturnPicture ``` ## 方法总览 ### 链式入口方法 | 方法 | 说明 | 返回 | |------|------|------| | [Data](#data) | 设置数据源（默认成员） | `cImage` (Me) | ### 链式辅助方法 | 方法 | 说明 | 返回 | |------|------|------| | [SetMimeType](#setmimetype) | 手动设置 MIME 类型 | `cImage` (Me) | | [ShowTo](#showto) | 将图片显示到目标控件 | `cImage` (Me) | ### 输出方法（终结方法） | 方法 | 说明 | 返回 | |------|------|------| | [ReturnBytes](#returnbytes) | 输出为字节数组 | `Byte()` | | [ReturnBase64](#returnbase64) | 输出为 Base64 字符串 | `String` | | [ReturnPicture](#returnpicture) | 输出为 StdPicture 对象 | `StdPicture` | | [ReturnDataUri](#returndatauri) | 输出为 Data URI 字符串 | `String` | | [ReturnMimeType](#returnmimetype) | 返回检测到的 MIME 类型 | `String` | ### 检查方法 | 方法 | 说明 | 返回 | |------|------|------| | [IsValid](#isvalid) | 检查数据是否有效 | `Boolean` | *** ## 方法详解 ### Data 链式调用入口，接受三种数据类型。为默认成员，支持简写 `VBMAN.Image.(data)`。 ```vb Public Function Data(ByVal vData As Variant) As cImage ``` **参数**: | 参数名 | 类型 | 说明 | |--------|------|------| | `vData` | Variant | 数据源，支持 Byte() 数组、Base64 字符串、StdPicture 对象 | **支持的输入类型**: | 类型 | 判断依据 | 示例 | |------|----------|------| | Byte() 数组 | `VarType = vbArray Or vbByte` | 读取图片文件的字节数据 | | Base64 字符串 | `VarType = vbString` | API 返回的头像 Base64 | | Data URI 字符串 | 以 `data:` 开头 | `data:image/png;base64,...` | | StdPicture 对象 | `IsObject(vData)` | `Image1.Picture` | **Data URI 自动解析**: 传入 `data:image/jpeg;base64,xxxxx` 格式的字符串时，自动提取 MIME 类型并剥离前缀，仅保留纯 Base64 部分。 **返回**: `cImage` (Me)，支持链式调用 **示例**: ```vb ' 从 Base64 字符串 VBMAN.Image.Data("/9j/4AAQ...").ReturnPicture ' 从字节数组 Dim bytes() As Byte bytes = VBMAN.FileEx.OpenFile("photo.jpg", "R").ReadData.ReturnBytes VBMAN.FileEx.CloseFile VBMAN.Image.Data(bytes).ReturnBase64 ' 从 StdPicture VBMAN.Image.Data(Image1.Picture).ReturnBase64 ' 简写法（利用默认成员） VBMAN.Image.("/9j/4AAQ...").ReturnPicture ' Data URI 格式自动解析 VBMAN.Image.("data:image/png;base64,iVBOR...").ReturnPicture ``` *** ### SetMimeType 手动设置 MIME 类型，用于覆盖自动检测结果或补充无法检测的格式。 ```vb Public Function SetMimeType(ByVal MimeType As String) As cImage ``` **参数**: | 参数名 | 类型 | 说明 | |--------|------|------| | `MimeType` | String | MIME 类型，如 `"image/jpeg"`、`"image/png"` | **返回**: `cImage` (Me)，支持链式调用 **示例**: ```vb ' 手动指定 MIME 类型（影响 ReturnDataUri 输出） VBMAN.Image.Data(bytes).SetMimeType("image/png").ReturnDataUri ' 从 StdPicture 获取时无法自动检测格式，需手动指定 VBMAN.Image.Data(Image1.Picture).SetMimeType("image/bmp").ReturnDataUri ``` *** ### ShowTo 将图片直接显示到目标控件，是最便捷的显示方式。 ```vb Public Function ShowTo(ByVal Target As Object) As cImage ``` **参数**: | 参数名 | 类型 | 说明 | |--------|------|------| | `Target` | Object | 任何拥有 `Picture` 属性的控件对象（Image、PictureBox 等） | **返回**: `cImage` (Me)，支持链式调用 **示例**: ```vb ' 传统写法 - 需要 Set 关键字 Set Image1.Picture = VBMAN.Image.Data(base64Str).ReturnPicture ' 简写法 - 一行搞定 VBMAN.Image.(base64Str).ShowTo Image1 ' 链式显示后再获取 Base64 Dim b64 As String b64 = VBMAN.Image.(base64Str).ShowTo(Image1).ReturnBase64 ' 显示到 PictureBox VBMAN.Image.(bytesArr).ShowTo Picture1 ' 从 StdPicture 显示到另一个控件 VBMAN.Image.Data(Picture1.Picture).ShowTo Image2 ``` *** ### ReturnBytes 将图片数据转换为字节数组输出。 ```vb Public Function ReturnBytes() As Byte() ``` **返回**: `Byte()` 字节数组 **示例**: ```vb ' Base64 → 字节数组 Dim bytes() As Byte bytes = VBMAN.Image.Data(base64Str).ReturnBytes ' StdPicture → 字节数组（可用于保存图片） Dim picBytes() As Byte picBytes = VBMAN.Image.Data(Image1.Picture).ReturnBytes ' 将字节数组写入文件 VBMAN.FileEx.SetBufferBytes(bytes).SaveData "C:\output.jpg" ``` *** ### ReturnBase64 将图片数据转换为 Base64 字符串输出。 ```vb Public Function ReturnBase64() As String ``` **返回**: `String` - 纯 Base64 字符串（不含 `data:` 前缀） **示例**: ```vb ' 字节数组 → Base64 Dim b64 As String b64 = VBMAN.Image.Data(bytes).ReturnBase64 ' StdPicture → Base64 Dim picB64 As String picB64 = VBMAN.Image.Data(Image1.Picture).ReturnBase64 ' 用于 API 请求 Dim json As New cJson json("avatar") = VBMAN.Image.Data(Image1.Picture).ReturnBase64 Dim resp As String resp = VBMAN.HttpClient.SetUrl("/api/upload").SetBody(json.Encode).Post ``` *** ### ReturnPicture 将图片数据转换为 StdPicture 对象输出，可直接赋给控件的 Picture 属性。 ```vb Public Function ReturnPicture() As StdPicture ``` **返回**: `StdPicture` 对象 **示例**: ```vb ' Base64 → StdPicture Set Image1.Picture = VBMAN.Image.Data(base64Str).ReturnPicture ' 字节数组 → StdPicture Set Image1.Picture = VBMAN.Image.Data(bytes).ReturnPicture ' Data URI → StdPicture Set Image1.Picture = VBMAN.Image.("data:image/png;base64,iVBOR...").ReturnPicture ``` *** ### ReturnDataUri 将图片数据转换为 Data URI 格式字符串输出，适合直接嵌入 HTML/CSS。 ```vb Public Function ReturnDataUri(Optional ByVal MimeType As String) As String ``` **参数**: | 参数名 | 类型 | 必填 | 说明 | |--------|------|------|------| | `MimeType` | String | 否 | MIME 类型，省略时使用自动检测或默认 `image/jpeg` | **返回**: `String` - Data URI 格式字符串，如 `data:image/png;base64,iVBORw0KGgo...` **示例**: ```vb ' 自动检测 MIME 类型 Dim uri As String uri = VBMAN.Image.Data(bytes).ReturnDataUri ' 输出: data:image/jpeg;base64,/9j/4AAQ... ' 手动指定 MIME 类型 uri = VBMAN.Image.Data(bytes).SetMimeType("image/png").ReturnDataUri ' 输出: data:image/png;base64,iVBORw0KGgo... ' 嵌入 HTML Dim html As String html = "" WebBrowser1.Document.Write html ' 从 Base64 生成 Data URI uri = VBMAN.Image.Data(base64Str).ReturnDataUri("image/png") ``` *** ### ReturnMimeType 返回自动检测到的图片 MIME 类型。 ```vb Public Function ReturnMimeType() As String ``` **返回**: `String` - MIME 类型字符串 **支持的检测格式**: | 格式 | 魔数 (Hex) | MIME 类型 | |------|-----------|-----------| | JPEG | `FF D8 FF` | `image/jpeg` | | PNG | `89 50 4E 47` | `image/png` | | GIF | `47 49 46` | `image/gif` | | BMP | `42 4D` | `image/bmp` | | WebP | `52 49 46 46 ... 57 45 42 50` | `image/webp` | | ICO | `00 00 01 00` | `image/x-icon` | **示例**: ```vb ' 检测图片类型 Dim mime As String mime = VBMAN.Image.Data(bytes).ReturnMimeType Debug.Print mime ' 输出: image/png ' 判断类型后分别处理 Select Case mime Case "image/jpeg" ' JPEG 处理逻辑 Case "image/png" ' PNG 处理逻辑 Case Else ' 其他格式 End Select ``` *** ### IsValid 检查数据源是否有效（是否已通过 `Data` 方法设置了数据）。 ```vb Public Function IsValid() As Boolean ``` **返回**: `Boolean` - 数据有效时返回 `True` **示例**: ```vb Dim img As New cImage img.Data(base64Str) If img.IsValid Then Set Image1.Picture = img.ReturnPicture Else MsgBox "图片数据无效！" End If ``` *** ## 综合示例 ### 示例1: API 头像显示 从 API 获取用户头像 Base64，直接显示到 Image 控件： ```vb Private Sub LoadUserAvatar(userId As Long) ' 从 API 获取头像 Base64 Dim resp As String resp = VBMAN.HttpClient.SetUrl("/api/user/" & userId & "/avatar").Get ' 解析 JSON 获取 avatar 字段 Dim json As cJson Set json = VBMAN.Json.Decode(resp) Dim avatarB64 As String avatarB64 = json("avatar") ' 显示到 Image 控件（一行搞定） VBMAN.Image.(avatarB64).ShowTo Image1 End Sub ``` ### 示例2: 图片上传到服务器 将本地图片转为 Base64 后上传到 API： ```vb Private Sub UploadImage(filePath As String) ' 读取图片文件为字节数组 VBMAN.FileEx.OpenFile filePath, "R" Dim bytes() As Byte bytes = VBMAN.FileEx.ReadData.ReturnBytes VBMAN.FileEx.CloseFile ' 转为 Base64 并检测类型 Dim img As cImage Set img = VBMAN.Image.Data(bytes) Dim b64 As String b64 = img.ReturnBase64 Dim mime As String mime = img.ReturnMimeType ' 构建请求 JSON Dim json As New cJson json("image") = b64 json("mime_type") = mime ' 上传 Dim resp As String resp = VBMAN.HttpClient _ .SetUrl("/api/upload") _ .SetBody(json.Encode) _ .Post End Sub ``` ### 示例3: 图片 Data URI 嵌入 HTML 将图片转为 Data URI 嵌入 WebBrowser 页面： ```vb Private Sub ShowEmbeddedImage(filePath As String) ' 读取图片 VBMAN.FileEx.OpenFile filePath, "R" Dim bytes() As Byte bytes = VBMAN.FileEx.ReadData.ReturnBytes VBMAN.FileEx.CloseFile ' 获取 Data URI Dim dataUri As String dataUri = VBMAN.Image.Data(bytes).ReturnDataUri ' 嵌入 HTML Dim html As String html = "" & _ "" & _ "" WebBrowser1.Document.Write html End Sub ``` ### 示例4: 图片格式互转全流程 完整演示三种格式之间的互转： ```vb Private Sub TestImageConversion() Dim img As cImage ' 1. 字节数组 → Base64 + StdPicture + Data URI Dim bytes() As Byte bytes = VBMAN.FileEx.OpenFile("C:\photo.jpg", "R").ReadData.ReturnBytes VBMAN.FileEx.CloseFile Set img = VBMAN.Image.Data(bytes) Debug.Print "MIME: " & img.ReturnMimeType ' image/jpeg Debug.Print "Base64长度: " & Len(img.ReturnBase64) Set Image1.Picture = img.ReturnPicture ' 2. Base64 → 字节数组 + StdPicture Dim b64 As String b64 = img.ReturnBase64 Set img = VBMAN.Image.Data(b64) Dim newBytes() As Byte newBytes = img.ReturnBytes Set Image2.Picture = img.ReturnPicture ' 3. StdPicture → Base64 + 字节数组 Set img = VBMAN.Image.Data(Image2.Picture) Dim picB64 As String picB64 = img.SetMimeType("image/bmp").ReturnBase64 Dim picBytes() As Byte picBytes = img.ReturnBytes Debug.Print "转换完成！" End Sub ``` ### 示例5: 批量头像显示 从数据库批量获取头像 Base64 并显示到多个控件： ```vb Private Sub LoadAllAvatars() ' 查询所有用户头像 VBMAN.Db.Sql("SELECT id, avatar FROM users").Fetch Dim i As Long For i = 0 To VBMAN.Db.RowCount - 1 VBMAN.Db.Row i ' 根据用户 ID 找到对应的 Image 控件 Dim ctrlName As String ctrlName = "imgAvatar" & VBMAN.Db.Field("id") ' 一行代码显示头像 VBMAN.Image.(VBMAN.Db.Field("avatar")).ShowTo Me.Controls(ctrlName) Next i End Sub ``` *** ## 转换流程图 ``` ┌─────────────┐ │ Data() │ ← 链式入口（默认成员） └─────────────┘ │ ┌───────────────┼───────────────┐ │ │ │ Byte() 数组 Base64 字符串 StdPicture │ │ │ └───────────────┼───────────────┘ │ ┌───────────┼───────────┐ │ │ │ ReturnBytes ReturnBase64 ReturnPicture │ │ │ │ ReturnDataUri ShowTo(控件) │ │ │ └───────────┼───────────┘ │ ┌─────────────┐ │ ReturnMimeType │ ← MIME 类型检测 └─────────────┘ ``` ## 注意事项 1. **StdPicture → 字节数组**: 内部通过 `SavePicture` 保存临时文件再读取，输出为 BMP 格式 2. **MIME 类型检测**: 仅对字节数组输入有效，Base64 和 StdPicture 输入需手动指定 3. **Data URI 格式**: `ReturnBase64` 返回纯 Base64，`ReturnDataUri` 返回带 `data:` 前缀的完整格式 4. **GDI+ 初始化**: 类内部自动管理 GDI+ 生命周期，首次使用时初始化，类销毁时释放 5. **线程安全**: `VBMAN.Image` 是全局共享实例，如需多个独立转换任务，应创建 `New cImage` ## 最佳实践 1. **显示优先用 ShowTo**: 比 `Set Image1.Picture = ...ReturnPicture` 更简洁 2. **简写法**: `VBMAN.Image.(base64Str)` 比完整写法更直观 3. **API 场景**: 接收 Base64 图片 → `ShowTo` 显示；发送图片 → `ReturnBase64` 编码 4. **HTML 嵌入**: 使用 `ReturnDataUri` 生成可直接嵌入的格式 5. **格式确认**: 上传图片时用 `ReturnMimeType` 获取类型，随请求一起发送 6. **独立实例**: 多线程或批量转换场景应 `New cImage` 创建独立实例 --- --- url: /en/vbman/tools/image.md --- # cImage - Image Data Conversion Class ## Overview `cImage` provides mutual conversion functionality between `Byte()` ↔ `Base64` ↔ `StdPicture` image data formats, using a chained call design that allows complex conversions in a single line of code. Accessible directly through the `VBMAN.Image` global static instance without manual instantiation. ## Core Features * **Chained Calls**: Fluent API design, one line to complete conversion + output * **Three-Format Conversion**: Free conversion between byte arrays, Base64 strings, and StdPicture objects * **Data URI Support**: Automatically parses `data:image/jpeg;base64,...` format * **MIME Type Detection**: Automatically identifies JPEG/PNG/GIF/BMP/WebP/ICO via file magic numbers * **Direct Control Assignment**: `ShowTo` method directly displays images to Image/PictureBox controls * **Default Member**: `Data` method is the default member, supporting `VBMAN.Image.(base64Str)` shorthand ## Usage Patterns ```vb ' Global static instance (recommended) VBMAN.Image.Data(base64Str).ReturnPicture ' Shorthand (using default member) VBMAN.Image.(base64Str).ReturnPicture ' Independent instance Dim img As New cImage Set Image1.Picture = img.Data(bytesArr).ReturnPicture ``` ## Method Overview ### Chained Entry Method | Method | Description | Return | |--------|-------------|--------| | [Data](#data) | Set data source (default member) | `cImage` (Me) | ### Chained Helper Methods | Method | Description | Return | |--------|-------------|--------| | [SetMimeType](#setmimetype) | Manually set MIME type | `cImage` (Me) | | [ShowTo](#showto) | Display image to target control | `cImage` (Me) | ### Output Methods (Terminal Methods) | Method | Description | Return | |--------|-------------|--------| | [ReturnBytes](#returnbytes) | Output as byte array | `Byte()` | | [ReturnBase64](#returnbase64) | Output as Base64 string | `String` | | [ReturnPicture](#returnpicture) | Output as StdPicture object | `StdPicture` | | [ReturnDataUri](#returndatauri) | Output as Data URI string | `String` | | [ReturnMimeType](#returnmimetype) | Return detected MIME type | `String` | ### Check Method | Method | Description | Return | |--------|-------------|--------| | [IsValid](#isvalid) | Check if data is valid | `Boolean` | *** ## Method Details ### Data Chained call entry point, accepts three data types. Default member, supports shorthand `VBMAN.Image.(data)`. ```vb Public Function Data(ByVal vData As Variant) As cImage ``` **Parameters**: | Parameter | Type | Description | |-----------|------|-------------| | `vData` | Variant | Data source, supports Byte() array, Base64 string, StdPicture object | **Supported Input Types**: | Type | Detection Basis | Example | |------|-----------------|---------| | Byte() array | `VarType = vbArray Or vbByte` | Byte data from reading an image file | | Base64 string | `VarType = vbString` | Avatar Base64 returned by API | | Data URI string | Starts with `data:` | `data:image/png;base64,...` | | StdPicture object | `IsObject(vData)` | `Image1.Picture` | **Data URI Auto-Parsing**: When a `data:image/jpeg;base64,xxxxx` format string is passed, the MIME type is automatically extracted and the prefix stripped, keeping only the pure Base64 portion. **Return**: `cImage` (Me), supports chained calls **Example**: ```vb ' From Base64 string VBMAN.Image.Data("/9j/4AAQ...").ReturnPicture ' From byte array Dim bytes() As Byte bytes = VBMAN.FileEx.OpenFile("photo.jpg", "R").ReadData.ReturnBytes VBMAN.FileEx.CloseFile VBMAN.Image.Data(bytes).ReturnBase64 ' From StdPicture VBMAN.Image.Data(Image1.Picture).ReturnBase64 ' Shorthand (using default member) VBMAN.Image.("/9j/4AAQ...").ReturnPicture ' Data URI format auto-parsing VBMAN.Image.("data:image/png;base64,iVBOR...").ReturnPicture ``` *** ### SetMimeType Manually set MIME type to override auto-detection results or supplement undetectable formats. ```vb Public Function SetMimeType(ByVal MimeType As String) As cImage ``` **Parameters**: | Parameter | Type | Description | |-----------|------|-------------| | `MimeType` | String | MIME type, e.g., `"image/jpeg"`, `"image/png"` | **Return**: `cImage` (Me), supports chained calls **Example**: ```vb ' Manually specify MIME type (affects ReturnDataUri output) VBMAN.Image.Data(bytes).SetMimeType("image/png").ReturnDataUri ' From StdPicture, cannot auto-detect format, need manual specification VBMAN.Image.Data(Image1.Picture).SetMimeType("image/bmp").ReturnDataUri ``` *** ### ShowTo Directly display image to the target control, the most convenient display method. ```vb Public Function ShowTo(ByVal Target As Object) As cImage ``` **Parameters**: | Parameter | Type | Description | |-----------|------|-------------| | `Target` | Object | Any control object with a `Picture` property (Image, PictureBox, etc.) | **Return**: `cImage` (Me), supports chained calls **Example**: ```vb ' Traditional approach - requires Set keyword Set Image1.Picture = VBMAN.Image.Data(base64Str).ReturnPicture ' Shorthand - one line VBMAN.Image.(base64Str).ShowTo Image1 ' Chain display then get Base64 Dim b64 As String b64 = VBMAN.Image.(base64Str).ShowTo(Image1).ReturnBase64 ' Display to PictureBox VBMAN.Image.(bytesArr).ShowTo Picture1 ' From StdPicture display to another control VBMAN.Image.Data(Picture1.Picture).ShowTo Image2 ``` *** ### ReturnBytes Convert image data to byte array output. ```vb Public Function ReturnBytes() As Byte() ``` **Return**: `Byte()` byte array **Example**: ```vb ' Base64 → byte array Dim bytes() As Byte bytes = VBMAN.Image.Data(base64Str).ReturnBytes ' StdPicture → byte array (can be used to save image) Dim picBytes() As Byte picBytes = VBMAN.Image.Data(Image1.Picture).ReturnBytes ' Write byte array to file VBMAN.FileEx.SetBufferBytes(bytes).SaveData "C:\output.jpg" ``` *** ### ReturnBase64 Convert image data to Base64 string output. ```vb Public Function ReturnBase64() As String ``` **Return**: `String` - Pure Base64 string (without `data:` prefix) **Example**: ```vb ' Byte array → Base64 Dim b64 As String b64 = VBMAN.Image.Data(bytes).ReturnBase64 ' StdPicture → Base64 Dim picB64 As String picB64 = VBMAN.Image.Data(Image1.Picture).ReturnBase64 ' For API request Dim json As New cJson json("avatar") = VBMAN.Image.Data(Image1.Picture).ReturnBase64 Dim resp As String resp = VBMAN.HttpClient.SetUrl("/api/upload").SetBody(json.Encode).Post ``` *** ### ReturnPicture Convert image data to StdPicture object output, can be directly assigned to control's Picture property. ```vb Public Function ReturnPicture() As StdPicture ``` **Return**: `StdPicture` object **Example**: ```vb ' Base64 → StdPicture Set Image1.Picture = VBMAN.Image.Data(base64Str).ReturnPicture ' Byte array → StdPicture Set Image1.Picture = VBMAN.Image.Data(bytes).ReturnPicture ' Data URI → StdPicture Set Image1.Picture = VBMAN.Image.("data:image/png;base64,iVBOR...").ReturnPicture ``` *** ### ReturnDataUri Convert image data to Data URI format string output, suitable for direct embedding in HTML/CSS. ```vb Public Function ReturnDataUri(Optional ByVal MimeType As String) As String ``` **Parameters**: | Parameter | Type | Required | Description | |-----------|------|----------|-------------| | `MimeType` | String | No | MIME type. When omitted, uses auto-detection or defaults to `image/jpeg` | **Return**: `String` - Data URI format string, e.g., `data:image/png;base64,iVBORw0KGgo...` **Example**: ```vb ' Auto-detect MIME type Dim uri As String uri = VBMAN.Image.Data(bytes).ReturnDataUri ' Output: data:image/jpeg;base64,/9j/4AAQ... ' Manually specify MIME type uri = VBMAN.Image.Data(bytes).SetMimeType("image/png").ReturnDataUri ' Output: data:image/png;base64,iVBORw0KGgo... ' Embed in HTML Dim html As String html = "" WebBrowser1.Document.Write html ' Generate Data URI from Base64 uri = VBMAN.Image.Data(base64Str).ReturnDataUri("image/png") ``` *** ### ReturnMimeType Returns the auto-detected image MIME type. ```vb Public Function ReturnMimeType() As String ``` **Return**: `String` - MIME type string **Supported Detection Formats**: | Format | Magic Number (Hex) | MIME Type | |--------|--------------------|-----------| | JPEG | `FF D8 FF` | `image/jpeg` | | PNG | `89 50 4E 47` | `image/png` | | GIF | `47 49 46` | `image/gif` | | BMP | `42 4D` | `image/bmp` | | WebP | `52 49 46 46 ... 57 45 42 50` | `image/webp` | | ICO | `00 00 01 00` | `image/x-icon` | **Example**: ```vb ' Detect image type Dim mime As String mime = VBMAN.Image.Data(bytes).ReturnMimeType Debug.Print mime ' Output: image/png ' Process based on type Select Case mime Case "image/jpeg" ' JPEG processing logic Case "image/png" ' PNG processing logic Case Else ' Other formats End Select ``` *** ### IsValid Check if the data source is valid (whether data has been set via the `Data` method). ```vb Public Function IsValid() As Boolean ``` **Return**: `Boolean` - Returns `True` when data is valid **Example**: ```vb Dim img As New cImage img.Data(base64Str) If img.IsValid Then Set Image1.Picture = img.ReturnPicture Else MsgBox "Image data is invalid!" End If ``` *** ## Comprehensive Examples ### Example 1: API Avatar Display Get user avatar Base64 from API and display directly to Image control: ```vb Private Sub LoadUserAvatar(userId As Long) ' Get avatar Base64 from API Dim resp As String resp = VBMAN.HttpClient.SetUrl("/api/user/" & userId & "/avatar").Get ' Parse JSON to get avatar field Dim json As cJson Set json = VBMAN.Json.Decode(resp) Dim avatarB64 As String avatarB64 = json("avatar") ' Display to Image control (one line) VBMAN.Image.(avatarB64).ShowTo Image1 End Sub ``` ### Example 2: Image Upload to Server Convert local image to Base64 and upload to API: ```vb Private Sub UploadImage(filePath As String) ' Read image file as byte array VBMAN.FileEx.OpenFile filePath, "R" Dim bytes() As Byte bytes = VBMAN.FileEx.ReadData.ReturnBytes VBMAN.FileEx.CloseFile ' Convert to Base64 and detect type Dim img As cImage Set img = VBMAN.Image.Data(bytes) Dim b64 As String b64 = img.ReturnBase64 Dim mime As String mime = img.ReturnMimeType ' Build request JSON Dim json As New cJson json("image") = b64 json("mime_type") = mime ' Upload Dim resp As String resp = VBMAN.HttpClient _ .SetUrl("/api/upload") _ .SetBody(json.Encode) _ .Post End Sub ``` ### Example 3: Image Data URI Embedding in HTML Convert image to Data URI and embed in WebBrowser page: ```vb Private Sub ShowEmbeddedImage(filePath As String) ' Read image VBMAN.FileEx.OpenFile filePath, "R" Dim bytes() As Byte bytes = VBMAN.FileEx.ReadData.ReturnBytes VBMAN.FileEx.CloseFile ' Get Data URI Dim dataUri As String dataUri = VBMAN.Image.Data(bytes).ReturnDataUri ' Embed in HTML Dim html As String html = "" & _ "" & _ "" WebBrowser1.Document.Write html End Sub ``` ### Example 4: Full Image Format Conversion Flow Complete demonstration of conversion between the three formats: ```vb Private Sub TestImageConversion() Dim img As cImage ' 1. Byte array → Base64 + StdPicture + Data URI Dim bytes() As Byte bytes = VBMAN.FileEx.OpenFile("C:\photo.jpg", "R").ReadData.ReturnBytes VBMAN.FileEx.CloseFile Set img = VBMAN.Image.Data(bytes) Debug.Print "MIME: " & img.ReturnMimeType ' image/jpeg Debug.Print "Base64 length: " & Len(img.ReturnBase64) Set Image1.Picture = img.ReturnPicture ' 2. Base64 → byte array + StdPicture Dim b64 As String b64 = img.ReturnBase64 Set img = VBMAN.Image.Data(b64) Dim newBytes() As Byte newBytes = img.ReturnBytes Set Image2.Picture = img.ReturnPicture ' 3. StdPicture → Base64 + byte array Set img = VBMAN.Image.Data(Image2.Picture) Dim picB64 As String picB64 = img.SetMimeType("image/bmp").ReturnBase64 Dim picBytes() As Byte picBytes = img.ReturnBytes Debug.Print "Conversion complete!" End Sub ``` ### Example 5: Batch Avatar Display Get avatar Base64 from database in batch and display to multiple controls: ```vb Private Sub LoadAllAvatars() ' Query all user avatars VBMAN.Db.Sql("SELECT id, avatar FROM users").Fetch Dim i As Long For i = 0 To VBMAN.Db.RowCount - 1 VBMAN.Db.Row i ' Find corresponding Image control by user ID Dim ctrlName As String ctrlName = "imgAvatar" & VBMAN.Db.Field("id") ' Display avatar in one line VBMAN.Image.(VBMAN.Db.Field("avatar")).ShowTo Me.Controls(ctrlName) Next i End Sub ``` *** ## Conversion Flow Diagram ``` ┌─────────────┐ │ Data() │ ← Chained entry (default member) └─────────────┘ │ ┌───────────────┼───────────────┐ │ │ │ Byte() array Base64 string StdPicture │ │ │ └───────────────┼───────────────┘ │ ┌───────────┼───────────┐ │ │ │ ReturnBytes ReturnBase64 ReturnPicture │ │ │ │ ReturnDataUri ShowTo(control) │ │ │ └───────────┼───────────┘ │ ┌─────────────┐ │ ReturnMimeType │ ← MIME type detection └─────────────┘ ``` ## Notes 1. **StdPicture → Byte Array**: Internally saves a temporary file via `SavePicture` then reads it, outputs in BMP format 2. **MIME Type Detection**: Only effective for byte array input; Base64 and StdPicture input requires manual specification 3. **Data URI Format**: `ReturnBase64` returns pure Base64, `ReturnDataUri` returns complete format with `data:` prefix 4. **GDI+ Initialization**: Class internally manages GDI+ lifecycle automatically, initializes on first use, releases on class destruction 5. **Thread Safety**: `VBMAN.Image` is a globally shared instance; for multiple independent conversion tasks, create `New cImage` ## Best Practices 1. **Prefer ShowTo for Display**: More concise than `Set Image1.Picture = ...ReturnPicture` 2. **Shorthand**: `VBMAN.Image.(base64Str)` is more intuitive than the full form 3. **API Scenario**: Receive Base64 image → `ShowTo` display; send image → `ReturnBase64` encode 4. **HTML Embedding**: Use `ReturnDataUri` to generate directly embeddable format 5. **Format Confirmation**: Use `ReturnMimeType` to get type when uploading images, send along with request 6. **Independent Instance**: Create `New cImage` for multi-thread or batch conversion scenarios --- --- url: /zh/vbman/Json/faq.md --- # cJson 常见问题解答（FAQ） ## 基础问题 ### Q1: cJson 类在哪里定义？ **A:** cJson 类定义在 `VBMAN` 库中，文件位于： ``` vbman/src/Tools/Json/cJson.cls ``` 在项目中使用需要引用 VBMAN 库： ```vb '标准引用方式 Dim Json As New VBMANLIB.cJson '或使用 VBMAN 全局实例 With VBMAN.Json '... End With ``` ### Q2: 为什么数组下标从 1 开始而不是 0？ **A:** cJson 内部使用 VB 的 `Collection` 对象存储数组，而 VB 的 Collection 下标从 1 开始。这是为了符合 VB 开发者的习惯。 ```vb '添加元素使用 0（表示新增） Json.Items(0) = "元素1" Json.Items(0) = "元素2" '访问使用 1-based 索引（通过 Root） MsgBox Json.Root("items")(1) '元素1 MsgBox Json.Root("items")(2) '元素2 ``` ### Q3: 如何清空 cJson 实例？ **A:** 使用 `Clear` 方法： ```vb Json.Clear '清空所有数据 ``` **注意：** 使用 `VBMAN.Json` 全局实例前建议先调用 `Clear`： ```vb With VBMAN.Json .Clear '清理之前的数据 .Item("key") = "value" End With ``` ## 使用问题 ### Q4: 如何判断 JSON 解析是否成功？ **A:** 使用 `LastSuccess` 属性： ```vb Json.Decode JsonText If Json.LastSuccess Then MsgBox "解析成功" Else MsgBox "解析失败: " & Json.LastError End If ``` ### Q5: 如何判断某个键是否存在？ **A:** 使用 `RootItem.Exists` 方法检查，使用 `Root` 访问： ```vb If Json.RootItem.Exists("key") Then MsgBox Json.Root("key") Else MsgBox "键不存在" End If ``` ### Q6: 如何遍历 JSON 数组？ **A:** 使用 `Root` 访问数组，有两种遍历方式： ```vb '方式一：For Each（推荐） Dim Item As Variant For Each Item In Json.Root("data") Debug.Print Item("name") Next '方式二：For 循环（下标从 1 开始） Dim i As Long For i = 1 To Json.Root("data").Count Debug.Print Json.Root("data")(i)("name") Next ``` ### Q7: 如何处理嵌套对象？ **A:** 使用 `Root` 进行链式访问或分层访问： ```vb '链式访问（推荐） MsgBox Json.Root("level1")("level2")("level3") '或使用默认成员特性（更简洁） MsgBox Json("level1")("level2")("level3") '分层访问（推荐用于深层嵌套） Dim Level1 As Object Dim Level2 As Object Set Level1 = Json.Root("level1") Set Level2 = Level1("level2") MsgBox Level2("level3") ``` ## 编码问题 ### Q8: 如何让 JSON 显示中文而不是 Unicode？ **A:** 在 `Encode` 方法中设置第三个参数为 `True`： ```vb Json.Encode(, 2, True) '第三个参数 True 表示中文原样显示 ``` ### Q9: 如何格式化输出 JSON 字符串？ **A:** 在 `Encode` 方法中设置第二个参数： ```vb Json.Encode(, 2) '使用 2 个空格缩进 Json.Encode(, 4) '使用 4 个空格缩进 Json.Encode(, vbTab) '使用 Tab 缩进 ``` ### Q10: 如何处理特殊字符？ **A:** cJson 会自动处理特殊字符的转义： ```vb Json.Item("text") = "包含"引号"和\反斜杠的文本" '输出："text": "包含""引号""和\\反斜杠的文本" ``` ## 文件操作问题 ### Q11: 如何从文件加载 JSON？ **A:** 使用 `LoadFrom` 方法： ```vb '标准方式 With New cJson .LoadFrom "C:\data.json" MsgBox .Item("name") End With '链式调用 MsgBox VBMAN.Json.LoadFrom("C:\data.json")("name") ``` ### Q12: 如何保存 JSON 到文件？ **A:** 使用 `SaveTo` 方法： ```vb Json.SaveTo "C:\data.json" '简单保存 Json.SaveTo "C:\data.json", "UTF-8" '指定编码 Json.SaveTo "C:\data.json", "UTF-8", 2, True '格式化并显示中文 ``` ### Q13: 支持哪些字符编码？ **A:** 支持常见的字符编码： * `UTF-8`（推荐） * `UTF-16` * `GB2312` * `GBK` * `ASCII` ## HTTP 相关问题 ### Q14: 如何发送 JSON 数据？ **A:** 构造 JSON 字符串后发送： ```vb '构造请求体 Dim Body As String With New cJson .Item("key") = "value" Body = .Encode() End With '发送 POST 请求 With New cHttpClient .SetRequestContentType JsonString .SendPost "https://api.example.com", Body End With ``` ### Q15: 如何解析 API 返回的 JSON？ **A:** 使用 `ReturnJson` 方法： ```vb With VBMAN.HttpClient.Fetch(ReqGet, "https://api.example.com").ReturnJson() '格式化显示 Text1.Text = .Encode(, 2, True) '提取数据 If .Item("code") = 200 Then MsgBox .Item("data")("name") End If End With ``` ### Q16: 如何处理 JSONP 格式？ **A:** cJson 的 `Decode` 方法会自动处理 JSONP 格式： ```vb '以下格式都可以自动解析 Json.Decode "callback({""name"":""张三""});" Json.Decode "var data = {""name"":""张三""};" Json.Decode "{""name"":""张三""}" '标准 JSON ``` ## 错误处理 ### Q17: 常见的错误有哪些？ **A:** 常见错误及解决方案： | 错误 | 原因 | 解决方案 | | ---------- | ---------------------- | ---------------------- | | 下标越界 | 访问了不存在的数组索引 | 检查数组长度再访问 | | 键不存在 | 访问了不存在的键 | 使用 `Exists` 方法检查 | | 类型不匹配 | 数据类型与变量不匹配 | 使用类型转换函数 | | 解析失败 | JSON 格式错误 | 检查输入字符串格式 | ### Q18: 如何调试 JSON 问题？ **A:** 使用以下调试技巧： ```vb '1. 格式化输出查看结构 Debug.Print Json.Encode(, 2, True) '2. 检查错误信息 Json.Decode BadJsonText If Not Json.LastSuccess Then Debug.Print "错误: " & Json.LastError End If '3. 检查数据类型 Debug.Print TypeName(Json.Item("field")) ``` ## 性能问题 ### Q19: 处理大数据量时有什么建议？ **A:** 1. 使用紧凑格式传输：`Json.Encode()`（不格式化） 2. 避免深层嵌套的对象查找 3. 及时释放不需要的对象 4. 考虑分批处理大量数据 ### Q20: 全局实例和新建实例有什么区别？ **A:** | 特性 | VBMAN.Json（全局） | New cJson（新建） | | -------- | ------------------ | ----------------- | | 生命周期 | 应用程序全程 | 随代码块结束释放 | | 数据共享 | 全局共享 | 独立隔离 | | 使用场景 | 缓存全局配置 | 临时数据处理 | | 注意事项 | 需要手动 Clear | 自动清理 | ## 进阶问题 ### Q21: 如何构造根节点为数组的 JSON？ **A:** 先调用 `NewItem` 或 `NewItems`： ```vb With New cJson '根是数组 With .NewItem() .Item("name") = "张三" End With With .NewItem() .Item("name") = "李四" End With '结果: [{"name": "张三"}, {"name": "李四"}] Debug.Print .Encode(, 2, True) End With ``` ### Q22: 如何合并两个 JSON 对象？ **A:** 手动复制键值对： ```vb Private Sub MergeJson(Target As cJson, Source As cJson) Dim Key As Variant For Each Key In Source.RootItem.Keys Target.Item(Key) = Source.Item(Key) Next End Sub ``` ### Q23: 如何复制 JSON 对象？ **A:** 编码后再解码： ```vb Dim Copy As New cJson Copy.Decode Original.Encode() ``` ### Q24: Root 和 Item 有什么区别？ **A:** | 特性 | Root | Item | | -------- | ------------------------------- | -------------------- | | 默认成员 | 是（可用 `Json("key")`） | 否 | | 返回类型 | Object（Dictionary/Collection） | Variant | | 链式访问 | 支持 | 有限支持 | | 主要用途 | **读取数据** | **设置值** | | 示例 | `Json.Root("a")("b")` | `Json.Item("a") = 1` | **推荐用法：** ```vb '设置值用 Item Json.Item("name") = "张三" '读取值用 Root MsgBox Json.Root("name") MsgBox Json.Root("address")("city") '链式访问嵌套对象 '简写形式（利用 Root 是默认成员） MsgBox Json("name") MsgBox Json("address")("city") ``` ### Q25: 如何处理日期类型？ **A:** 日期会转为字符串，建议格式化： ```vb Json.Item("created") = Format(Now(), "yyyy-mm-dd HH:mm:ss") ``` --- --- url: /zh/vbman/Json/README.md --- # cJson 开发者文档手册 ## 简介 `cJson` 是 VBMAN 框架提供的 JSON 处理类，基于 VBA-JSON v2.3.1 改进封装。它提供了简单易用的 API 来解析和生成 JSON 数据，支持嵌套对象、数组、文件操作等功能。 ## 文档导航 | 文档 | 说明 | 适合读者 | | ---------------------------------------- | ------------------- | ---------- | | [index.md](./index.md) | 概述和主要特性 | 所有开发者 | | [quickstart.md](./quickstart.md) | 5 分钟快速上手指南 | 新手开发者 | | [api-reference.md](./api-reference.md) | 完整的 API 参考手册 | 所有开发者 | | [examples.md](./examples.md) | 详细的代码示例集 | 所有开发者 | | [best-practices.md](./best-practices.md) | 最佳实践和注意事项 | 进阶开发者 | | [faq.md](./faq.md) | 常见问题解答 | 所有开发者 | ## 快速开始 ### 安装引用 确保项目中已添加对 `VBMAN` 库的引用。 ### 最简单的示例 ```vb '创建 JSON 对象 With New VBMANLIB.cJson .Item("name") = "张三" .Item("age") = 25 MsgBox .Encode(, 2, True) End With ``` 输出： ```json { "name": "张三", "age": 25 } ``` ### 解析 JSON 字符串（使用 Root 访问） ```vb Dim JsonText As String JsonText = "{""name"":""张三"",""age"":25}" With New VBMANLIB.cJson .Decode JsonText '使用 Root（默认成员）访问 - 推荐方式 MsgBox .Root("name") '输出：张三 '或简写为： MsgBox $("name") '输出：张三 End With ``` ## 核心特性 * **类型映射清晰**：Dictionary（字典）↔ JSON 对象 `{...}`，Collection（集合）↔ JSON 数组 `[...]` * **节点创建与成员设置分离**：`NewItem/NewItems` 创建子节点，`Item/Items` 在节点上增改成员 * **默认成员**：`Root` 是默认成员，可直接用 `Json("key")` 访问，支持链式嵌套 * **支持嵌套**：无限层级的 JSON 对象和数组嵌套 * **文件操作**：支持从文件加载和保存 JSON 数据 * **编码解码**：支持 JSON 字符串与 VB 对象的相互转换 * **格式化输出**：支持自定义缩进格式化 JSON 字符串 * **中文支持**：支持中文原样显示（不进行 Unicode 转码） * **数组下标**：集合数组下标从 **1** 开始（符合 VB 习惯） ## 重要提示 1. **类型对应**：Dictionary（字典）对应 JSON 对象 `{...}`，Collection（集合）对应 JSON 数组 `[...]` 2. **Root 是默认成员**：可直接用 `Json("key")` 访问，等同于 `Json.Root("key")`，用于链式读写 3. **NewItem/NewItems 创建节点**：`NewItem` 创建子对象节点，`NewItems` 创建子数组节点 4. **Item/Items 增改成员**：`Item` 在对象节点上设置键值对，`Items` 在数组节点上添加元素 5. **数组下标从 1 开始**：VB 的 Collection 对象下标从 1 开始，与 JavaScript 不同 6. **全局实例共享数据**：`VBMAN.Json` 是全局实例，数据会在多次使用间保留，必要时调用 `.Clear()` 清理 ## 作者信息 * **作者**: 邓伟 * **QQ**: 215879458 * **基于**: VBA-JSON v2.3.1 by Tim Hall (https://github.com/VBA-tools/VBA-JSON) ## 许可证 本文档遵循项目许可证。 *** *最后更新: 2026年3月7日* --- --- url: /zh/vbman/Json.md --- # cJson 开发者文档手册 ## 概述 `cJson` 是 VBMAN 框架提供的 JSON 处理类，基于 VBA-JSON v2.3.1 (Tim Hall) 改进封装。它提供了简单易用的 API 来解析和生成 JSON 数据，支持嵌套对象、数组、文件操作等功能。 ## 主要特性 * **类型映射清晰**：Dictionary（字典）↔ JSON 对象 `{...}`，Collection（集合）↔ JSON 数组 `[...]` * **节点创建与成员设置分离**：`NewItem/NewItems` 创建子节点，`Item/Items` 在节点上增改成员 * **默认成员**：`Root` 是默认成员，可直接用 `Json("key")` 访问，支持链式嵌套 * **支持嵌套**：无限层级的 JSON 对象和数组嵌套 * **文件操作**：支持从文件加载和保存 JSON 数据 * **编码解码**：支持 JSON 字符串与 VB 对象的相互转换 * **格式化输出**：支持自定义缩进格式化 JSON 字符串 * **中文支持**：支持中文原样显示（不进行 Unicode 转码） * **数组下标**：集合数组下标从 **1** 开始（符合 VB 习惯） ## 创建方式 ### 方式一：使用全局实例（推荐） ```vb '使用 VBMAN 内置的全局 Json 实例 With VBMAN.Json .Item("name") = "张三" MsgBox .Encode() End With ``` ### 方式二：创建新实例 ```vb '创建独立实例 Dim Json As New VBMANLIB.cJson Json.Item("name") = "张三" MsgBox Json.Encode() '或者使用 With New With New VBMANLIB.cJson .Item("name") = "张三" MsgBox .Encode() End With ``` ## 快速示例 ### 示例 1：创建简单 JSON 对象 ```vb With New cJson .Item("code") = 200 .Item("msg") = "操作成功" .Item("data") = "返回数据" MsgBox .Encode(, 2, True) End With '输出： '{ ' "code": 200, ' "msg": "操作成功", ' "data": "返回数据" '} ``` ### 示例 2：创建包含数组的 JSON ```vb With New cJson .Item("code") = 200 .Item("msg") = "操作成功" With .NewItems("data") '创建数组 With .NewItem() '数组第一个对象 .Item("name") = "张三" .Item("age") = 25 End With With .NewItem() '数组第二个对象 .Item("name") = "李四" .Item("age") = 30 End With End With MsgBox .Encode(, 2, True) End With ``` ### 示例 3：解析 JSON 字符串（使用 Root 访问） ```vb Dim JsonText As String JsonText = "{""name"":""张三"",""age"":25}" With New cJson .Decode JsonText '使用 Root（默认成员）访问 - 推荐方式 MsgBox .Root("name") '输出：张三 MsgBox .Root("age") '输出：25 '或者直接使用默认成员特性 MsgBox $("name") '输出：张三 End With ``` ### 示例 4：一句话把数据库记录 Ado.RS 转为 Json 字符串 ```vb 'cJson.Decode 直接支持 ADODB.Recordset，一句话即可转换 MsgBox VBMAN.Json.Decode(Rs).Encode(, 2, True) '或者使用独立实例 With New cJson .Decode VBMAN.Db.Rs MsgBox .Encode(, 2, True) End With ``` ## 文档导航 * [快速开始](./quickstart.md) - 5 分钟上手指南 * [API 参考](./api-reference.md) - 完整的属性和方法说明 * [示例代码](./examples.md) - 详细的代码示例 ## 注意事项 1. **类型对应**：Dictionary（字典）对应 JSON 对象 `{...}`，Collection（集合）对应 JSON 数组 `[...]` 2. **Root 是默认成员**：可直接用 `Json("key")` 访问，等同于 `Json.Root("key")`，用于链式读写 3. **NewItem/NewItems 创建节点**：`NewItem` 创建子对象节点，`NewItems` 创建子数组节点 4. **Item/Items 增改成员**：`Item` 在对象节点上设置键值对，`Items` 在数组节点上添加元素 5. **数组下标从 1 开始**：VB 的 Collection 对象下标从 1 开始，与 JavaScript 不同 6. **全局实例共享数据**：`VBMAN.Json` 是全局实例，数据会在多次使用间保留，必要时调用 `.Clear()` 清理 --- --- url: /zh/vbman/Json/quickstart.md --- # cJson 快速开始指南 ## 1. 引入库 确保项目中已添加对 `VBMAN` 库的引用： ```vb '在代码中使用以下方式引用 Dim Json As New VBMANLIB.cJson '或者直接使用 VBMAN 全局实例 With VBMAN.Json '... End With ``` ## 2. 创建 JSON 对象 ### 2.1 创建简单的键值对对象 ```vb Private Sub CreateSimpleJson() With New VBMANLIB.cJson '直接赋值创建键值对 .Item("servicesn") = "0001" .Item("userid") = "admin" .Item("token") = "" .Item("argcounts") = 2 '编码为 JSON 字符串 Dim JsonString As String JsonString = .Encode(, 2, True) Debug.Print JsonString End With End Sub ``` 输出结果： ```json { "servicesn": "0001", "userid": "admin", "token": "", "argcounts": 2 } ``` ### 2.2 创建嵌套对象 ```vb Private Sub CreateNestedJson() With New VBMANLIB.cJson .Item("name") = "张三" .Item("age") = 25 '创建嵌套对象（使用 NewItem） With .NewItem("address") .Item("city") = "北京" .Item("district") = "海淀区" End With Debug.Print .Encode(, 2, True) End With End Sub ``` 输出结果： ```json { "name": "张三", "age": 25, "address": { "city": "北京", "district": "海淀区" } } ``` ### 2.3 创建数组 ```vb Private Sub CreateArrayJson() With New VBMANLIB.cJson .Item("code") = 200 .Item("msg") = "成功" '创建数组（使用 NewItems） With .NewItems("data") '添加数组元素（使用 NewItem 创建对象元素） With .NewItem() .Item("id") = 1 .Item("name") = "项目1" End With With .NewItem() .Item("id") = 2 .Item("name") = "项目2" End With End With Debug.Print .Encode(, 2, True) End With End Sub ``` 输出结果： ```json { "code": 200, "msg": "成功", "data": [ { "id": 1, "name": "项目1" }, { "id": 2, "name": "项目2" } ] } ``` ## 3. 解析 JSON 字符串 ### 3.1 解析简单对象（使用 Root 访问） ```vb Private Sub ParseSimpleJson() Dim JsonText As String JsonText = "{""name"":""张三"",""age"":25,""city"":""北京""}" With New VBMANLIB.cJson .Decode JsonText '使用 Root 访问 - 推荐方式（返回 Object，支持链式访问） Debug.Print .Root("name") '输出：张三 Debug.Print .Root("age") '输出：25 Debug.Print .Root("city") '输出：北京 '或使用默认成员特性（更简洁） Debug.Print $("name") '输出：张三 End With End Sub ``` ### 3.2 解析嵌套对象和数组（使用 Root 链式访问） ```vb Private Sub ParseComplexJson() Dim JsonText As String JsonText = "{""code"":200,""data"":[{""id"":1,""name"":""项目1""},{""id"":2,""name"":""项目2""}]}" With New VBMANLIB.cJson .Decode JsonText '使用 Root 访问顶层字段 Debug.Print .Root("code") '输出：200 '使用 Root 链式访问数组元素（注意：下标从 1 开始） Debug.Print .Root("data")(1)("name") '输出：项目1 Debug.Print .Root("data")(2)("name") '输出：项目2 '循环遍历数组（使用 Root） Dim Item As Variant For Each Item In .Root("data") Debug.Print Item("id") & " - " & Item("name") Next End With End Sub ``` ## 4. 文件操作 ### 4.1 保存 JSON 到文件 ```vb Private Sub SaveJsonToFile() With VBMAN.Json .Item("name") = "测试数据" .Item("version") = "1.0" '保存到文件（参数：路径, 编码, 缩进, 中文原样显示） .SaveTo "C:\tmp\data.json", "UTF-8", 2, True MsgBox "文件已保存" End With End Sub ``` ### 4.2 从文件加载 JSON ```vb Private Sub LoadJsonFromFile() With New VBMANLIB.cJson '从文件加载 .LoadFrom "C:\tmp\data.json", "UTF-8" '使用数据（使用 Root 访问） MsgBox .Root("name") End With '或者直接使用（Root 是默认成员） MsgBox VBMAN.Json.LoadFrom("C:\tmp\data.json")("name") End Sub ``` ## 5. 与 HTTP 请求结合使用 ### 5.1 发送 JSON 数据（POST 请求） ```vb Private Sub PostJsonData() '构造请求体 Dim Body As String With New cJson .Item("sysStuffCode") = "TEST001" .Item("quantity") = 2 With .NewItems("detailList") Dim i As Long For i = 0 To 3 With .NewItem() .Item("test") = 123 .Item("time") = Now() End With Next End With Body = .Encode() End With '发送请求 With New cHttpClient .RequestHeaders.Add "Content-Type", "application/json" Dim Response As String Response = .Fetch(ReqPost, "https://api.example.com/submit", Body).ReturnText() Debug.Print Response End With End Sub ``` ### 5.2 解析返回的 JSON 数据 ```vb Private Sub ParseApiResponse() With VBMAN.HttpClient.Fetch(ReqGet, "https://api.example.com/data").ReturnJson() '格式化显示返回内容 Text1.Text = .Encode(, 2, True) '提取数据 If .Item("code") = 200 Then Dim Item As Variant For Each Item In .Item("data") List1.AddItem Item("name") Next Else MsgBox .Item("message") End If End With End Sub ``` ## 6. 常见错误处理 ```vb Private Sub SafeJsonOperation() On Error GoTo ErrorHandler Dim Json As New cJson '解析可能格式错误的 JSON Json.Decode Text1.Text '检查解析是否成功 If Json.LastSuccess Then MsgBox "解析成功: " & Json.Item("name") Else MsgBox "解析失败: " & Json.LastError End If Exit Sub ErrorHandler: MsgBox "操作出错: " & Err.Description End Sub ``` ## 下一步 * 查看 [API 参考](./api-reference.md) 了解完整的属性和方法 * 查看 [示例代码](./examples.md) 获取更多使用场景 --- --- url: /zh/vbman/Json/examples.md --- # cJson 示例代码集 本文档包含各种实际使用场景的详细示例代码。 ## 目录 1. [基础示例](#基础示例) 2. [HTTP API 交互](#http-api-交互) 3. [文件操作](#文件操作) 4. [复杂数据结构](#复杂数据结构) 5. [实际业务场景](#实际业务场景) *** ## 基础示例 ### 示例 1：创建用户信息对象 ```vb Private Sub CreateUserInfo() With New VBMANLIB.cJson .Item("username") = "admin" .Item("password") = "123456" .Item("age") = 40 .Item("name") = "邓伟" '格式化输出，显示中文 Debug.Print .Encode(, 2, True) End With End Sub ``` 输出： ```json { "username": "admin", "password": "123456", "age": 40, "name": "邓伟" } ``` ### 示例 2：创建带数组的简单 JSON ```vb Private Sub CreateWithArray() With New VBMANLIB.cJson .Item("code") = 200 .Item("msg") = "操作成功" '创建普通值数组 With .NewItems("hobbies") .Items(0) = "阅读" .Items(0) = "游泳" .Items(0) = "编程" End With Debug.Print .Encode(, 2, True) End With End Sub ``` 输出： ```json { "code": 200, "msg": "操作成功", "hobbies": ["阅读", "游泳", "编程"] } ``` ### 示例 3：解析并读取 JSON ```vb Private Sub ParseAndRead() Dim JsonText As String JsonText = "{""servicesn"":""0001"",""userid"":""admin"",""token"":"""",""argcounts"":2}" With New VBMANLIB.cJson .Decode JsonText '使用 Root 读取各个字段（推荐方式） Debug.Print "Service SN: " & .Root("servicesn") Debug.Print "User ID: " & .Root("userid") Debug.Print "Token: " & .Root("token") Debug.Print "Arg Counts: " & .Root("argcounts") End With End Sub ``` *** ## HTTP API 交互 ### 示例 4：构造 POST 请求体 **方式一：使用独立的 cJson 实例（推荐用于复杂结构）** ```vb Private Sub BuildPostBody() Dim Body As String '创建独立的 JSON 对象 With New cJson .Item("sysStuffCode") = "TEST001" .Item("quantity") = 2 '构造数组 With .NewItems("detailList") Dim i As Long For i = 0 To 3 With .NewItem() .Item("test") = 123 .Item("time") = Now() End With Next End With Body = .Encode() End With '发送请求 With New cHttpClient .RequestHeaders.Add "Content-Type", "application/json") .Fetch ReqPost, "https://api.example.com/submit", Body Debug.Print .ReturnText() End With End Sub ``` **方式二：使用 HttpClient 内置的 RequestDataJson 对象（简洁写法）** ```vb Private Sub BuildPostBodySimple() With VBMAN.HttpClient '使用内置 RequestDataJson 对象构造请求体 With .RequestDataJson .Clear '清空之前的数据 .Item("sysStuffCode") = "TEST001" .Item("quantity") = 2 With .NewItems("detailList") Dim i As Long For i = 0 To 3 With .NewItem() .Item("test") = 123 .Item("time") = Now() End With Next End With End With '设置请求类型并发送（ContentType=Json 时会自动使用 RequestDataJson） .SetRequestContentType JsonString .SendPost "https://api.example.com/submit" 'Body 参数可省略，自动使用 RequestDataJson Debug.Print .ReturnText() End With End Sub ``` ### 示例 5：处理 API 响应 ```vb Private Sub HandleApiResponse() Const API_BASE As String = "https://api.example.com" Const API_PULL_WAYBILL As String = API_BASE & "/api/pullWaybill" '构造请求数据 Dim Body As String With New cJson .Item("wayBillId") = "46349936" .Item("clientId") = "CLIENT001" .Item("token") = "cbe84888-9f48-4c00-aae6-3170bf5951cd" Body = .Encode() End With '发送请求并处理响应 On Error GoTo ErrorHandler With VBMAN.HttpClient .SetRequestContentType JsonString .SendPost API_PULL_WAYBILL, Body With .ReturnJson() '显示完整返回 Text2.Text = .Encode(, 2, True) '判断业务状态 If .Root("success") = True Then MsgBox "货物名称: " & .Root("data")("cargoName"), , "运单号: " & .Root("data")("wayBillId") Else MsgBox .Root("message"), , "请求失败" End If End With End With Exit Sub ErrorHandler: Debug.Print VBMAN.HttpClient.DebugInfo.Encode(, 2, True) End Sub ``` ### 示例 6：使用查询参数获取数据 ```vb Private Sub FetchWithQuery() Const API_BASE As String = "https://api.example.com" Const API_SALE_PLAN As String = API_BASE & "/api/salePlan/selectByVehicleNo" On Error Resume Next '使用内置查询构造器（自动 URL 编码） VBMAN.HttpClient.RequestDataQuery.Add "vehicleNo", "鲁B70AP0" With VBMAN.HttpClient.Fetch(ReqGet, API_SALE_PLAN).ReturnJson() '显示格式化结果 Text1.Text = .Encode(, 2, True) '判断返回状态（使用 Root 访问） If .Root("code") = 200 Then '循环遍历数组 Dim x As Variant For Each x In .Root("data") List1.AddItem x("planCode") List1.AddItem x("warehouseName") Next '直接取指定数组对象（使用 Root 链式访问） With .Root("data")(1) List1.AddItem .Root("planCode") List1.AddItem .Root("warehouseName") End With Else MsgBox .Root("message") End If End With End Sub ``` *** ## 文件操作 ### 示例 7：保存配置到 JSON 文件 ```vb Private Sub SaveConfig() With VBMAN.Json '清空之前的数据 .Clear .Item("appName") = "MyApplication" .Item("version") = "1.0.0" .Item("debug") = True '嵌套配置对象 With .NewItem("database") .Item("host") = "localhost" .Item("port") = 3306 .Item("username") = "root" .Item("password") = "secret" End With '保存到文件 .SaveTo App.Path & "\config.json", "UTF-8", 2, True MsgBox "配置已保存" End With End Sub ``` ### 示例 8：从 JSON 文件加载配置 ```vb Private Sub LoadConfig() Dim ConfigPath As String ConfigPath = App.Path & "\config.json" '检查文件是否存在 If Dir(ConfigPath) = "" Then MsgBox "配置文件不存在" Exit Sub End If With New VBMANLIB.cJson .LoadFrom ConfigPath '读取配置 Dim AppName As String Dim DbHost As String Dim DbPort As Long AppName = .Root("appName") DbHost = .Root("database")("host") DbPort = .Root("database")("port") MsgBox "应用: " & AppName & vbCrLf & _ "数据库: " & DbHost & ":" & DbPort End With End Sub ``` ### 示例 9：从文件加载并修改 ```vb Private Sub ModifyJsonFile() Dim FilePath As String FilePath = "C:\tmp\data.json" With New VBMANLIB.cJson .LoadFrom FilePath '修改数据 .Item("name") = "新名称" .Item("updated") = Now() '保存回文件 .SaveTo FilePath, "UTF-8", 2, True End With End Sub ``` *** ## 复杂数据结构 ### 示例 10：无限层级嵌套 ```vb Private Sub NestedStructure() With New VBMANLIB.cJson .Item("a") = 1 .Item("b") = "dengwei" With .NewItems("c") Dim i As Long For i = 0 To 3 With .NewItem() .Item("d") = Now() .Item("e") = 34 + i .Item("f") = "数据: " & i '创建更深的嵌套 With .NewItem("g") .Item("g1") = 123 .Item("g2") = 456 End With With .NewItems("h") .Items(0) = "数组元素1" .Items(0) = "数组元素2" End With End With Next End With '保存并显示 .SaveTo "C:\tmp\nested.json", , 2, True Text1.Text = .Encode(, 2, True) End With End Sub ``` ### 示例 11：混合数组（对象和普通值） ```vb Private Sub MixedArray() With New VBMANLIB.cJson '对象数组 With .NewItems("users") With .NewItem() .Item("name") = "张三" .Item("age") = 25 End With With .NewItem() .Item("name") = "李四" .Item("age") = 30 End With End With '普通值数组 With .NewItems("tags") .Items(0) = "VIP" .Items(0) = "活跃" .Items(0) = "付费" End With Debug.Print .Encode(, 2, True) End With End Sub ``` 输出： ```json { "users": [ { "name": "张三", "age": 25 }, { "name": "李四", "age": 30 } ], "tags": ["VIP", "活跃", "付费"] } ``` ### 示例 12：解析复杂嵌套 JSON ```vb Private Sub ParseComplexNested() '假设这是从 API 获取的复杂 JSON Dim JsonText As String JsonText = "{" JsonText = JsonText & """code"":200," JsonText = JsonText & """data"":{" JsonText = JsonText & " ""company"":""ABC公司""," JsonText = JsonText & " ""departments"":[{" JsonText = JsonText & " ""name"":""技术部""," JsonText = JsonText & " ""employees"":[{""name"":""张三"",""position"":""工程师""}]" JsonText = JsonText & " }]" JsonText = JsonText & "}" JsonText = JsonText & "}" With New VBMANLIB.cJson .Decode JsonText '使用 Root 进行深层链式访问 Dim Company As String Dim DeptName As String Dim EmpName As String Company = .Root("data")("company") DeptName = .Root("data")("departments")(1)("name") EmpName = .Root("data")("departments")(1)("employees")(1)("name") MsgBox "公司: " & Company & vbCrLf & _ "部门: " & DeptName & vbCrLf & _ "员工: " & EmpName End With End Sub ``` *** ## 实际业务场景 ### 示例 13：用户登录接口（HTTP 服务端） ```vb '在业务类中（如 bHello.cls） Public Sub Login(ctx As cHttpServerContext) Dim username As String: username = ctx.Request.Form("username") Dim password As String: password = ctx.Request.Form("password") With New cJson .Item("name") = "邓伟" .Item("age") = 40 .Item("username") = username .Item("password") = password '返回格式化 JSON ctx.Response.Text .Encode(, 2, True) End With End Sub ``` ### 示例 14：SSE 数据推送 ```vb '在定时发送类中（如 bSendData.cls） Private Sub SendTotalData() With New VBMANLIB.cJson '服务器时间 With .NewItem() .Item("id") = "serverTime" .Item("value") = Format(Now(), "yyyy年MM月dd日 HH:mm:ss") End With '统计数据 With .NewItem() .Item("id") = "today_count" .Item("value") = GetTodayCount() End With With .NewItem() .Item("id") = "yesterday_count" .Item("value") = GetYesterdayCount() End With '发送给前端 Form1.HttpServer.SSE.SendPack "total", .Encode() End With End Sub ``` ### 示例 15：数据库记录转 JSON **方法1：使用 RsToCollection 函数（推荐）** vbman 提供了全局函数 `VBMAN.ToolsList.RsToCollection`，可直接将 Recordset 转为集合，配合 cJson 使用更简便： ```vb Private Sub RecordsToJsonEasy() Dim Rs As ADODB.Recordset Set Rs = GetRecords() '获取数据库记录集 With New VBMANLIB.cJson .Item("code") = 200 .Item("total") = Rs.RecordCount '直接赋值转换后的集合 .Item("data") = VBMAN.ToolsList.RsToCollection(Rs) ctx.Response.Text .Encode(, 2, True) End With End Sub ``` **方法2：手动遍历构建（了解原理）** ```vb Private Sub RecordsToJson() Dim Rs As ADODB.Recordset Set Rs = GetRecords() '获取数据库记录集 With New VBMANLIB.cJson .Item("code") = 200 .Item("total") = Rs.RecordCount With .NewItems("data") Do While Not Rs.EOF With .NewItem() .Item("id") = Rs("id") .Item("name") = Rs("name") .Item("created") = Rs("created_at") End With Rs.MoveNext Loop End With '输出或保存 ctx.Response.Text .Encode(, 2, True) End With End Sub ``` > **提示**：`RsToCollection` 函数可通过 `VBMAN.ToolsList.RsToCollection` 全局调用，会自动处理分页和字段映射，是处理数据库记录转 JSON 的最佳实践。 ### 示例 16：批量任务数据结构 ```vb Private Function MakeTaskData() As String With New cJson '根是数组，需要先 NewItem With .NewItem() .Item("uuid") = GenerateUUID() .Item("task_no") = "TASK001" .Item("task_type") = 1 .Item("factory_code") = "0206" .Item("warehouse_code") = "0601" '明细数组 With .NewItems("detail") With .NewItem() .Item("row_no") = 1 .Item("part_no") = "PART001" .Item("qty") = 45.5 End With With .NewItem() .Item("row_no") = 2 .Item("part_no") = "PART002" .Item("qty") = 30.0 End With End With End With MakeTaskData = .Encode(.Root, 2) End With End Function ``` ### 示例 17：动态构建报表数据 ```vb Private Sub BuildReportData() With New VBMANLIB.cJson .Item("ReportTime") = Format(Date, "yyyy-mm-dd") .Item("SampleModel") = "样品型号123" .Item("ProductModel") = "产品型号ABC" Dim i As Long For i = 1 To 10 With .NewItem("record" & i) .Item("TestNum") = "TEST" & i .Item("T1") = RandValue() .Item("T2") = RandValue() .Item("Result") = IIf(i Mod 2 = 0, "PASS", "FAIL") End With Next '保存报表 .SaveTo App.Path & "\Reports"" & Format(Now(), "yyyymmdd") & ".json", , 2, True End With End Sub ``` ### 示例 18：使用全局实例缓存数据 ```vb Private Sub UseGlobalInstance() '使用全局 VBMAN.Json 实例缓存配置 With VBMAN.Json .Clear '先清理 .Item("api_url") = "https://api.example.com" .Item("timeout") = 30 .Item("retry") = 3 '在其他地方可以直接使用（Root 是默认成员） 'MsgBox VBMAN.Json.Root("api_url") '或简写为： 'MsgBox VBMAN.Json("api_url") End With End Sub ``` *** ## 调试技巧 ### 示例 19：格式化输出调试 ```vb Private Sub DebugJson() With New VBMANLIB.cJson '构建复杂数据... .Item("data") = "一些数据" '输出到立即窗口（格式化） Debug.Print .Encode(, 2, True) '输出到文本框 Text1.Text = .Encode(, 2, True) '紧凑格式（用于传输） Debug.Print .Encode() End With End Sub ``` ### 示例 20：错误处理模式 ```vb Private Sub SafeParse() On Error GoTo ErrorHandler Dim Json As New cJson Json.Decode Text1.Text If Not Json.LastSuccess Then MsgBox "JSON 解析失败: " & Json.LastError Exit Sub End If '安全访问数据 If Json.RootItem.Exists("name") Then MsgBox "Name: " & Json.Item("name") Else MsgBox "name 字段不存在" End If Exit Sub ErrorHandler: MsgBox "发生错误: " & Err.Number & " - " & Err.Description End Sub ``` --- --- url: /zh/vbman/Json/best-practices.md --- # cJson 最佳实践与注意事项 ## 使用建议 ### 1. 实例选择 | 场景 | 推荐方式 | 说明 | | ------------ | ----------------------- | ------------------ | | 临时使用 | `With New cJson` | 用完即弃，自动清理 | | 需要保存状态 | `Dim Json As New cJson` | 可在多个方法间传递 | | 全局配置 | `VBMAN.Json` | 全局共享，注意清理 | **推荐代码：** ```vb '临时使用推荐这种方式 With New VBMANLIB.cJson .Item("key") = "value" MsgBox .Encode() End With '对象自动释放，无需手动清理 ``` ### 2. 数组操作注意事项 **重要：数组下标从 1 开始！** ```vb With Json.NewItems("items") '添加元素使用 0 .Items(0) = "第一项" .Items(0) = "第二项" End With '访问时使用 1-based 索引 MsgBox Json.Item("items")(1) '第一项 MsgBox Json.Item("items")(2) '第二项 ``` ### 3. 及时清理全局实例 使用 `VBMAN.Json` 全局实例时，注意在开始前清理： ```vb With VBMAN.Json .Clear '重要！清理之前的数据 .Item("key") = "value" '... End With ``` ### 4. 命名规范建议 ```vb 'JSON 键名建议使用驼峰或下划线命名 Json.Item("userName") '驼峰式 Json.Item("user_name") '下划线式 '避免使用中文键名（虽然支持） Json.Item("用户名") '不推荐，可能引起兼容问题 ``` ## 性能优化 ### 1. 大批量数据处理 ```vb '推荐：预先估算数组大小（如果有） Private Sub BatchProcess() With New cJson With .NewItems("records") Dim Rs As ADODB.Recordset Set Rs = GetData() '使用 With 语句减少对象查找 Do While Not Rs.EOF With .NewItem() .Item("id") = Rs("id") .Item("name") = Rs("name") End With Rs.MoveNext Loop End With '一次性输出，避免多次 Encode Dim Result As String Result = .Encode(, 0) '紧凑格式节省空间 End With End Sub ``` ### 2. 链式访问 vs 分层处理 **推荐链式访问**（简洁清晰）： ```vb '直接链式访问嵌套数据 MsgBox Json.Root("user")("profile")("name") MsgBox Json.Root("data")(1)("title") ``` **需要重复使用子节点时，才分层处理**： ```vb '当需要多次使用同一子节点时，分层更高效 Dim User As Object Set User = Json.Root("user") MsgBox User("name") MsgBox User("email") MsgBox User("profile")("age") ``` ## 常见陷阱 ### 陷阱 1：忘记检查键是否存在 ```vb '错误：直接访问可能不存在的键 MsgBox Json.Item("mayNotExist") '可能出错 '正确：先检查是否存在 If Json.RootItem.Exists("mayNotExist") Then MsgBox Json.Item("mayNotExist") Else MsgBox "键不存在" End If ``` ### 陷阱 2：混淆 Root、Item 和 Items ```vb 'Root - 用于读取数据（默认成员，返回 Object 支持链式访问） MsgBox Json.Root("key") MsgBox Json.Root("level1")("level2") '链式访问嵌套对象 'Item - 用于设置键值对（有 Let/Set） Json.Item("key") = "value" 'Items - 用于数组（集合），Index=0 表示添加 Json.Items(0) = "value" '添加元素 MsgBox Json.Root("arr")(1) '访问元素（下标从1开始） '错误示范： Json.Item(1) = "value" '错误！Item 需要字符串键 Json.Items("key") '错误！Items 需要数字索引 ``` ### 陷阱 3：集合索引越界 ```vb '错误：假设集合有元素（cJson 使用 VB Collection 存储数组） MsgBox Json.Root("items")(1) '如果集合为空会出错 '正确：先检查 Count If Json.Root("items").Count > 0 Then MsgBox Json.Root("items")(1) End If ``` ## 错误处理最佳实践 ```vb Private Sub ProcessJson() On Error GoTo ErrorHandler Dim Json As New cJson '解析 JSON Json.Decode JsonText If Not Json.LastSuccess Then LogError "JSON 解析失败: " & Json.LastError Exit Sub End If '检查必需字段 If Not ValidateRequiredFields(Json) Then LogError "缺少必需字段" Exit Sub End If '处理数据 ProcessData Json Exit Sub ErrorHandler: LogError "处理出错: " & Err.Description End Sub Private Function ValidateRequiredFields(Json As cJson) As Boolean ValidateRequiredFields = True If Not Json.RootItem.Exists("code") Then ValidateRequiredFields = False Exit Function End If If Not Json.RootItem.Exists("data") Then ValidateRequiredFields = False Exit Function End If End Function ``` ## HTTP 请求集成建议 ### GET 请求处理 ```vb Private Sub HandleGetRequest() On Error Resume Next With VBMAN.HttpClient.Fetch(ReqGet, "https://api.example.com/data").ReturnJson() If .Item("code") <> 200 Then MsgBox "请求失败: " & .Item("message") Exit Sub End If '处理成功响应 ProcessSuccessResponse .Item("data") End With If Err.Number <> 0 Then MsgBox "网络错误: " & Err.Description End If End Sub ``` ### POST 请求处理 ```vb Private Sub HandlePostRequest() On Error GoTo ErrorHandler '构造请求体 Dim Body As String With New cJson .Item("action") = "submit" .Item("timestamp") = Now() Body = .Encode() End With '发送请求 With New cHttpClient .SetRequestContentType JsonString .SendPost "https://api.example.com/submit", Body '解析响应 With .ReturnJson() Select Case .Item("code") Case 200 MsgBox "提交成功" Case 400 MsgBox "参数错误: " & .Item("message") Case 500 MsgBox "服务器错误" Case Else MsgBox "未知错误: " & .Item("message") End Select End With End With Exit Sub ErrorHandler: Debug.Print "错误: " & Err.Description End Sub ``` ## 文件操作建议 ### 安全的文件读写 ```vb Private Sub SafeFileOperation() Dim FilePath As String FilePath = App.Path & "\data\config.json" '检查文件是否存在（SaveTo 会自动创建目录） If Dir(FilePath) <> "" Then '备份旧文件 FileCopy FilePath, FilePath & ".bak" End If '写入新内容（SaveTo 内部会自动创建目录） With New cJson .Item("version") = "1.0" .SaveTo FilePath, "UTF-8", 2, True End With End Sub ``` **注意：** `SaveTo` 方法内部会自动调用 `ToolsFso.AutoMakeDir` 创建目录，无需手动创建。 ## 调试技巧 ### 使用格式化输出 ```vb '开发阶段使用格式化输出 Debug.Print Json.Encode(, 2, True) '生产环境使用紧凑格式 ResponseText = Json.Encode() ``` ### 记录调试信息 ```vb Private Sub LogJson(Json As cJson, Context As String) Debug.Print "=== " & Context & " ===" Debug.Print Json.Encode(, 2, True) Debug.Print "========================" End Sub ``` --- --- url: /zh/vbman/Json/api-reference.md --- # cJson API 参考手册 ## 核心概念 ### VB 类型与 JSON 对应关系 | VB 类型 | JSON 类型 | 说明 | | ---------------------- | ------------------------- | ---------- | | **Dictionary（字典）** | `{ "key": "value" }` 对象 | 键值对结构 | | **Collection（集合）** | `[ 1, 2, 3 ]` 数组 | 有序列表 | ### 核心成员分工 | 成员 | 主要用途 | 说明 | | ------------ | --------------------- | -------------------------------------------------- | | **NewItem** | **创建子对象节点** | 创建 Dictionary 类型子节点，对应 JSON 对象 `{...}` | | **NewItems** | **创建子数组节点** | 创建 Collection 类型子节点，对应 JSON 数组 `[...]` | | **Item** | **设置/读取对象成员** | 在当前节点（Dictionary）上设置/获取键值对 | | **Items** | **设置/读取数组成员** | 在当前节点（Collection）上设置/获取数组元素 | | **Root** | **链式读取** | 返回根节点 Object，支持链式访问 | ### 构建 JSON 的正确流程 ```vb '1. 创建根节点（本身就是对象节点） With New cJson '在根节点上用 Item 设置键值对 .Item("name") = "张三" .Item("age") = 25 '2. 创建子数组节点（用 NewItems） With .NewItems("hobbies") '创建名为 "hobbies" 的子数组 '在子数组上用 Items 添加元素 .Items(0) = "阅读" 'Index=0 表示添加 .Items(0) = "编程" End With '3. 创建子对象节点（用 NewItem） With .NewItem("address") '创建名为 "address" 的子对象 '在子对象上用 Item 设置键值对 .Item("city") = "北京" .Item("zip") = "100000" End With '4. 编码为 JSON 字符串 Dim JsonString As String JsonString = .Encode() '输出：{"name":"张三","age":25,"hobbies":["阅读","编程"],"address":{"city":"北京","zip":"100000"}} End With ``` *** ## 属性列表 ### 公共属性 | 属性名 | 类型 | 说明 | | --------------- | ---------- | -------------------------------------------------------------------------- | | `Root` | Object | **默认成员**，返回根节点对象（Dictionary/字典 或 Collection/集合），最常用 | | `Self` | cJson | 返回对象自身实例（Me），用于需要传递本对象的场景 | | `RootText` | String | 最后一次编码/解码的 JSON 文本 | | `RootItem` | Dictionary | 根节点字典对象，对应 JSON 对象 `{ ... }` | | `RootItems` | Collection | 根节点集合对象，对应 JSON 数组 `[ ... ]` | | `LastError` | String | 最后一次错误信息 | | `WhiteSpaceSet` | Variant | 全局缩进设置 | **类型对应关系：** * **Dictionary（字典）** → JSON 对象 `{ "key": "value" }`（有键值对） * **Collection（集合）** → JSON 数组 `[ 1, 2, 3 ]`（有序列表） ### 状态属性 #### LastSuccess ```vb Public Property Get LastSuccess() As Boolean ``` 返回最后一次操作是否成功（`LastError = ""` 时返回 True）。 **示例：** ```vb Json.Decode JsonText If Json.LastSuccess Then MsgBox "解析成功" Else MsgBox "解析失败: " & Json.LastError End If ``` #### Root（默认成员，用于链式读写） ```vb Public Property Get Root() As Object Attribute Root.VB_UserMemId = 0 ``` 返回根节点对象。如果 `RootItems.Count > 0` 返回 **Collection（集合/数组）**，否则返回 **Dictionary（字典/对象）**。 **重要特性：** * **默认成员**：`Root` 是类的默认成员，可直接用 `Json("key")` 访问，等同于 `Json.Root("key")` * **返回 Object**：返回 Dictionary（对应 JSON 对象 `{...}`）或 Collection（对应 JSON 数组 `[...]`），支持链式嵌套访问 * **用于链式读写**：读取嵌套 JSON 数据时推荐使用 `Root`，支持无限层级链式访问 * **类型对应**： * Dictionary → JSON 对象 `{ "key": "value" }` * Collection → JSON 数组 `[ 1, 2, 3 ]` **示例：** ```vb '直接访问（利用默认成员特性） MsgBox Json("name") '等同于 Json.Root("name") MsgBox Json("user")("name") '链式访问嵌套对象 MsgBox Json("items")(1)("title") '访问数组内对象（数组下标从1开始） '明确使用 Root 属性 MsgBox Json.Root("name") MsgBox Json.Root("user")("name") '遍历数组 Dim Item As Variant For Each Item In Json("data") Debug.Print Item("name") Next ``` #### RootIsEmpty ```vb Public Property Get RootIsEmpty() As Boolean ``` 检查根节点是否为空（没有键值对也没有数组元素）。 **示例：** ```vb If Json.RootIsEmpty Then MsgBox "JSON 对象为空" End If ``` #### RootIsArray ```vb Public Property Get RootIsArray() As Boolean ``` 检查根节点是否为数组类型。 **示例：** ```vb If Json.RootIsArray Then MsgBox "根节点是数组" End If ``` ### 数据访问属性 #### Item（在当前对象节点上增改成员） ```vb Public Property Get Item(ByVal Key As String) As Variant Public Property Let Item(ByVal Key As String, Dat As Variant) Public Property Set Item(ByVal Key As String, Dat As Variant) ``` 在当前对象节点（Dictionary）上访问或设置键值对。 **核心作用：** * **增改对象成员**：在**当前对象节点**上设置键值对，用于构建 JSON 对象的属性 * **适用节点**：只能在 Dictionary 类型节点上使用（包括根节点和 NewItem 创建的子对象） * **对应 JSON**：操作的是 Dictionary，对应 JSON 对象 `{ "key": "value" }` **参数：** * `Key` - 键名（字符串） * `Dat` - 要设置的值（任意类型） **使用场景：** 1. 在**根节点**上设置键值对（根节点默认是对象） 2. 在 **NewItem 创建的子对象** 上设置键值对 **示例：** ```vb '===== 场景1：在根节点上设置键值对 ===== With New cJson '根节点本身就是对象，直接用 Item .Item("name") = "张三" .Item("age") = 25 .Item("active") = True '结果：{ "name": "张三", "age": 25, "active": true } End With '===== 场景2：在 NewItem 创建的子对象上设置 ===== With New cJson '创建子对象 "address" With .NewItem("address") '在子对象上用 Item 设置键值对 .Item("city") = "北京" .Item("zip") = "100000" End With '结果：{ "address": { "city": "北京", "zip": "100000" } } End With '===== 读取值（推荐用 Root 链式访问）===== '不推荐：Item 返回 Variant，不支持链式访问 Name = Json.Item("name") '推荐：Root 返回 Object，支持链式访问 Name = Json.Root("name") City = Json.Root("address")("city") '链式访问嵌套对象 '设置对象引用 Dim SubJson As New cJson Set Json.Item("sub") = SubJson.Root ``` #### Items（在当前数组节点上增改成员） ```vb Public Property Get Items(ByVal Index As Long) As Variant Public Property Let Items(ByVal Index As Long, Dat As Variant) Public Property Set Items(ByVal Index As Long, Dat As Variant) ``` 在当前数组节点（Collection）上访问或设置数组元素。**注意：索引从 1 开始**。 **核心作用：** * **增改数组成员**：在**当前数组节点**上添加或修改数组元素 * **适用节点**：只能在 Collection 类型节点上使用（NewItems 创建的子数组） * **对应 JSON**：操作的是 Collection，对应 JSON 数组 `[ 1, 2, 3 ]` **参数：** * `Index` - 数组索引（从 1 开始） * `Dat` - 要设置的值 **特殊用法：** * 当 `Index = 0` 时，表示**添加**新元素到数组末尾 **使用场景：** 1. 在 **NewItems 创建的子数组** 上添加元素 **示例：** ```vb '===== 场景：在 NewItems 创建的子数组上添加元素 ===== With New cJson With .NewItems("tags") '创建名为 "tags" 的子数组 '在子数组上用 Items 添加元素 .Items(0) = "VIP" 'Index=0 表示添加 .Items(0) = "活跃" .Items(0) = "付费" End With '结果：{ "tags": ["VIP", "活跃", "付费"] } '数组中的对象元素 With .NewItems("users") With .NewItem() '数组第一个对象元素 .Item("name") = "张三" .Item("age") = 25 End With With .NewItem() '数组第二个对象元素 .Item("name") = "李四" .Item("age") = 30 End With End With '结果：{ "users": [{"name":"张三","age":25}, {"name":"李四","age":30}] } End With '===== 访问数组元素（用 Root，从 1 开始）===== Dim First As String First = Json.Root("tags")(1) 'VIP '修改数组元素 Json.Root("tags").Items(1) = "新值" '遍历数组（推荐用 Root） Dim Item As Variant For Each Item In Json.Root("tags") Debug.Print Item Next '修改数组元素 Json.Items(1) = "新值" ``` ## 方法列表 ### Clear ```vb Public Sub Clear() ``` 清空所有数据，重置对象状态。 **示例：** ```vb Json.Item("name") = "张三" Json.Clear '现在 Json.RootIsEmpty = True ``` ### NewItem（创建子对象节点） ```vb Public Function NewItem(Optional ParentKey As String) As cJson ``` 创建一个新的 **Dictionary 类型子节点**，对应 JSON 对象 `{ ... }`。 **核心作用：** * **创建子对象**：在当前节点下创建一个子对象（Dictionary）节点 * **对应 JSON**：创建的是 JSON 对象 `{ "key": "value" }` * **后续操作**：创建后使用 `Item` 在该子对象上设置键值对 **参数：** * `ParentKey` - 父节点中的键名（可选） * 提供键名：子对象挂载到父节点的该键下 * 省略键名：子对象添加到父节点的数组中（父节点必须是数组类型） **返回：** * 新创建的 cJson 实例（Dictionary 类型） **使用流程：** 1. 调用 `NewItem([Key])` 创建子对象 2. 在返回的 cJson 实例上用 `Item` 设置键值对 **示例：** ```vb '===== 场景1：创建具名子对象（带 ParentKey）===== With New cJson '创建名为 "address" 的子对象 With .NewItem("address") '在子对象上用 Item 设置键值对 .Item("city") = "北京" .Item("zip") = "100000" End With '结果：{ "address": { "city": "北京", "zip": "100000" } } End With '===== 场景2：创建数组中的对象元素（省略 ParentKey）===== With New cJson With .NewItems("users") '先创建数组 "users" With .NewItem() '创建数组第一个对象元素 .Item("name") = "张三" .Item("age") = 25 End With With .NewItem() '创建数组第二个对象元素 .Item("name") = "李四" .Item("age") = 30 End With End With '结果：{ "users": [{"name":"张三","age":25}, {"name":"李四","age":30}] } End With '===== 场景3：无限层级嵌套 ===== With New cJson With .NewItem("level1") With .NewItem("level2") With .NewItem("level3") .Item("value") = "深层数据" End With End With End With '结果：{ "level1": { "level2": { "level3": { "value": "深层数据" } } } } End With ``` ### NewItems（创建子数组节点） ```vb Public Function NewItems(Optional ParentKey As String) As cJson ``` 创建一个新的 **Collection 类型子节点**，对应 JSON 数组 `[ ... ]`。 **核心作用：** * **创建子数组**：在当前节点下创建一个子数组（Collection）节点 * **对应 JSON**：创建的是 JSON 数组 `[ 1, 2, 3 ]` * **后续操作**：创建后使用 `Items` 在该子数组上添加元素，或使用 `NewItem` 添加对象元素 **参数：** * `ParentKey` - 父节点中的键名（可选） * 提供键名：子数组挂载到父节点的该键下 * 省略键名：子数组添加到父节点的数组中（父节点必须是数组类型） **返回：** * 新创建的 cJson 实例（Collection 类型） **使用流程：** 1. 调用 `NewItems([Key])` 创建子数组 2. 在返回的 cJson 实例上： * 用 `Items(0)` 添加普通值元素 * 用 `NewItem()` 添加对象元素 **示例：** ```vb '===== 场景1：创建具名子数组（带 ParentKey）===== With New cJson '创建名为 "tags" 的子数组 With .NewItems("tags") '在子数组上用 Items 添加元素 .Items(0) = "VIP" 'Index=0 表示添加 .Items(0) = "活跃" .Items(0) = "付费" End With '结果：{ "tags": ["VIP", "活跃", "付费"] } End With '===== 场景2：创建数组中的数组（省略 ParentKey）===== With New cJson With .NewItems("matrix") '创建二维数组 With .NewItems() '第一行数组 .Items(0) = 1 .Items(0) = 2 End With With .NewItems() '第二行数组 .Items(0) = 3 .Items(0) = 4 End With End With '结果：{ "matrix": [[1, 2], [3, 4]] } End With '===== 场景3：对象数组（混合使用 NewItem 和 Items）===== With New cJson With .NewItems("users") '数组元素是对象：用 NewItem 创建，用 Item 设置 With .NewItem() .Item("name") = "张三" .Item("age") = 25 End With '再添加一个对象 With .NewItem() .Item("name") = "李四" .Item("age") = 30 End With End With '结果：{ "users": [{"name":"张三","age":25}, {"name":"李四","age":30}] } End With ``` ### Encode ```vb Public Function Encode( _ Optional Obj As Variant, _ Optional Whitespace As Variant, _ Optional FromUnicode As Boolean _ ) As String ``` 将对象编码为 JSON 字符串。 **参数：** * `Obj` - 要编码的对象（可选，省略时使用内部 RootItem/RootItems） * `Whitespace` - 格式化缩进（数字表示空格数，字符串表示缩进字符） * `FromUnicode` - 是否将 Unicode 编码解码为中文（True 显示中文） **返回：** * JSON 字符串 **示例：** ```vb '简单编码 Dim JsonStr As String JsonStr = Json.Encode() '格式化输出（2个空格缩进） JsonStr = Json.Encode(, 2) '格式化并显示中文 JsonStr = Json.Encode(, 2, True) '编码指定对象 JsonStr = Json.Encode(Json.Item("subObject"), 2, True) ``` ### Decode ```vb Public Function Decode(ByRef Source As Variant) As cJson ``` 解析 JSON 数据为对象。**支持 JSONP 格式、var 变量格式，以及多种对象类型直接转换**。 **参数：** * `Source` - 要解析的数据源，支持以下类型： * `String` - JSON 字符串（标准 JSON / JSONP / var 格式） * `cJson` - 复制另一个 cJson 实例的数据 * `ADODB.Recordset` - 自动转换为 JSON 数组 * `cCollection` - 提取底层 Collection 或 Dictionary * `Collection` - 直接作为 JSON 数组根节点 * `Dictionary` - 直接作为 JSON 对象根节点 **返回：** * 返回自身实例（支持链式调用） **支持格式：** * 标准 JSON: `{"name": "value"}` * JSON 数组: `[{"name": "value"}]` * JSONP: `callback({"name": "value"});` * Var 变量: `var data = {"name": "value"};` **示例：** ```vb '标准 JSON Json.Decode "{""name"":""张三""}" 'JSONP 格式（自动提取） Json.Decode "callback({""name"":""张三""});" 'Var 格式（自动提取） Json.Decode "var data = {""name"":""张三""};" '从其他 cJson 实例复制 Json.Decode AnotherJsonObj '从 Recordset 转换 Json.Decode Rs '链式调用 MsgBox Json.Decode(JsonText).Item("name") ``` ### LoadFrom ```vb Public Function LoadFrom(ByVal Path As String, _ Optional CharSet As String = "UTF-8" _ ) As cJson ``` 从文件加载 JSON 数据。 **参数：** * `Path` - 文件路径 * `CharSet` - 字符编码（默认 UTF-8） **返回：** * 返回自身实例（支持链式调用） **示例：** ```vb '从文件加载 Json.LoadFrom "C:\data.json" '指定编码 Json.LoadFrom "C:\data.json", "GB2312" '链式调用 MsgBox Json.LoadFrom("C:\data.json").Item("name") ``` ### SaveTo ```vb Public Function SaveTo( _ ByVal FileName As String, _ Optional CharSet As String = "UTF-8", _ Optional Whitespace As Variant, _ Optional FromUnicode As Boolean _ ) As String ``` 将 JSON 数据保存到文件。 **参数：** * `FileName` - 文件路径 * `CharSet` - 字符编码（默认 UTF-8） * `Whitespace` - 格式化缩进 * `FromUnicode` - 是否显示中文 **返回：** * 保存的 JSON 字符串内容 **示例：** ```vb '简单保存 Json.SaveTo "C:\data.json" '格式化保存 Json.SaveTo "C:\data.json", "UTF-8", 2, True ``` ### ToArray ```vb Public Function ToArray() As Variant ``` 将 JSON 数据转换为 VB 数组。 **示例：** ```vb Dim Arr As Variant Arr = Json.ToArray() ``` ## 内部函数（Private） 以下函数是内部使用的，不对外公开： ### ConvertToJson 内部使用，将 VB 对象转换为 JSON 字符串（来自 VBA-JSON）。 ### ParseJson 内部使用，解析 JSON 字符串为 VB 对象（来自 VBA-JSON）。 ## 使用技巧 ### 链式访问深层数据 ```vb '多层嵌套访问 MsgBox Json.Item("level1")("level2")("level3") '数组访问（下标从 1 开始） MsgBox Json.Item("users")(1)("name") ``` ### 安全的值获取 ```vb '检查键是否存在（使用 RootItem） If Json.RootItem.Exists("key") Then Value = Json.Item("key") End If '获取数组长度 Dim Count As Long Count = Json.Item("array").Count ``` ### 循环遍历数组 ```vb 'For Each 遍历 Dim Item As Variant For Each Item In Json.Item("data") Debug.Print Item("name") Next 'For 循环遍历（下标从 1 开始） Dim i As Long For i = 1 To Json.Item("data").Count Debug.Print Json.Item("data")(i)("name") Next ``` ### 类型转换注意事项 ```vb '数字转字符串 Dim StrValue As String StrValue = CStr(Json.Item("numberField")) '字符串转数字 Dim NumValue As Long NumValue = CLng(Json.Item("stringField")) '日期处理 Dim DateValue As Date DateValue = CDate(Json.Item("dateField")) ``` --- --- url: /en/vbman/Json/api-reference.md --- # cJson API Reference ## Core Concepts ### VB Type and JSON Correspondence | VB Type | JSON Type | Description | | -------------- | --------------------------- | ------------------- | | **Dictionary** | `{ "key": "value" }` object | Key-value structure | | **Collection** | `[ 1, 2, 3 ]` array | Ordered list | ### Core Member Functions | Member | Primary Purpose | Description | | ------------ | ---------------------------- | -------------------------------------------------------------------------- | | **NewItem** | **Create child object node** | Creates a Dictionary-type child node, corresponding to JSON object `{...}` | | **NewItems** | **Create child array node** | Creates a Collection-type child node, corresponding to JSON array `[...]` | | **Item** | **Set/read object members** | Set/get key-value pairs on the current node (Dictionary) | | **Items** | **Set/read array members** | Set/get array elements on the current node (Collection) | | **Root** | **Chained reading** | Returns root node Object, supports chained access | ### Correct JSON Construction Flow ```vb '1. Create root node (itself is an object node) With New cJson 'Set key-value pairs on root node using Item .Item("name") = "John" .Item("age") = 25 '2. Create child array node (using NewItems) With .NewItems("hobbies") 'Create child array named "hobbies" 'Add elements on child array using Items .Items(0) = "Reading" 'Index=0 means append .Items(0) = "Coding" End With '3. Create child object node (using NewItem) With .NewItem("address") 'Create child object named "address" 'Set key-value pairs on child object using Item .Item("city") = "Beijing" .Item("zip") = "100000" End With '4. Encode to JSON string Dim JsonString As String JsonString = .Encode() 'Output: {"name":"John","age":25,"hobbies":["Reading","Coding"],"address":{"city":"Beijing","zip":"100000"}} End With ``` *** ## Properties ### Public Properties | Property | Type | Description | | --------------- | ---------- | ---------------------------------------------------------------------------------------- | | `Root` | Object | **Default member**, returns root node object (Dictionary/Collection), most commonly used | | `Self` | cJson | Returns the object's own instance (Me), for scenarios requiring passing this object | | `RootText` | String | The JSON text from the last encode/decode operation | | `RootItem` | Dictionary | Root node dictionary object, corresponding to JSON object `{ ... }` | | `RootItems` | Collection | Root node collection object, corresponding to JSON array `[ ... ]` | | `LastError` | String | Last error message | | `WhiteSpaceSet` | Variant | Global indent settings | **Type Correspondence:** * **Dictionary** → JSON object `{ "key": "value" }` (key-value pairs) * **Collection** → JSON array `[ 1, 2, 3 ]` (ordered list) ### Status Properties #### LastSuccess ```vb Public Property Get LastSuccess() As Boolean ``` Returns whether the last operation was successful (`True` when `LastError = ""`). **Example:** ```vb Json.Decode JsonText If Json.LastSuccess Then MsgBox "Parse successful" Else MsgBox "Parse failed: " & Json.LastError End If ``` #### Root (Default Member, for Chained Read/Write) ```vb Public Property Get Root() As Object Attribute Root.VB_UserMemId = 0 ``` Returns the root node object. If `RootItems.Count > 0` returns **Collection (array)**, otherwise returns **Dictionary (object)**. **Important Features:** * **Default Member**: `Root` is the class's default member, allowing direct access with `Json("key")`, equivalent to `Json.Root("key")` * **Returns Object**: Returns Dictionary (corresponding to JSON object `{...}`) or Collection (corresponding to JSON array `[...]`), supports chained nested access * **For Chained Read/Write**: Recommended to use `Root` when reading nested JSON data, supports unlimited levels of chained access * **Type Correspondence**: * Dictionary → JSON object `{ "key": "value" }` * Collection → JSON array `[ 1, 2, 3 ]` **Example:** ```vb 'Direct access (using default member feature) MsgBox Json("name") 'Equivalent to Json.Root("name") MsgBox Json("user")("name") 'Chained access to nested object MsgBox Json("items")(1)("title") 'Access object within array (array index starts from 1) 'Explicitly using Root property MsgBox Json.Root("name") MsgBox Json.Root("user")("name") 'Iterate through array Dim Item As Variant For Each Item In Json("data") Debug.Print Item("name") Next ``` #### RootIsEmpty ```vb Public Property Get RootIsEmpty() As Boolean ``` Checks whether the root node is empty (no key-value pairs and no array elements). **Example:** ```vb If Json.RootIsEmpty Then MsgBox "JSON object is empty" End If ``` #### RootIsArray ```vb Public Property Get RootIsArray() As Boolean ``` Checks whether the root node is of array type. **Example:** ```vb If Json.RootIsArray Then MsgBox "Root node is an array" End If ``` ### Data Access Properties #### Item (Add/Modify Members on Current Object Node) ```vb Public Property Get Item(ByVal Key As String) As Variant Public Property Let Item(ByVal Key As String, Dat As Variant) Public Property Set Item(ByVal Key As String, Dat As Variant) ``` Access or set key-value pairs on the current object node (Dictionary). **Core Purpose:** * **Add/Modify Object Members**: Set key-value pairs on the **current object node**, for building JSON object properties * **Applicable Node**: Only usable on Dictionary-type nodes (including root node and child objects created by NewItem) * **JSON Correspondence**: Operates on Dictionary, corresponding to JSON object `{ "key": "value" }` **Parameters:** * `Key` - Key name (string) * `Dat` - Value to set (any type) **Usage Scenarios:** 1. Set key-value pairs on **root node** (root node defaults to object) 2. Set key-value pairs on **child objects created by NewItem** **Example:** ```vb '===== Scenario 1: Set key-value pairs on root node ===== With New cJson 'Root node itself is an object, use Item directly .Item("name") = "John" .Item("age") = 25 .Item("active") = True 'Result: { "name": "John", "age": 25, "active": true } End With '===== Scenario 2: Set on child object created by NewItem ===== With New cJson 'Create child object "address" With .NewItem("address") 'Set key-value pairs on child object using Item .Item("city") = "Beijing" .Item("zip") = "100000" End With 'Result: { "address": { "city": "Beijing", "zip": "100000" } } End With '===== Reading Values (Recommended: use Root for chained access) ===== 'Not recommended: Item returns Variant, does not support chained access Name = Json.Item("name") 'Recommended: Root returns Object, supports chained access Name = Json.Root("name") City = Json.Root("address")("city") 'Chained access to nested object 'Set object reference Dim SubJson As New cJson Set Json.Item("sub") = SubJson.Root ``` #### Items (Add/Modify Members on Current Array Node) ```vb Public Property Get Items(ByVal Index As Long) As Variant Public Property Let Items(ByVal Index As Long, Dat As Variant) Public Property Set Items(ByVal Index As Long, Dat As Variant) ``` Access or set array elements on the current array node (Collection). **Note: Index starts from 1**. **Core Purpose:** * **Add/Modify Array Members**: Add or modify array elements on the **current array node** * **Applicable Node**: Only usable on Collection-type nodes (child arrays created by NewItems) * **JSON Correspondence**: Operates on Collection, corresponding to JSON array `[ 1, 2, 3 ]` **Parameters:** * `Index` - Array index (starts from 1) * `Dat` - Value to set **Special Usage:** * When `Index = 0`, it means **append** a new element to the end of the array **Usage Scenarios:** 1. Add elements on **child arrays created by NewItems** **Example:** ```vb '===== Scenario: Add elements on child array created by NewItems ===== With New cJson With .NewItems("tags") 'Create child array named "tags" 'Add elements on child array using Items .Items(0) = "VIP" 'Index=0 means append .Items(0) = "Active" .Items(0) = "Paid" End With 'Result: { "tags": ["VIP", "Active", "Paid"] } 'Object elements in array With .NewItems("users") With .NewItem() 'First object element in array .Item("name") = "John" .Item("age") = 25 End With With .NewItem() 'Second object element in array .Item("name") = "Jane" .Item("age") = 30 End With End With 'Result: { "users": [{"name":"John","age":25}, {"name":"Jane","age":30}] } End With '===== Access Array Elements (using Root, starting from 1) ===== Dim First As String First = Json.Root("tags")(1) 'VIP 'Modify array element Json.Root("tags").Items(1) = "New value" 'Iterate through array (recommended: use Root) Dim Item As Variant For Each Item In Json.Root("tags") Debug.Print Item Next 'Modify array element Json.Items(1) = "New value" ``` ## Methods ### Clear ```vb Public Sub Clear() ``` Clear all data and reset object state. **Example:** ```vb Json.Item("name") = "John" Json.Clear 'Now Json.RootIsEmpty = True ``` ### NewItem (Create Child Object Node) ```vb Public Function NewItem(Optional ParentKey As String) As cJson ``` Creates a new **Dictionary-type child node**, corresponding to JSON object `{ ... }`. **Core Purpose:** * **Create Child Object**: Creates a child object (Dictionary) node under the current node * **JSON Correspondence**: Creates a JSON object `{ "key": "value" }` * **Follow-up Operations**: After creation, use `Item` to set key-value pairs on the child object **Parameters:** * `ParentKey` - Key name in parent node (optional) * With key name: child object is mounted under this key in the parent node * Without key name: child object is added to the parent node's array (parent node must be array type) **Returns:** * Newly created cJson instance (Dictionary type) **Usage Flow:** 1. Call `NewItem([Key])` to create child object 2. Use `Item` on the returned cJson instance to set key-value pairs **Example:** ```vb '===== Scenario 1: Create named child object (with ParentKey) ===== With New cJson 'Create child object named "address" With .NewItem("address") 'Set key-value pairs on child object using Item .Item("city") = "Beijing" .Item("zip") = "100000" End With 'Result: { "address": { "city": "Beijing", "zip": "100000" } } End With '===== Scenario 2: Create object element in array (omit ParentKey) ===== With New cJson With .NewItems("users") 'First create array "users" With .NewItem() 'Create first object element in array .Item("name") = "John" .Item("age") = 25 End With With .NewItem() 'Create second object element in array .Item("name") = "Jane" .Item("age") = 30 End With End With 'Result: { "users": [{"name":"John","age":25}, {"name":"Jane","age":30}] } End With '===== Scenario 3: Unlimited Level Nesting ===== With New cJson With .NewItem("level1") With .NewItem("level2") With .NewItem("level3") .Item("value") = "Deep data" End With End With End With 'Result: { "level1": { "level2": { "level3": { "value": "Deep data" } } } } End With ``` ### NewItems (Create Child Array Node) ```vb Public Function NewItems(Optional ParentKey As String) As cJson ``` Creates a new **Collection-type child node**, corresponding to JSON array `[ ... ]`. **Core Purpose:** * **Create Child Array**: Creates a child array (Collection) node under the current node * **JSON Correspondence**: Creates a JSON array `[ 1, 2, 3 ]` * **Follow-up Operations**: After creation, use `Items` to add elements on the child array, or use `NewItem` to add object elements **Parameters:** * `ParentKey` - Key name in parent node (optional) * With key name: child array is mounted under this key in the parent node * Without key name: child array is added to the parent node's array (parent node must be array type) **Returns:** * Newly created cJson instance (Collection type) **Usage Flow:** 1. Call `NewItems([Key])` to create child array 2. On the returned cJson instance: * Use `Items(0)` to add plain value elements * Use `NewItem()` to add object elements **Example:** ```vb '===== Scenario 1: Create named child array (with ParentKey) ===== With New cJson 'Create child array named "tags" With .NewItems("tags") 'Add elements on child array using Items .Items(0) = "VIP" 'Index=0 means append .Items(0) = "Active" .Items(0) = "Paid" End With 'Result: { "tags": ["VIP", "Active", "Paid"] } End With '===== Scenario 2: Create array within array (omit ParentKey) ===== With New cJson With .NewItems("matrix") 'Create two-dimensional array With .NewItems() 'First row array .Items(0) = 1 .Items(0) = 2 End With With .NewItems() 'Second row array .Items(0) = 3 .Items(0) = 4 End With End With 'Result: { "matrix": [[1, 2], [3, 4]] } End With '===== Scenario 3: Object Array (Mixed use of NewItem and Items) ===== With New cJson With .NewItems("users") 'Array element is object: use NewItem to create, use Item to set With .NewItem() .Item("name") = "John" .Item("age") = 25 End With 'Add another object With .NewItem() .Item("name") = "Jane" .Item("age") = 30 End With End With 'Result: { "users": [{"name":"John","age":25}, {"name":"Jane","age":30}] } End With ``` ### Encode ```vb Public Function Encode( _ Optional Obj As Variant, _ Optional Whitespace As Variant, _ Optional FromUnicode As Boolean _ ) As String ``` Encodes an object to a JSON string. **Parameters:** * `Obj` - Object to encode (optional, uses internal RootItem/RootItems when omitted) * `Whitespace` - Format indent (number for spaces, string for indent characters) * `FromUnicode` - Whether to decode Unicode encoding to Chinese characters (True displays Chinese) **Returns:** * JSON string **Example:** ```vb 'Simple encoding Dim JsonStr As String JsonStr = Json.Encode() 'Formatted output (2-space indent) JsonStr = Json.Encode(, 2) 'Formatted and display Chinese JsonStr = Json.Encode(, 2, True) 'Encode specified object JsonStr = Json.Encode(Json.Item("subObject"), 2, True) ``` ### Decode ```vb Public Function Decode(ByRef Source As Variant) As cJson ``` Parses JSON data into an object. **Supports JSONP format, var variable format, and direct conversion from multiple object types**. **Parameters:** * `Source` - Data source to parse, supports the following types: * `String` - JSON string (standard JSON / JSONP / var format) * `cJson` - Copy data from another cJson instance * `ADODB.Recordset` - Automatically convert to JSON array * `cCollection` - Extract underlying Collection or Dictionary * `Collection` - Directly use as JSON array root node * `Dictionary` - Directly use as JSON object root node **Returns:** * Returns self instance (supports chained calling) **Supported Formats:** * Standard JSON: `{"name": "value"}` * JSON Array: `[{"name": "value"}]` * JSONP: `callback({"name": "value"});` * Var variable: `var data = {"name": "value"};` **Example:** ```vb 'Standard JSON Json.Decode "{""name"":""John""}" 'JSONP format (auto-extracted) Json.Decode "callback({""name"":""John""});" 'Var format (auto-extracted) Json.Decode "var data = {""name"":""John""};" 'Copy from another cJson instance Json.Decode AnotherJsonObj 'Convert from Recordset Json.Decode Rs 'Chained calling MsgBox Json.Decode(JsonText).Item("name") ``` ### LoadFrom ```vb Public Function LoadFrom(ByVal Path As String, _ Optional CharSet As String = "UTF-8" _ ) As cJson ``` Loads JSON data from a file. **Parameters:** * `Path` - File path * `CharSet` - Character encoding (default UTF-8) **Returns:** * Returns self instance (supports chained calling) **Example:** ```vb 'Load from file Json.LoadFrom "C:\data.json" 'Specify encoding Json.LoadFrom "C:\data.json", "GB2312" 'Chained calling MsgBox Json.LoadFrom("C:\data.json").Item("name") ``` ### SaveTo ```vb Public Function SaveTo( _ ByVal FileName As String, _ Optional CharSet As String = "UTF-8", _ Optional Whitespace As Variant, _ Optional FromUnicode As Boolean _ ) As String ``` Saves JSON data to a file. **Parameters:** * `FileName` - File path * `CharSet` - Character encoding (default UTF-8) * `Whitespace` - Format indent * `FromUnicode` - Whether to display Chinese characters **Returns:** * Saved JSON string content **Example:** ```vb 'Simple save Json.SaveTo "C:\data.json" 'Formatted save Json.SaveTo "C:\data.json", "UTF-8", 2, True ``` ### ToArray ```vb Public Function ToArray() As Variant ``` Converts JSON data to a VB array. **Example:** ```vb Dim Arr As Variant Arr = Json.ToArray() ``` ## Internal Functions (Private) The following functions are for internal use and are not publicly exposed: ### ConvertToJson Internal use, converts VB objects to JSON strings (from VBA-JSON). ### ParseJson Internal use, parses JSON strings into VB objects (from VBA-JSON). ## Usage Tips ### Chained Access to Deep Data ```vb 'Multi-level nested access MsgBox Json.Item("level1")("level2")("level3") 'Array access (index starts from 1) MsgBox Json.Item("users")(1)("name") ``` ### Safe Value Retrieval ```vb 'Check if key exists (using RootItem) If Json.RootItem.Exists("key") Then Value = Json.Item("key") End If 'Get array length Dim Count As Long Count = Json.Item("array").Count ``` ### Loop Through Array ```vb 'For Each iteration Dim Item As Variant For Each Item In Json.Item("data") Debug.Print Item("name") Next 'For loop iteration (index starts from 1) Dim i As Long For i = 1 To Json.Item("data").Count Debug.Print Json.Item("data")(i)("name") Next ``` ### Type Conversion Notes ```vb 'Number to string Dim StrValue As String StrValue = CStr(Json.Item("numberField")) 'String to number Dim NumValue As Long NumValue = CLng(Json.Item("stringField")) 'Date handling Dim DateValue As Date DateValue = CDate(Json.Item("dateField")) ``` --- --- url: /en/vbman/Json/best-practices.md --- # cJson Best Practices and Tips ## Usage Recommendations ### 1. Instance Selection | Scenario | Recommended Approach | Description | | ----------------- | ------------------------- | ------------------------- | | Temporary use | `With New cJson` | Auto-cleanup after use | | Need to persist | `Dim Json As New cJson` | Can be passed across methods | | Global config | `VBMAN.Json` | Global shared, remember to clean | **Recommended Code:** ```vb 'Temporary use - recommended approach With New VBMANLIB.cJson .Item("key") = "value" MsgBox .Encode() End With 'Object auto-released, no manual cleanup needed ``` ### 2. Array Operation Notes **Important: Array index starts from 1!** ```vb With Json.NewItems("items") 'Add elements using 0 .Items(0) = "First item" .Items(0) = "Second item" End With 'Access using 1-based index MsgBox Json.Item("items")(1) 'First item MsgBox Json.Item("items")(2) 'Second item ``` ### 3. Timely Cleaning of Global Instance When using the `VBMAN.Json` global instance, remember to clean before starting: ```vb With VBMAN.Json .Clear 'Important! Clean previous data .Item("key") = "value" '... End With ``` ### 4. Naming Convention Recommendations ```vb 'JSON key names recommended: camelCase or snake_case Json.Item("userName") 'camelCase Json.Item("user_name") 'snake_case 'Avoid Chinese key names (even though supported) Json.Item("Username") 'Not recommended, may cause compatibility issues ``` ## Performance Optimization ### 1. Large Batch Data Processing ```vb 'Recommended: Estimate array size in advance if possible Private Sub BatchProcess() With New cJson With .NewItems("records") Dim Rs As ADODB.Recordset Set Rs = GetData() 'Use With statement to reduce object lookup Do While Not Rs.EOF With .NewItem() .Item("id") = Rs("id") .Item("name") = Rs("name") End With Rs.MoveNext Loop End With 'Single output, avoid multiple Encode calls Dim Result As String Result = .Encode(, 0) 'Compact format saves space End With End Sub ``` ### 2. Chained Access vs. Layered Processing **Recommended: Chained Access** (concise and clear): ```vb 'Direct chained access to nested data MsgBox Json.Root("user")("profile")("name") MsgBox Json.Root("data")(1)("title") ``` **Only use layered processing when reusing sub-nodes:** ```vb 'When needing to use the same sub-node multiple times, layered is more efficient Dim User As Object Set User = Json.Root("user") MsgBox User("name") MsgBox User("email") MsgBox User("profile")("age") ``` ## Common Pitfalls ### Pitfall 1: Forget to Check if Key Exists ```vb 'Wrong: Directly access a key that may not exist MsgBox Json.Item("mayNotExist") 'May error 'Correct: Check existence first If Json.RootItem.Exists("mayNotExist") Then MsgBox Json.Item("mayNotExist") Else MsgBox "Key does not exist" End If ``` ### Pitfall 2: Confuse Root, Item, and Items ```vb 'Root - for reading data (default member, returns Object supporting chained access) MsgBox Json.Root("key") MsgBox Json.Root("level1")("level2") 'Chained access to nested object 'Item - for setting key-value pairs (has Let/Set) Json.Item("key") = "value" 'Items - for arrays (Collection), Index=0 means append Json.Items(0) = "value" 'Add element MsgBox Json.Root("arr")(1) 'Access element (index starts from 1) 'Wrong examples: Json.Item(1) = "value" 'Wrong! Item requires string key Json.Items("key") 'Wrong! Items requires numeric index ``` ### Pitfall 3: Collection Index Out of Bounds ```vb 'Wrong: Assume collection has elements (cJson uses VB Collection for arrays) MsgBox Json.Root("items")(1) 'Will error if collection is empty 'Correct: Check Count first If Json.Root("items").Count > 0 Then MsgBox Json.Root("items")(1) End If ``` ## Error Handling Best Practices ```vb Private Sub ProcessJson() On Error GoTo ErrorHandler Dim Json As New cJson 'Parse JSON Json.Decode JsonText If Not Json.LastSuccess Then LogError "JSON parse failed: " & Json.LastError Exit Sub End If 'Check required fields If Not ValidateRequiredFields(Json) Then LogError "Missing required fields" Exit Sub End If 'Process data ProcessData Json Exit Sub ErrorHandler: LogError "Processing error: " & Err.Description End Sub Private Function ValidateRequiredFields(Json As cJson) As Boolean ValidateRequiredFields = True If Not Json.RootItem.Exists("code") Then ValidateRequiredFields = False Exit Function End If If Not Json.RootItem.Exists("data") Then ValidateRequiredFields = False Exit Function End If End Function ``` ## HTTP Request Integration Recommendations ### GET Request Handling ```vb Private Sub HandleGetRequest() On Error Resume Next With VBMAN.HttpClient.Fetch(ReqGet, "https://api.example.com/data").ReturnJson() If .Item("code") <> 200 Then MsgBox "Request failed: " & .Item("message") Exit Sub End If 'Process successful response ProcessSuccessResponse .Item("data") End With If Err.Number <> 0 Then MsgBox "Network error: " & Err.Description End If End Sub ``` ### POST Request Handling ```vb Private Sub HandlePostRequest() On Error GoTo ErrorHandler 'Construct request body Dim Body As String With New cJson .Item("action") = "submit" .Item("timestamp") = Now() Body = .Encode() End With 'Send request With New cHttpClient .SetRequestContentType JsonString .SendPost "https://api.example.com/submit", Body 'Parse response With .ReturnJson() Select Case .Item("code") Case 200 MsgBox "Submit successful" Case 400 MsgBox "Parameter error: " & .Item("message") Case 500 MsgBox "Server error" Case Else MsgBox "Unknown error: " & .Item("message") End Select End With End With Exit Sub ErrorHandler: Debug.Print "Error: " & Err.Description End Sub ``` ## File Operation Recommendations ### Safe File Read/Write ```vb Private Sub SafeFileOperation() Dim FilePath As String FilePath = App.Path & "\data\config.json" 'Check if file exists (SaveTo will auto-create directories) If Dir(FilePath) <> "" Then 'Backup old file FileCopy FilePath, FilePath & ".bak" End If 'Write new content (SaveTo internally calls ToolsFso.AutoMakeDir to create directories) With New cJson .Item("version") = "1.0" .SaveTo FilePath, "UTF-8", 2, True End With End Sub ``` **Note:** The `SaveTo` method internally calls `ToolsFso.AutoMakeDir` to create directories, no need to manually create them. ## Debug Tips ### Using Formatted Output ```vb 'Development stage: use formatted output Debug.Print Json.Encode(, 2, True) 'Production environment: use compact format ResponseText = Json.Encode() ``` ### Recording Debug Information ```vb Private Sub LogJson(Json As cJson, Context As String) Debug.Print "=== " & Context & " ===" Debug.Print Json.Encode(, 2, True) Debug.Print "========================" End Sub ``` --- --- url: /en/vbman/Json/examples.md --- # cJson Code Examples This document contains detailed example code for various practical usage scenarios. ## Table of Contents 1. [Basic Examples](#basic-examples) 2. [HTTP API Interaction](#http-api-interaction) 3. [File Operations](#file-operations) 4. [Complex Data Structures](#complex-data-structures) 5. [Real Business Scenarios](#real-business-scenarios) *** ## Basic Examples ### Example 1: Creating a User Info Object ```vb Private Sub CreateUserInfo() With New VBMANLIB.cJson .Item("username") = "admin" .Item("password") = "123456" .Item("age") = 40 .Item("name") = "Deng Wei" 'Formatted output, display Chinese Debug.Print .Encode(, 2, True) End With End Sub ``` Output: ```json { "username": "admin", "password": "123456", "age": 40, "name": "Deng Wei" } ``` ### Example 2: Creating JSON with an Array ```vb Private Sub CreateWithArray() With New VBMANLIB.cJson .Item("code") = 200 .Item("msg") = "Success" 'Create plain value array With .NewItems("hobbies") .Items(0) = "Reading" .Items(0) = "Swimming" .Items(0) = "Coding" End With Debug.Print .Encode(, 2, True) End With End Sub ``` Output: ```json { "code": 200, "msg": "Success", "hobbies": ["Reading", "Swimming", "Coding"] } ``` ### Example 3: Parsing and Reading JSON ```vb Private Sub ParseAndRead() Dim JsonText As String JsonText = "{""servicesn"":""0001"",""userid"":""admin"",""token"":"""",""argcounts"":2}" With New VBMANLIB.cJson .Decode JsonText 'Read fields using Root (recommended approach) Debug.Print "Service SN: " & .Root("servicesn") Debug.Print "User ID: " & .Root("userid") Debug.Print "Token: " & .Root("token") Debug.Print "Arg Counts: " & .Root("argcounts") End With End Sub ``` *** ## HTTP API Interaction ### Example 4: Constructing a POST Request Body **Method 1: Using an independent cJson instance (recommended for complex structures)** ```vb Private Sub BuildPostBody() Dim Body As String 'Create independent JSON object With New cJson .Item("sysStuffCode") = "TEST001" .Item("quantity") = 2 'Construct array With .NewItems("detailList") Dim i As Long For i = 0 To 3 With .NewItem() .Item("test") = 123 .Item("time") = Now() End With Next End With Body = .Encode() End With 'Send request With New cHttpClient .RequestHeaders.Add "Content-Type", "application/json" .Fetch ReqPost, "https://api.example.com/submit", Body Debug.Print .ReturnText() End With End Sub ``` **Method 2: Using HttpClient's built-in RequestDataJson object (concise approach)** ```vb Private Sub BuildPostBodySimple() With VBMAN.HttpClient 'Use built-in RequestDataJson object to construct request body With .RequestDataJson .Clear 'Clear previous data .Item("sysStuffCode") = "TEST001" .Item("quantity") = 2 With .NewItems("detailList") Dim i As Long For i = 0 To 3 With .NewItem() .Item("test") = 123 .Item("time") = Now() End With Next End With End With 'Set request type and send (ContentType=Json auto-uses RequestDataJson) .SetRequestContentType JsonString .SendPost "https://api.example.com/submit" 'Body parameter can be omitted, auto-uses RequestDataJson Debug.Print .ReturnText() End With End Sub ``` ### Example 5: Handling API Response ```vb Private Sub HandleApiResponse() Const API_BASE As String = "https://api.example.com" Const API_PULL_WAYBILL As String = API_BASE & "/api/pullWaybill" 'Construct request data Dim Body As String With New cJson .Item("wayBillId") = "46349936" .Item("clientId") = "CLIENT001" .Item("token") = "cbe84888-9f48-4c00-aae6-3170bf5951cd" Body = .Encode() End With 'Send request and handle response On Error GoTo ErrorHandler With VBMAN.HttpClient .SetRequestContentType JsonString .SendPost API_PULL_WAYBILL, Body With .ReturnJson() 'Display full response Text2.Text = .Encode(, 2, True) 'Check business status If .Root("success") = True Then MsgBox "Cargo Name: " & .Root("data")("cargoName"), , "Waybill No: " & .Root("data")("wayBillId") Else MsgBox .Root("message"), , "Request Failed" End If End With End With Exit Sub ErrorHandler: Debug.Print VBMAN.HttpClient.DebugInfo.Encode(, 2, True) End Sub ``` ### Example 6: Fetching Data with Query Parameters ```vb Private Sub FetchWithQuery() Const API_BASE As String = "https://api.example.com" Const API_SALE_PLAN As String = API_BASE & "/api/salePlan/selectByVehicleNo" On Error Resume Next 'Use built-in query builder (auto URL-encode) VBMAN.HttpClient.RequestDataQuery.Add "vehicleNo", "鲁B70AP0" With VBMAN.HttpClient.Fetch(ReqGet, API_SALE_PLAN).ReturnJson() 'Display formatted result Text1.Text = .Encode(, 2, True) 'Check return status (using Root access) If .Root("code") = 200 Then 'Loop through array Dim x As Variant For Each x In .Root("data") List1.AddItem x("planCode") List1.AddItem x("warehouseName") Next 'Directly get specific array object (using Root chained access) With .Root("data")(1) List1.AddItem .Root("planCode") List1.AddItem .Root("warehouseName") End With Else MsgBox .Root("message") End If End With End Sub ``` *** ## File Operations ### Example 7: Saving Configuration to a JSON File ```vb Private Sub SaveConfig() With VBMAN.Json 'Clear previous data .Clear .Item("appName") = "MyApplication" .Item("version") = "1.0.0" .Item("debug") = True 'Nested config object With .NewItem("database") .Item("host") = "localhost" .Item("port") = 3306 .Item("username") = "root" .Item("password") = "secret" End With 'Save to file .SaveTo App.Path & "\config.json", "UTF-8", 2, True MsgBox "Configuration saved" End With End Sub ``` ### Example 8: Loading Configuration from a JSON File ```vb Private Sub LoadConfig() Dim ConfigPath As String ConfigPath = App.Path & "\config.json" 'Check if file exists If Dir(ConfigPath) = "" Then MsgBox "Configuration file does not exist" Exit Sub End If With New VBMANLIB.cJson .LoadFrom ConfigPath 'Read configuration Dim AppName As String Dim DbHost As String Dim DbPort As Long AppName = .Root("appName") DbHost = .Root("database")("host") DbPort = .Root("database")("port") MsgBox "App: " & AppName & vbCrLf & _ "Database: " & DbHost & ":" & DbPort End With End Sub ``` ### Example 9: Loading from File and Modifying ```vb Private Sub ModifyJsonFile() Dim FilePath As String FilePath = "C:\tmp\data.json" With New VBMANLIB.cJson .LoadFrom FilePath 'Modify data .Item("name") = "New Name" .Item("updated") = Now() 'Save back to file .SaveTo FilePath, "UTF-8", 2, True End With End Sub ``` *** ## Complex Data Structures ### Example 10: Unlimited Level Nesting ```vb Private Sub NestedStructure() With New VBMANLIB.cJson .Item("a") = 1 .Item("b") = "dengwei" With .NewItems("c") Dim i As Long For i = 0 To 3 With .NewItem() .Item("d") = Now() .Item("e") = 34 + i .Item("f") = "Data: " & i 'Create deeper nesting With .NewItem("g") .Item("g1") = 123 .Item("g2") = 456 End With With .NewItems("h") .Items(0) = "Array element 1" .Items(0) = "Array element 2" End With End With Next End With 'Save and display .SaveTo "C:\tmp\nested.json", , 2, True Text1.Text = .Encode(, 2, True) End With End Sub ``` ### Example 11: Mixed Array (Objects and Plain Values) ```vb Private Sub MixedArray() With New VBMANLIB.cJson 'Object array With .NewItems("users") With .NewItem() .Item("name") = "John" .Item("age") = 25 End With With .NewItem() .Item("name") = "Jane" .Item("age") = 30 End With End With 'Plain value array With .NewItems("tags") .Items(0) = "VIP" .Items(0) = "Active" .Items(0) = "Paid" End With Debug.Print .Encode(, 2, True) End With End Sub ``` Output: ```json { "users": [ { "name": "John", "age": 25 }, { "name": "Jane", "age": 30 } ], "tags": ["VIP", "Active", "Paid"] } ``` ### Example 12: Parsing Complex Nested JSON ```vb Private Sub ParseComplexNested() 'Assume this is complex JSON from an API Dim JsonText As String JsonText = "{" JsonText = JsonText & """code"":200," JsonText = JsonText & """data"":{" JsonText = JsonText & " ""company"":""ABC Corp""," JsonText = JsonText & " ""departments"":[{" JsonText = JsonText & " ""name"":""Engineering""," JsonText = JsonText & " ""employees"":[{""name"":""John"",""position"":""Engineer""}]" JsonText = JsonText & " }]" JsonText = JsonText & "}" JsonText = JsonText & "}" With New VBMANLIB.cJson .Decode JsonText 'Deep chained access using Root Dim Company As String Dim DeptName As String Dim EmpName As String Company = .Root("data")("company") DeptName = .Root("data")("departments")(1)("name") EmpName = .Root("data")("departments")(1)("employees")(1)("name") MsgBox "Company: " & Company & vbCrLf & _ "Department: " & DeptName & vbCrLf & _ "Employee: " & EmpName End With End Sub ``` *** ## Real Business Scenarios ### Example 13: User Login API (HTTP Server) ```vb 'In business class (e.g., bHello.cls) Public Sub Login(ctx As cHttpServerContext) Dim username As String: username = ctx.Request.Form("username") Dim password As String: password = ctx.Request.Form("password") With New cJson .Item("name") = "Deng Wei" .Item("age") = 40 .Item("username") = username .Item("password") = password 'Return formatted JSON ctx.Response.Text .Encode(, 2, True) End With End Sub ``` ### Example 14: SSE Data Push ```vb 'In timed send class (e.g., bSendData.cls) Private Sub SendTotalData() With New VBMANLIB.cJson 'Server time With .NewItem() .Item("id") = "serverTime" .Item("value") = Format(Now(), "yyyy-MM-dd HH:mm:ss") End With 'Statistics data With .NewItem() .Item("id") = "today_count" .Item("value") = GetTodayCount() End With With .NewItem() .Item("id") = "yesterday_count" .Item("value") = GetYesterdayCount() End With 'Send to frontend Form1.HttpServer.SSE.SendPack "total", .Encode() End With End Sub ``` ### Example 15: Database Records to JSON **Method 1: Using RsToCollection function (Recommended)** VBMAN provides the global function `VBMAN.ToolsList.RsToCollection`, which can directly convert a Recordset to a Collection. Using it with cJson is simpler: ```vb Private Sub RecordsToJsonEasy() Dim Rs As ADODB.Recordset Set Rs = GetRecords() 'Get database recordset With New VBMANLIB.cJson .Item("code") = 200 .Item("total") = Rs.RecordCount 'Directly assign converted collection .Item("data") = VBMAN.ToolsList.RsToCollection(Rs) ctx.Response.Text .Encode(, 2, True) End With End Sub ``` **Method 2: Manual iteration construction (for understanding principles)** ```vb Private Sub RecordsToJson() Dim Rs As ADODB.Recordset Set Rs = GetRecords() 'Get database recordset With New VBMANLIB.cJson .Item("code") = 200 .Item("total") = Rs.RecordCount With .NewItems("data") Do While Not Rs.EOF With .NewItem() .Item("id") = Rs("id") .Item("name") = Rs("name") .Item("created") = Rs("created_at") End With Rs.MoveNext Loop End With 'Output or save ctx.Response.Text .Encode(, 2, True) End With End Sub ``` > **Tip**: The `RsToCollection` function is available globally via `VBMAN.ToolsList.RsToCollection`. It automatically handles pagination and field mapping, making it the best practice for converting database records to JSON. ### Example 16: Batch Task Data Structure ```vb Private Function MakeTaskData() As String With New cJson 'Root is an array, need NewItem first With .NewItem() .Item("uuid") = GenerateUUID() .Item("task_no") = "TASK001" .Item("task_type") = 1 .Item("factory_code") = "0206" .Item("warehouse_code") = "0601" 'Detail array With .NewItems("detail") With .NewItem() .Item("row_no") = 1 .Item("part_no") = "PART001" .Item("qty") = 45.5 End With With .NewItem() .Item("row_no") = 2 .Item("part_no") = "PART002" .Item("qty") = 30.0 End With End With End With MakeTaskData = .Encode(.Root, 2) End With End Function ``` ### Example 17: Dynamically Building Report Data ```vb Private Sub BuildReportData() With New VBMANLIB.cJson .Item("ReportTime") = Format(Date, "yyyy-mm-dd") .Item("SampleModel") = "Sample Model 123" .Item("ProductModel") = "Product Model ABC" Dim i As Long For i = 1 To 10 With .NewItem("record" & i) .Item("TestNum") = "TEST" & i .Item("T1") = RandValue() .Item("T2") = RandValue() .Item("Result") = IIf(i Mod 2 = 0, "PASS", "FAIL") End With Next 'Save report .SaveTo App.Path & "\Reports\" & Format(Now(), "yyyymmdd") & ".json", , 2, True End With End Sub ``` ### Example 18: Using Global Instance for Data Caching ```vb Private Sub UseGlobalInstance() 'Use global VBMAN.Json instance to cache configuration With VBMAN.Json .Clear 'Clean first .Item("api_url") = "https://api.example.com" .Item("timeout") = 30 .Item("retry") = 3 'Can be used elsewhere directly (Root is default member) 'MsgBox VBMAN.Json.Root("api_url") 'Or shorthand: 'MsgBox VBMAN.Json("api_url") End With End Sub ``` *** ## Debug Tips ### Example 19: Formatted Output for Debugging ```vb Private Sub DebugJson() With New VBMANLIB.cJson 'Build complex data... .Item("data") = "Some data" 'Output to immediate window (formatted) Debug.Print .Encode(, 2, True) 'Output to text box Text1.Text = .Encode(, 2, True) 'Compact format (for transmission) Debug.Print .Encode() End With End Sub ``` ### Example 20: Error Handling Pattern ```vb Private Sub SafeParse() On Error GoTo ErrorHandler Dim Json As New cJson Json.Decode Text1.Text If Not Json.LastSuccess Then MsgBox "JSON parse failed: " & Json.LastError Exit Sub End If 'Safe data access If Json.RootItem.Exists("name") Then MsgBox "Name: " & Json.Item("name") Else MsgBox "name field does not exist" End If Exit Sub ErrorHandler: MsgBox "Error occurred: " & Err.Number & " - " & Err.Description End Sub ``` --- --- url: /en/vbman/Json/README.md --- # cJson Developer Documentation ## Introduction `cJson` is the JSON processing class provided by the VBMAN framework, improved and encapsulated based on VBA-JSON v2.3.1. It provides a simple and easy-to-use API to parse and generate JSON data, supporting nested objects, arrays, file operations, and more. ## Documentation Navigation | Document | Description | Target Audience | | -------------------------------------------- | -------------------------- | ---------------- | | [index.md](./index.md) | Overview and key features | All developers | | [quickstart.md](./quickstart.md) | 5-minute quick start guide | New developers | | [api-reference.md](./api-reference.md) | Complete API reference | All developers | | [examples.md](./examples.md) | Detailed code examples | All developers | | [best-practices.md](./best-practices.md) | Best practices and tips | Advanced users | | [faq.md](./faq.md) | Frequently asked questions | All developers | ## Quick Start ### Add Reference Ensure your project has a reference to the `VBMAN` library added. ### Simplest Example ```vb 'Create a JSON object With New VBMANLIB.cJson .Item("name") = "John" .Item("age") = 25 MsgBox .Encode(, 2, True) End With ``` Output: ```json { "name": "John", "age": 25 } ``` ### Parse a JSON String (Using Root) ```vb Dim JsonText As String JsonText = "{""name"":""John"",""age"":25}" With New VBMANLIB.cJson .Decode JsonText 'Access using Root (default member) - recommended approach MsgBox .Root("name") 'Output: John 'Or shorthand: MsgBox $("name") 'Output: John End With ``` ## Core Features * **Clear Type Mapping**: Dictionary ↔ JSON object `{...}`, Collection ↔ JSON array `[...]` * **Separated Node Creation and Member Setting**: `NewItem/NewItems` create child nodes, `Item/Items` add/modify members on nodes * **Default Member**: `Root` is the default member, allowing direct access via `Json("key")` and supporting chained nesting * **Nested Support**: Unlimited levels of JSON object and array nesting * **File Operations**: Load and save JSON data from/to files * **Encoding/Decoding**: Bidirectional conversion between JSON strings and VB objects * **Formatted Output**: Custom indent formatting for JSON strings * **Chinese Support**: Display Chinese characters directly (no Unicode transcoding) * **Array Indexing**: Collection array indices start from **1** (following VB conventions) ## Important Notes 1. **Type Correspondence**: Dictionary corresponds to JSON object `{...}`, Collection corresponds to JSON array `[...]` 2. **Root is Default Member**: Directly access with `Json("key")`, equivalent to `Json.Root("key")`, used for chained read/write 3. **NewItem/NewItems Create Nodes**: `NewItem` creates child object nodes, `NewItems` creates child array nodes 4. **Item/Items Modify Members**: `Item` sets key-value pairs on object nodes, `Items` adds elements on array nodes 5. **Array Index Starts from 1**: VB's Collection object indexing starts from 1, unlike JavaScript 6. **Global Instance Shares Data**: `VBMAN.Json` is a global instance, data persists between uses; call `.Clear()` when necessary ## Author Information * **Author**: Deng Wei * **QQ**: 215879458 * **Based on**: VBA-JSON v2.3.1 by Tim Hall (https://github.com/VBA-tools/VBA-JSON) ## License This documentation follows the project license. *** *Last updated: March 7, 2026* --- --- url: /en/vbman/Json.md --- # cJson Developer Documentation ## Overview `cJson` is the JSON processing class provided by the VBMAN framework, improved and encapsulated based on VBA-JSON v2.3.1 (Tim Hall). It provides a simple and easy-to-use API to parse and generate JSON data, supporting nested objects, arrays, file operations, and more. ## Key Features * **Clear Type Mapping**: Dictionary ↔ JSON object `{...}`, Collection ↔ JSON array `[...]` * **Separated Node Creation and Member Setting**: `NewItem/NewItems` create child nodes, `Item/Items` add/modify members on nodes * **Default Member**: `Root` is the default member, allowing direct access via `Json("key")` and supporting chained nesting * **Nested Support**: Unlimited levels of JSON object and array nesting * **File Operations**: Load and save JSON data from/to files * **Encoding/Decoding**: Bidirectional conversion between JSON strings and VB objects * **Formatted Output**: Custom indent formatting for JSON strings * **Chinese Support**: Display Chinese characters directly (no Unicode transcoding) * **Array Indexing**: Collection array indices start from **1** (following VB conventions) ## Creating Instances ### Method 1: Using the Global Instance (Recommended) ```vb 'Use the built-in global Json instance of VBMAN With VBMAN.Json .Item("name") = "John" MsgBox .Encode() End With ``` ### Method 2: Creating a New Instance ```vb 'Create an independent instance Dim Json As New VBMANLIB.cJson Json.Item("name") = "John" MsgBox Json.Encode() 'Or use With New With New VBMANLIB.cJson .Item("name") = "John" MsgBox .Encode() End With ``` ## Quick Examples ### Example 1: Creating a Simple JSON Object ```vb With New cJson .Item("code") = 200 .Item("msg") = "Success" .Item("data") = "Response data" MsgBox .Encode(, 2, True) End With 'Output: '{ ' "code": 200, ' "msg": "Success", ' "data": "Response data" '} ``` ### Example 2: Creating JSON with an Array ```vb With New cJson .Item("code") = 200 .Item("msg") = "Success" With .NewItems("data") 'Create array With .NewItem() 'First object in array .Item("name") = "John" .Item("age") = 25 End With With .NewItem() 'Second object in array .Item("name") = "Jane" .Item("age") = 30 End With End With MsgBox .Encode(, 2, True) End With ``` ### Example 3: Parsing a JSON String (Using Root) ```vb Dim JsonText As String JsonText = "{""name"":""John"",""age"":25}" With New cJson .Decode JsonText 'Access using Root (default member) - recommended approach MsgBox .Root("name") 'Output: John MsgBox .Root("age") 'Output: 25 'Or use the default member feature directly MsgBox $("name") 'Output: John End With ``` ### Example 4: Convert Database Recordset to JSON in One Line ```vb 'cJson.Decode directly supports ADODB.Recordset, one-liner conversion MsgBox VBMAN.Json.Decode(Rs).Encode(, 2, True) 'Or use an independent instance With New cJson .Decode VBMAN.Db.Rs MsgBox .Encode(, 2, True) End With ``` ## Documentation Navigation * [Quick Start](./quickstart.md) - 5-minute guide * [API Reference](./api-reference.md) - Complete properties and methods * [Code Examples](./examples.md) - Detailed code examples ## Important Notes 1. **Type Correspondence**: Dictionary corresponds to JSON object `{...}`, Collection corresponds to JSON array `[...]` 2. **Root is Default Member**: Directly access with `Json("key")`, equivalent to `Json.Root("key")`, used for chained read/write 3. **NewItem/NewItems Create Nodes**: `NewItem` creates child object nodes, `NewItems` creates child array nodes 4. **Item/Items Modify Members**: `Item` sets key-value pairs on object nodes, `Items` adds elements on array nodes 5. **Array Index Starts from 1**: VB's Collection object indexing starts from 1, unlike JavaScript 6. **Global Instance Shares Data**: `VBMAN.Json` is a global instance, data persists between uses; call `.Clear()` when necessary --- --- url: /en/vbman/Json/faq.md --- # cJson Frequently Asked Questions (FAQ) ## Basic Questions ### Q1: Where is the cJson class defined? **A:** The cJson class is defined in the `VBMAN` library, located at: ``` vbman/src/Tools/Json/cJson.cls ``` To use it in your project, add a reference to the VBMAN library: ```vb 'Standard reference method Dim Json As New VBMANLIB.cJson 'Or use the VBMAN global instance With VBMAN.Json '... End With ``` ### Q2: Why do array indices start from 1 instead of 0? **A:** cJson internally uses VB's `Collection` object to store arrays, and VB's Collection indexing starts from 1. This follows VB developer conventions. ```vb 'Add elements using 0 (means append) Json.Items(0) = "Element 1" Json.Items(0) = "Element 2" 'Access using 1-based index (via Root) MsgBox Json.Root("items")(1) 'Element 1 MsgBox Json.Root("items")(2) 'Element 2 ``` ### Q3: How to clear a cJson instance? **A:** Use the `Clear` method: ```vb Json.Clear 'Clear all data ``` **Note:** When using the `VBMAN.Json` global instance, it's recommended to call `Clear` first: ```vb With VBMAN.Json .Clear 'Clean previous data .Item("key") = "value" End With ``` ## Usage Questions ### Q4: How to check if JSON parsing was successful? **A:** Use the `LastSuccess` property: ```vb Json.Decode JsonText If Json.LastSuccess Then MsgBox "Parse successful" Else MsgBox "Parse failed: " & Json.LastError End If ``` ### Q5: How to check if a key exists? **A:** Use the `RootItem.Exists` method to check, use `Root` to access: ```vb If Json.RootItem.Exists("key") Then MsgBox Json.Root("key") Else MsgBox "Key does not exist" End If ``` ### Q6: How to iterate through a JSON array? **A:** Use `Root` to access the array, two iteration methods: ```vb 'Method 1: For Each (recommended) Dim Item As Variant For Each Item In Json.Root("data") Debug.Print Item("name") Next 'Method 2: For loop (index starts from 1) Dim i As Long For i = 1 To Json.Root("data").Count Debug.Print Json.Root("data")(i)("name") Next ``` ### Q7: How to handle nested objects? **A:** Use `Root` for chained access or layered access: ```vb 'Chained access (recommended) MsgBox Json.Root("level1")("level2")("level3") 'Or use default member feature (more concise) MsgBox Json("level1")("level2")("level3") 'Layered access (recommended for deep nesting) Dim Level1 As Object Dim Level2 As Object Set Level1 = Json.Root("level1") Set Level2 = Level1("level2") MsgBox Level2("level3") ``` ## Encoding Issues ### Q8: How to display Chinese characters instead of Unicode? **A:** Set the third parameter of `Encode` to `True`: ```vb Json.Encode(, 2, True) 'Third parameter True means display Chinese as-is ``` ### Q9: How to format JSON string output? **A:** Set the second parameter of `Encode`: ```vb Json.Encode(, 2) 'Use 2-space indent Json.Encode(, 4) 'Use 4-space indent Json.Encode(, vbTab) 'Use Tab indent ``` ### Q10: How to handle special characters? **A:** cJson automatically handles special character escaping: ```vb Json.Item("text") = "Text with \"quotes\" and \\backslashes" 'Output: "text": "Text with \"quotes\" and \\backslashes" ``` ## File Operation Questions ### Q11: How to load JSON from a file? **A:** Use the `LoadFrom` method: ```vb 'Standard method With New cJson .LoadFrom "C:\data.json" MsgBox .Item("name") End With 'Chained calling MsgBox VBMAN.Json.LoadFrom("C:\data.json")("name") ``` ### Q12: How to save JSON to a file? **A:** Use the `SaveTo` method: ```vb Json.SaveTo "C:\data.json" 'Simple save Json.SaveTo "C:\data.json", "UTF-8" 'Specify encoding Json.SaveTo "C:\data.json", "UTF-8", 2, True 'Formatted and display Chinese ``` ### Q13: What character encodings are supported? **A:** Common character encodings are supported: * `UTF-8` (recommended) * `UTF-16` * `GB2312` * `GBK` * `ASCII` ## HTTP Related Questions ### Q14: How to send JSON data? **A:** Construct a JSON string and send it: ```vb 'Construct request body Dim Body As String With New cJson .Item("key") = "value" Body = .Encode() End With 'Send POST request With New cHttpClient .SetRequestContentType JsonString .SendPost "https://api.example.com", Body End With ``` ### Q15: How to parse JSON returned by an API? **A:** Use the `ReturnJson` method: ```vb With VBMAN.HttpClient.Fetch(ReqGet, "https://api.example.com").ReturnJson() 'Formatted display Text1.Text = .Encode(, 2, True) 'Extract data If .Item("code") = 200 Then MsgBox .Item("data")("name") End If End With ``` ### Q16: How to handle JSONP format? **A:** cJson's `Decode` method automatically handles JSONP format: ```vb 'The following formats can all be auto-parsed Json.Decode "callback({""name"":""John""});" Json.Decode "var data = {""name"":""John""};" Json.Decode "{""name"":""John""}" 'Standard JSON ``` ## Error Handling ### Q17: What are common errors? **A:** Common errors and solutions: | Error | Cause | Solution | | --------------- | ------------------------------ | ---------------------------- | | Index out of bounds | Accessing non-existent array index | Check array length before access | | Key not found | Accessing non-existent key | Use `Exists` method to check | | Type mismatch | Data type doesn't match variable | Use type conversion functions | | Parse failure | Invalid JSON format | Check input string format | ### Q18: How to debug JSON issues? **A:** Use these debugging techniques: ```vb '1. Formatted output to view structure Debug.Print Json.Encode(, 2, True) '2. Check error information Json.Decode BadJsonText If Not Json.LastSuccess Then Debug.Print "Error: " & Json.LastError End If '3. Check data type Debug.Print TypeName(Json.Item("field")) ``` ## Performance Questions ### Q19: Tips for handling large data volumes? **A:** 1. Use compact format for transmission: `Json.Encode()` (no formatting) 2. Avoid deep nested object lookups 3. Release unused objects promptly 4. Consider batch processing for large data volumes ### Q20: What's the difference between global and new instances? **A:** | Feature | VBMAN.Json (Global) | New cJson (New Instance) | | ------------- | ----------------------- | ------------------------ | | Lifecycle | Application lifetime | Released with code block end | | Data Sharing | Globally shared | Independent isolation | | Use Case | Cache global config | Temporary data processing | | Note | Need manual Clear | Auto cleanup | ## Advanced Questions ### Q21: How to construct JSON with array root node? **A:** First call `NewItem` or `NewItems`: ```vb With New cJson 'Root is an array With .NewItem() .Item("name") = "John" End With With .NewItem() .Item("name") = "Jane" End With 'Result: [{"name": "John"}, {"name": "Jane"}] Debug.Print .Encode(, 2, True) End With ``` ### Q22: How to merge two JSON objects? **A:** Manually copy key-value pairs: ```vb Private Sub MergeJson(Target As cJson, Source As cJson) Dim Key As Variant For Each Key In Source.RootItem.Keys Target.Item(Key) = Source.Item(Key) Next End Sub ``` ### Q23: How to copy a JSON object? **A:** Encode then decode: ```vb Dim Copy As New cJson Copy.Decode Original.Encode() ``` ### Q24: What's the difference between Root and Item? **A:** | Feature | Root | Item | | ------------- | ------------------------------- | -------------------- | | Default Member| Yes (can use `Json("key")`) | No | | Return Type | Object (Dictionary/Collection) | Variant | | Chained Access| Supported | Limited support | | Primary Use | **Reading data** | **Setting values** | | Example | `Json.Root("a")("b")` | `Json.Item("a") = 1` | **Recommended Usage:** ```vb 'Set values with Item Json.Item("name") = "John" 'Read values with Root MsgBox Json.Root("name") MsgBox Json.Root("address")("city") 'Chained access to nested object 'Shorthand form (using Root as default member) MsgBox Json("name") MsgBox Json("address")("city") ``` ### Q25: How to handle date types? **A:** Dates are converted to strings; it's recommended to format them: ```vb Json.Item("created") = Format(Now(), "yyyy-mm-dd HH:mm:ss") ``` --- --- url: /en/vbman/Json/quickstart.md --- # cJson Quick Start Guide ## 1. Add Reference Ensure your project has a reference to the `VBMAN` library added: ```vb 'Reference in code using the following methods Dim Json As New VBMANLIB.cJson 'Or directly use the VBMAN global instance With VBMAN.Json '... End With ``` ## 2. Creating JSON Objects ### 2.1 Creating Simple Key-Value Pair Objects ```vb Private Sub CreateSimpleJson() With New VBMANLIB.cJson 'Directly assign to create key-value pairs .Item("servicesn") = "0001" .Item("userid") = "admin" .Item("token") = "" .Item("argcounts") = 2 'Encode to JSON string Dim JsonString As String JsonString = .Encode(, 2, True) Debug.Print JsonString End With End Sub ``` Output: ```json { "servicesn": "0001", "userid": "admin", "token": "", "argcounts": 2 } ``` ### 2.2 Creating Nested Objects ```vb Private Sub CreateNestedJson() With New VBMANLIB.cJson .Item("name") = "John" .Item("age") = 25 'Create nested object (using NewItem) With .NewItem("address") .Item("city") = "Beijing" .Item("district") = "Haidian" End With Debug.Print .Encode(, 2, True) End With End Sub ``` Output: ```json { "name": "John", "age": 25, "address": { "city": "Beijing", "district": "Haidian" } } ``` ### 2.3 Creating Arrays ```vb Private Sub CreateArrayJson() With New VBMANLIB.cJson .Item("code") = 200 .Item("msg") = "Success" 'Create array (using NewItems) With .NewItems("data") 'Add array elements (using NewItem to create object elements) With .NewItem() .Item("id") = 1 .Item("name") = "Project 1" End With With .NewItem() .Item("id") = 2 .Item("name") = "Project 2" End With End With Debug.Print .Encode(, 2, True) End With End Sub ``` Output: ```json { "code": 200, "msg": "Success", "data": [ { "id": 1, "name": "Project 1" }, { "id": 2, "name": "Project 2" } ] } ``` ## 3. Parsing JSON Strings ### 3.1 Parsing Simple Objects (Using Root) ```vb Private Sub ParseSimpleJson() Dim JsonText As String JsonText = "{""name"":""John"",""age"":25,""city"":""Beijing""}" With New VBMANLIB.cJson .Decode JsonText 'Access using Root - recommended (returns Object, supports chained access) Debug.Print .Root("name") 'Output: John Debug.Print .Root("age") 'Output: 25 Debug.Print .Root("city") 'Output: Beijing 'Or use the default member feature (more concise) Debug.Print $("name") 'Output: John End With End Sub ``` ### 3.2 Parsing Nested Objects and Arrays (Using Root Chained Access) ```vb Private Sub ParseComplexJson() Dim JsonText As String JsonText = "{""code"":200,""data"":[{""id"":1,""name"":""Project 1""},{""id"":2,""name"":""Project 2""}]}" With New VBMANLIB.cJson .Decode JsonText 'Access top-level fields using Root Debug.Print .Root("code") 'Output: 200 'Use Root chained access for array elements (Note: index starts from 1) Debug.Print .Root("data")(1)("name") 'Output: Project 1 Debug.Print .Root("data")(2)("name") 'Output: Project 2 'Loop through array (using Root) Dim Item As Variant For Each Item In .Root("data") Debug.Print Item("id") & " - " & Item("name") Next End With End Sub ``` ## 4. File Operations ### 4.1 Saving JSON to a File ```vb Private Sub SaveJsonToFile() With VBMAN.Json .Item("name") = "Test data" .Item("version") = "1.0" 'Save to file (parameters: path, encoding, indent, display Chinese) .SaveTo "C:\tmp\data.json", "UTF-8", 2, True MsgBox "File saved" End With End Sub ``` ### 4.2 Loading JSON from a File ```vb Private Sub LoadJsonFromFile() With New VBMANLIB.cJson 'Load from file .LoadFrom "C:\tmp\data.json", "UTF-8" 'Use data (access using Root) MsgBox .Root("name") End With 'Or directly use (Root is default member) MsgBox VBMAN.Json.LoadFrom("C:\tmp\data.json")("name") End Sub ``` ## 5. Using with HTTP Requests ### 5.1 Sending JSON Data (POST Request) ```vb Private Sub PostJsonData() 'Construct request body Dim Body As String With New cJson .Item("sysStuffCode") = "TEST001" .Item("quantity") = 2 With .NewItems("detailList") Dim i As Long For i = 0 To 3 With .NewItem() .Item("test") = 123 .Item("time") = Now() End With Next End With Body = .Encode() End With 'Send request With New cHttpClient .RequestHeaders.Add "Content-Type", "application/json" Dim Response As String Response = .Fetch(ReqPost, "https://api.example.com/submit", Body).ReturnText() Debug.Print Response End With End Sub ``` ### 5.2 Parsing Returned JSON Data ```vb Private Sub ParseApiResponse() With VBMAN.HttpClient.Fetch(ReqGet, "https://api.example.com/data").ReturnJson() 'Format and display returned content Text1.Text = .Encode(, 2, True) 'Extract data If .Item("code") = 200 Then Dim Item As Variant For Each Item In .Item("data") List1.AddItem Item("name") Next Else MsgBox .Item("message") End If End With End Sub ``` ## 6. Common Error Handling ```vb Private Sub SafeJsonOperation() On Error GoTo ErrorHandler Dim Json As New cJson 'Parse potentially malformed JSON Json.Decode Text1.Text 'Check if parsing was successful If Json.LastSuccess Then MsgBox "Parse successful: " & Json.Item("name") Else MsgBox "Parse failed: " & Json.LastError End If Exit Sub ErrorHandler: MsgBox "Operation error: " & Err.Description End Sub ``` ## Next Steps * Check [API Reference](./api-reference.md) for complete properties and methods * Check [Code Examples](./examples.md) for more usage scenarios --- --- url: /zh/vbman/logs/methods.md --- # cLogs 方法参考 ## 📝 日志记录方法 ### Data 记录日志内容（默认属性，支持链式调用）。 ```vb Public Function Data(ByVal LogContent As String, Optional ByVal LogTitle As String, Optional LogLevel As EnumLogLevel = LvInfo) As cLogs ``` **参数**: * `LogContent` - 日志内容 * `LogTitle` - 日志标题（可选） * `LogLevel` - 日志级别（默认 LvInfo） **返回**: 返回自身实例，支持链式调用 **示例**: ```vb Dim Log As New cLogs ' 基础用法 Log.Data "系统启动" ' 带标题 Log.Data "连接成功", "数据库" ' 指定级别 Log.Data "内存不足", "系统", LvWarn ' 链式调用 Log.Data("第一条").Data("第二条").Data("第三条") ``` *** ### DataLine 记录带换行的日志内容。 ```vb Public Function DataLine(ByVal LogContent As String, Optional ByVal LogTitle As String, Optional LogLevel As EnumLogLevel = LvInfo) As cLogs ``` **说明**: 自动在内容末尾添加换行符 `vbCrLf` **示例**: ```vb Log.DataLine "错误详情:" Log.DataLine " 文件: Form1.frm" Log.DataLine " 行号: 156" Log.Save ``` *** ### Save 将缓存的日志写入文件。 ```vb Public Function Save() As cLogs ``` **说明**: * 将 `CacheDatas` 中缓存的所有日志写入文件 * 根据 `LogFileNameRule` 决定文件名 * 自动创建目录结构 * 清空缓存 **示例**: ```vb ' 批量记录后一次性保存 Log.Data "事件1" Log.Data "事件2" Log.Data "事件3" Log.Save ' 链式写法 Log.Data("事件1").Data("事件2").Data("事件3").Save ``` *** ## 🔄 通道输出方法 ### ToFormView 输出到窗体 ListBox 控件。 ```vb Public Function ToFormView(LogStr As String, Optional LogLevel As EnumLogLevel) As String ``` **前置条件**: 需设置 `FormListBox` 属性 **示例**: ```vb ' 设置目标 ListBox Set Log.FormListBox = Form1.List1 Log.FormListBoxMaxItem = 500 ' 最大保留条目数 ' 输出日志 Log.ToFormView "实时消息" ' 或在 Data 后自动触发（如果 SendToFormView=True） Log.SendToFormView = True Log.Data "自动输出到 ListBox" ``` *** ### ToDbgView 输出到 DbgView 工具。 ```vb Public Function ToDbgView(LogStr As String, Optional LogLevel As EnumLogLevel) As String ``` **说明**: 使用 Windows API `OutputDebugString` 输出 **DbgView 过滤设置**: ``` Include: VBMAN LOG DATA* ``` **示例**: ```vb Log.SendToDbgView = True Log.Data "调试信息", "DEBUG", LvDebugger ' DbgView 中会显示: VBMAN LOG DATA：::[时间] [DEBUGGER] DEBUG 调试信息 ``` *** ### ToWebView 输出到网页远程调试。 ```vb Public Function ToWebView(LogStr As String, Optional LogLevel As EnumLogLevel) As String ``` **前置条件**: 需设置 `WebUserCode` **使用步骤**: 1. 访问 http://log.vb6.pro 获取用户码 2. 设置 `Log.WebUserCode = "your-code"` 3. 开启 `Log.SendToWebView = True` 4. 在网页实时查看日志 **示例**: ```vb Log.WebUserCode = "abc123" Log.SendToWebView = True Log.Data "远程调试信息" ``` *** ## 🎛️ 控制方法 ### View 控制日志查看器窗口显示/隐藏（链式）。 ```vb Public Function View(Value As Boolean) As cLogs ``` **示例**: ```vb Log.View(True).Data("显示窗口并记录").Save ``` *** ### HostApp 设置宿主应用程序对象（链式）。 ```vb Public Function HostApp(o As Object) As cLogs ``` **说明**: 用于获取程序路径，默认自动设置为 `App` 对象 **示例**: ```vb Log.HostApp(App).Data("记录").Save ``` *** ## 📊 日志级别 ### EnumLogLevel 枚举 | 级别 | 值 | 常量 | 说明 | |------|----|------|------| | LvInfo | 0 | INFO | 普通信息 | | LvWarn | 1 | WARN | 警告信息 | | LvDanger | 2 | DANGER | 危险信息 | | LvError | 3 | ERROR | 错误信息 | | LvDebugger | 4 | DEBUGGER | 调试信息 | | LvCustom | 5 | CUSTOM | 自定义级别 | ### 日志级别控制 ```vb Dim Log As New cLogs ' 设置控制级别（只记录 WARN 及以上） Log.LogLevelControl = LvWarn Log.Data "普通信息", , LvInfo ' 被忽略（0 < 1） Log.Data "警告信息", , LvWarn ' 被记录（1 >= 1） Log.Data "错误信息", , LvError ' 被记录（3 >= 1） Log.Save ``` *** **最后更新**: 2026-05-17 --- --- url: /zh/vbman/logs/overview.md --- # cLogs 日志组件概述 ## 简介 `cLogs` 是一个功能丰富的日志记录组件，支持多通道输出、日志级别控制、批量缓存写入。适用于调试、运行监控、错误追踪等场景。 ## 特性 | 特性 | 说明 | |------|------| | **多通道输出** | 文件、窗体、DbgView、网页远程调试 | | **日志级别** | INFO/WARN/DANGER/ERROR/DEBUGGER 五级控制 | | **批量缓存** | 先缓存后批量写入，提高性能 | | **链式调用** | 流畅的 API 设计 | | **灵活配置** | 支持按日/按月分文件，自定义目录结构 | | **远程调试** | 支持实时推送日志到网页查看 | ## 输出通道 ``` ┌─────────────────────────────────────────────────────────────┐ │ cLogs │ │ ┌───────────┐ ┌───────────┐ ┌───────────┐ ┌───────────┐│ │ │ 文件日志 │ │ 窗体显示 │ │ DbgView │ │ 网页远程 ││ │ │ Save() │ │ FormView │ │ ToDbgView │ │ ToWebView ││ │ └───────────┘ └───────────┘ └───────────┘ └───────────┘│ └─────────────────────────────────────────────────────────────┘ ``` ## 快速开始 ### 基础用法 ```vb Dim Log As New cLogs ' 简单记录 Log.Data "应用程序启动" Log.Save ' 带标题和级别 Log.Data "连接成功", "数据库", LvInfo Log.Save ' 链式调用 Log.Data("用户登录").DataLine("用户名: admin").Save ``` ### 多通道同时输出 ```vb Dim Log As New cLogs ' 设置 Web 调试码（从 http://log.vb6.pro 获取） Log.WebUserCode = "your-code-123" ' 开启所有通道 Log.SendToFormView = True ' 输出到 ListBox Log.SendToDbgView = True ' 输出到 DbgView Log.SendToWebView = True ' 输出到网页 ' 记录日志（自动输出到所有开启的通道） Log.Data "系统事件", "INFO", LvInfo Log.Save ' 保存到文件 ``` ### 配置日志文件 ```vb Dim Log As New cLogs ' 设置日志目录 Log.LogDir = "C:\MyApp\Logs" ' 设置子目录（用于区分模块） Log.LogSubDir = "database" ' 设置文件名规则 Log.LogFileNameRule = ByDay ' 按天分割：2026\01\20260115.txt ' Log.LogFileNameRule = ByMonth ' 按月分割：2026\202601.txt ' 记录日志 Log.Data "查询数据" Log.Save ``` ### 使用日志查看器 ```vb Dim Log As New cLogs ' 显示内置日志查看器窗口 Log.ShowLogsViewer = True ' 或使用链式方法 Log.View(True).Data("日志内容").Save ' 关闭查看器 Log.ShowLogsViewer = False ``` ## 日志文件结构 ``` ' 按天分割 (ByDay) logs/ └── system/ └── 2026/ └── 01/ ├── 20260115.txt └── 20260116.txt ' 按月分割 (ByMonth) logs/ └── system/ └── 2026/ ├── 202601.txt └── 202602.txt ``` ## 日志格式 ``` ::[2026/1/15 10:30:45] [INFO] 数据库 连接成功 ::[2026/1/15 10:31:12] [WARN] 网络 连接超时，正在重试... ``` ## 引用组件 * `FLogs.frm` - 日志查看器窗体（可选） * `ToolsLogs.bas` - 日志级别常量 *** **最后更新**: 2026-05-17 --- --- url: /zh/vbman/logs/properties.md --- # cLogs 属性参考 ## 📁 文件配置属性 ### LogDir 日志文件根目录。 ```vb Public LogDir As String ``` **默认值**: 空字符串（使用程序所在目录） **示例**: ```vb ' 使用程序目录下的 logs 文件夹（默认） Log.LogDir = "" ' 指定绝对路径 Log.LogDir = "C:\MyApp\Logs" ' 使用应用数据目录 Log.LogDir = Environ("APPDATA") & "\MyApp\Logs" ``` *** ### LogSubDir 日志子目录，用于区分业务模块。 ```vb Public LogSubDir As String ``` **默认值**: `"system"` **示例**: ```vb ' 数据库模块日志 Log.LogSubDir = "database" ' 输出到: logs/database/... ' 网络模块日志 Log.LogSubDir = "network" ' 输出到: logs/network/... ' 用户操作日志 Log.LogSubDir = "user" ' 输出到: logs/user/... ``` *** ### LogFileNameRule 日志文件命名规则。 ```vb Public LogFileNameRule As EnumLogFileNameRule ``` **枚举值**: | 值 | 常量 | 说明 | 示例路径 | |----|------|------|----------| | 0 | None | 使用用户定义名 | `logs/system/vb.txt` | | 1 | ByMonth | 按月分割 | `logs/system/2026/202601.txt` | | 2 | ByDay | 按日分割 | `logs/system/2026/01/20260115.txt` | | 3 | byUser | 完全用户定义 | 使用 `LogFileNameByUer` | **示例**: ```vb ' 按天分割（推荐，文件大小适中） Log.LogFileNameRule = ByDay ' 按月分割（日志量小） Log.LogFileNameRule = ByMonth ' 自定义文件名 Log.LogFileNameRule = byUser Log.LogFileNameByUer = "custom\mylog.txt" ``` *** ### LogFileNameByUer 用户自定义日志文件名（完整相对路径）。 ```vb Public LogFileNameByUer As String ``` **说明**: 当 `LogFileNameRule = byUser` 或 `None` 时使用 **示例**: ```vb Log.LogFileNameRule = byUser Log.LogFileNameByUer = "custom\app.log" ' 输出到: logs/custom/app.log Log.LogFileNameByUer = "2026\january\debug.txt" ' 输出到: logs/2026/january/debug.txt ``` *** ## 📡 通道开关属性 ### SendToFormView 是否输出到窗体 ListBox。 ```vb Public SendToFormView As Boolean ``` **配套属性**: * `FormListBox` - 目标 ListBox 对象 * `FormListBoxMaxItem` - 最大保留条目数 **示例**: ```vb Set Log.FormListBox = Form1.List1 Log.FormListBoxMaxItem = 1000 Log.SendToFormView = True Log.Data "这条会显示在 List1 中" ``` *** ### SendToDbgView 是否输出到 DbgView。 ```vb Public SendToDbgView As Boolean ``` **示例**: ```vb Log.SendToDbgView = True Log.Data "调试信息", "DEBUG" ' DbgView 中可见 ``` *** ### SendToWebView 是否输出到网页远程调试。 ```vb Public SendToWebView As Boolean ``` **配套属性**: `WebUserCode` **示例**: ```vb Log.WebUserCode = "abc123" Log.SendToWebView = True Log.Data "远程日志" ``` *** ## 🎚️ 日志控制属性 ### LogLevelControl 日志级别控制阈值。 ```vb Public LogLevelControl As EnumLogLevel ``` **说明**: 只记录大于等于此级别的日志 **示例**: ```vb ' 生产环境：只记录警告及以上 Log.LogLevelControl = LvWarn ' 调试环境：记录所有 Log.LogLevelControl = LvInfo ' 错误追踪：只记录错误 Log.LogLevelControl = LvError ``` *** ## 🖥️ 窗体相关属性 ### FormListBox 目标 ListBox 控件。 ```vb Public FormListBox As VB.ListBox ``` **示例**: ```vb ' 绑定到窗体上的 ListBox Set Log.FormListBox = Form1.List1 ' 或主窗体的列表 Set Log.FormListBox = MainForm.LogList ``` *** ### FormListBoxMaxItem ListBox 最大保留条目数。 ```vb Public FormListBoxMaxItem As Long ``` **默认值**: 999 **说明**: 超过此数量时自动移除最旧的条目 **示例**: ```vb Log.FormListBoxMaxItem = 500 ' 保留最近 500 条 Log.FormListBoxMaxItem = 100 ' 保留最近 100 条 ``` *** ### ShowLogsViewer 显示/隐藏内置日志查看器窗口。 ```vb Public Property Get ShowLogsViewer() As Boolean Public Property Let ShowLogsViewer(Value As Boolean) ``` **示例**: ```vb ' 显示日志窗口 Log.ShowLogsViewer = True ' 隐藏日志窗口 Log.ShowLogsViewer = False ' 切换显示状态 Log.ShowLogsViewer = Not Log.ShowLogsViewer ``` *** ## 🌐 远程调试属性 ### WebUserCode 网页远程调试用户识别码。 ```vb Public WebUserCode As String ``` **获取方式**: 1. 访问 http://log.vb6.pro 2. 获取随机字符串或设置自己的识别码 3. 填入此属性 **示例**: ```vb Log.WebUserCode = "myapp-123" Log.WebUserCode = "550e8400-e29b-41d4-a716-446655440000" ``` *** ## 🔧 其他属性 ### CacheDatas 日志缓存集合（只读）。 ```vb Public CacheDatas As New Collection ``` **说明**: 调用 `Save()` 时写入文件并清空 *** ### DebugPring 调试打印开关。 ```vb Public DebugPring As Boolean ``` **说明**: 在 IDE 中输出到立即窗口 *** ## 完整配置示例 ```vb Dim Log As New cLogs ' ========== 文件配置 ========== Log.LogDir = Environ("APPDATA") & "\MyApp\Logs" Log.LogSubDir = "database" Log.LogFileNameRule = ByDay ' ========== 窗体输出配置 ========== Set Log.FormListBox = MainForm.ListLog Log.FormListBoxMaxItem = 1000 Log.SendToFormView = True ' ========== 远程调试配置 ========== Log.WebUserCode = "myapp-debug-001" Log.SendToWebView = True ' ========== 级别控制 ========== Log.LogLevelControl = LvInfo ' 记录所有级别 ' ========== 记录日志 ========== Log.Data "应用程序启动", "SYSTEM", LvInfo Log.DataLine("日志系统初始化完成") Log.Save ``` *** **最后更新**: 2026-05-17 --- --- url: /en/vbman/logs/overview.md --- # cLogs Component Overview ## Introduction `cLogs` is a feature-rich logging component that supports multiple output channels, log level control, and batch cached writing. Suitable for debugging, runtime monitoring, error tracking, and more. ## Features | Feature | Description | |---------|-------------| | **Multi-channel Output** | File, Form, DbgView, Web remote debugging | | **Log Levels** | INFO/WARN/DANGER/ERROR/DEBUGGER five-level control | | **Batch Cache** | Cache first, then batch write for better performance | | **Chainable API** | Fluent API design | | **Flexible Config** | Daily/monthly file splitting, custom directory structure | | **Remote Debugging** | Real-time log push to web viewer | ## Output Channels ``` ┌─────────────────────────────────────────────────────────────┐ │ cLogs │ │ ┌───────────┐ ┌───────────┐ ┌───────────┐ ┌───────────┐│ │ │ File Log │ │ Form View │ │ DbgView │ │ Web View ││ │ │ Save() │ │ FormView │ │ ToDbgView │ │ ToWebView ││ │ └───────────┘ └───────────┘ └───────────┘ └───────────┘│ └─────────────────────────────────────────────────────────────┘ ``` ## Quick Start ### Basic Usage ```vb Dim Log As New cLogs ' Simple logging Log.Data "Application started" Log.Save ' With title and level Log.Data "Connection successful", "Database", LvInfo Log.Save ' Chainable call Log.Data("User login").DataLine("Username: admin").Save ``` ### Multiple Channels Output Simultaneously ```vb Dim Log As New cLogs ' Set Web debug code (get from http://log.vb6.pro) Log.WebUserCode = "your-code-123" ' Enable all channels Log.SendToFormView = True ' Output to ListBox Log.SendToDbgView = True ' Output to DbgView Log.SendToWebView = True ' Output to Web ' Log (auto outputs to all enabled channels) Log.Data "System event", "INFO", LvInfo Log.Save ' Save to file ``` ### Configure Log File ```vb Dim Log As New cLogs ' Set log directory Log.LogDir = "C:\MyApp\Logs" ' Set subdirectory (for module differentiation) Log.LogSubDir = "database" ' Set filename rule Log.LogFileNameRule = ByDay ' Daily split: 2026\01\20260115.txt ' Log.LogFileNameRule = ByMonth ' Monthly split: 2026\202601.txt ' Log Log.Data "Query data" Log.Save ``` ### Using Log Viewer ```vb Dim Log As New cLogs ' Show built-in log viewer window Log.ShowLogsViewer = True ' Or use chainable method Log.View(True).Data("Log content").Save ' Close viewer Log.ShowLogsViewer = False ``` ## Log File Structure ``` ' Daily split (ByDay) logs/ └── system/ └── 2026/ └── 01/ ├── 20260115.txt └── 20260116.txt ' Monthly split (ByMonth) logs/ └── system/ └── 2026/ ├── 202601.txt └── 202602.txt ``` ## Log Format ``` ::[2026/1/15 10:30:45] [INFO] Database Connection successful ::[2026/1/15 10:31:12] [WARN] Network Connection timeout, retrying... ``` ## References * `FLogs.frm` - Log viewer form (optional) * `ToolsLogs.bas` - Log level constants *** **Last Updated**: 2026-05-17 --- --- url: /en/vbman/logs/methods.md --- # cLogs Methods Reference ## 📝 Logging Methods ### Data Logs content (default property, supports chainable calls). ```vb Public Function Data(ByVal LogContent As String, Optional ByVal LogTitle As String, Optional LogLevel As EnumLogLevel = LvInfo) As cLogs ``` **Parameters:** * `LogContent` - Log content * `LogTitle` - Log title (optional) * `LogLevel` - Log level (default LvInfo) **Returns:** Returns self instance for chainable calls **Example:** ```vb Dim Log As New cLogs ' Basic usage Log.Data "System started" ' With title Log.Data "Connection successful", "Database" ' Specify level Log.Data "Memory low", "System", LvWarn ' Chainable call Log.Data("First").Data("Second").Data("Third") ``` *** ### DataLine Logs content with line break. ```vb Public Function DataLine(ByVal LogContent As String, Optional ByVal LogTitle As String, Optional LogLevel As EnumLogLevel = LvInfo) As cLogs ``` **Description:** Auto adds line break `vbCrLf` at end of content **Example:** ```vb Log.DataLine "Error details:" Log.DataLine " File: Form1.frm" Log.DataLine " Line: 156" Log.Save ``` *** ### Save Writes cached logs to file. ```vb Public Function Save() As cLogs ``` **Description:** * Writes all cached logs from `CacheDatas` to file * Decides filename based on `LogFileNameRule` * Auto creates directory structure * Clears cache **Example:** ```vb ' Batch log then save once Log.Data "Event 1" Log.Data "Event 2" Log.Data "Event 3" Log.Save ' Chainable写法 Log.Data("Event 1").Data("Event 2").Data("Event 3").Save ``` *** ## 🔄 Channel Output Methods ### ToFormView Outputs to form ListBox control. ```vb Public Function ToFormView(LogStr As String, Optional LogLevel As EnumLogLevel) As String ``` **Prerequisite:** Must set `FormListBox` property **Example:** ```vb ' Set target ListBox Set Log.FormListBox = Form1.List1 Log.FormListBoxMaxItem = 500 ' Max items to keep ' Output log Log.ToFormView "Real-time message" ' Or auto trigger after Data (if SendToFormView=True) Log.SendToFormView = True Log.Data "Auto output to ListBox" ``` *** ### ToDbgView Outputs to DbgView tool. ```vb Public Function ToDbgView(LogStr As String, Optional LogLevel As EnumLogLevel) As String ``` **Description:** Uses Windows API `OutputDebugString` to output **DbgView Filter Settings:** ``` Include: VBMAN LOG DATA* ``` **Example:** ```vb Log.SendToDbgView = True Log.Data "Debug info", "DEBUG", LvDebugger ' DbgView shows: VBMAN LOG DATA：::[time] [DEBUGGER] DEBUG Debug info ``` *** ### ToWebView Outputs to web remote debugging. ```vb Public Function ToWebView(LogStr As String, Optional LogLevel As EnumLogLevel) As String ``` **Prerequisite:** Must set `WebUserCode` **Usage Steps:** 1. Visit http://log.vb6.pro to get user code 2. Set `Log.WebUserCode = "your-code"` 3. Enable `Log.SendToWebView = True` 4. View logs in real-time on web **Example:** ```vb Log.WebUserCode = "abc123" Log.SendToWebView = True Log.Data "Remote debug info" ``` *** ## 🎛️ Control Methods ### View Controls log viewer window show/hide (chainable). ```vb Public Function View(Value As Boolean) As cLogs ``` **Example:** ```vb Log.View(True).Data("Show window and log").Save ``` *** ### HostApp Sets host application object (chainable). ```vb Public Function HostApp(o As Object) As cLogs ``` **Description:** Used to get program path, defaults to auto-set `App` object **Example:** ```vb Log.HostApp(App).Data("Log").Save ``` *** ## 📊 Log Levels ### EnumLogLevel Enum | Level | Value | Constant | Description | |-------|-------|----------|-------------| | LvInfo | 0 | INFO | General info | | LvWarn | 1 | WARN | Warning info | | LvDanger | 2 | DANGER | Danger info | | LvError | 3 | ERROR | Error info | | LvDebugger | 4 | DEBUGGER | Debug info | | LvCustom | 5 | CUSTOM | Custom level | ### Log Level Control ```vb Dim Log As New cLogs ' Set control level (only log WARN and above) Log.LogLevelControl = LvWarn Log.Data "General info", , LvInfo ' Ignored (0 < 1) Log.Data "Warning info", , LvWarn ' Logged (1 >= 1) Log.Data "Error info", , LvError ' Logged (3 >= 1) Log.Save ``` *** **Last Updated**: 2026-05-17 --- --- url: /en/vbman/logs/properties.md --- # cLogs Property Reference ## File Configuration Properties ### LogDir Root directory for log files. ```vb Public LogDir As String ``` **Default**: Empty string (uses program directory) **Example**: ```vb ' Use logs folder under program directory (default) Log.LogDir = "" ' Specify absolute path Log.LogDir = "C:\MyApp\Logs" ' Use AppData directory Log.LogDir = Environ("APPDATA") & "\MyApp\Logs" ``` *** ### LogSubDir Log subdirectory for distinguishing business modules. ```vb Public LogSubDir As String ``` **Default**: `"system"` **Example**: ```vb ' Database module logs Log.LogSubDir = "database" ' Output to: logs/database/... ' Network module logs Log.LogSubDir = "network" ' Output to: logs/network/... ' User operation logs Log.LogSubDir = "user" ' Output to: logs/user/... ``` *** ### LogFileNameRule Log file naming rule. ```vb Public LogFileNameRule As EnumLogFileNameRule ``` **Enum Values**: | Value | Constant | Description | Example Path | |-------|----------|-------------|--------------| | 0 | None | Use user-defined name | `logs/system/vb.txt` | | 1 | ByMonth | Split by month | `logs/system/2026/202601.txt` | | 2 | ByDay | Split by day | `logs/system/2026/01/20260115.txt` | | 3 | byUser | Fully user-defined | Uses `LogFileNameByUer` | **Example**: ```vb ' Split by day (recommended, file size moderate) Log.LogFileNameRule = ByDay ' Split by month (small log volume) Log.LogFileNameRule = ByMonth ' Custom file name Log.LogFileNameRule = byUser Log.LogFileNameByUer = "custom\mylog.txt" ``` *** ### LogFileNameByUer User-defined log file name (complete relative path). ```vb Public LogFileNameByUer As String ``` **Description**: Used when `LogFileNameRule = byUser` or `None` **Example**: ```vb Log.LogFileNameRule = byUser Log.LogFileNameByUer = "custom\app.log" ' Output to: logs/custom/app.log Log.LogFileNameByUer = "2026\january\debug.txt" ' Output to: logs/2026/january/debug.txt ``` *** ## Channel Switch Properties ### SendToFormView Whether to output to form ListBox. ```vb Public SendToFormView As Boolean ``` **Related properties**: * `FormListBox` - Target ListBox object * `FormListBoxMaxItem` - Maximum kept items **Example**: ```vb Set Log.FormListBox = Form1.List1 Log.FormListBoxMaxItem = 1000 Log.SendToFormView = True Log.Data "This will appear in List1" ``` *** ### SendToDbgView Whether to output to DbgView. ```vb Public SendToDbgView As Boolean ``` **Example**: ```vb Log.SendToDbgView = True Log.Data "Debug info", "DEBUG" ' Visible in DbgView ``` *** ### SendToWebView Whether to output to web remote debugging. ```vb Public SendToWebView As Boolean ``` **Related property**: `WebUserCode` **Example**: ```vb Log.WebUserCode = "abc123" Log.SendToWebView = True Log.Data "Remote log" ``` *** ## Log Control Properties ### LogLevelControl Log level control threshold. ```vb Public LogLevelControl As EnumLogLevel ``` **Description**: Only logs entries greater than or equal to this level are recorded **Example**: ```vb ' Production: Only log warnings and above Log.LogLevelControl = LvWarn ' Debug: Log everything Log.LogLevelControl = LvInfo ' Error tracking: Only log errors Log.LogLevelControl = LvError ``` *** ## Form-Related Properties ### FormListBox Target ListBox control. ```vb Public FormListBox As VB.ListBox ``` **Example**: ```vb ' Bind to ListBox on form Set Log.FormListBox = Form1.List1 ' Or main form's list Set Log.FormListBox = MainForm.LogList ``` *** ### FormListBoxMaxItem Maximum kept items in ListBox. ```vb Public FormListBoxMaxItem As Long ``` **Default**: 999 **Description**: Automatically removes oldest entries when exceeding this count **Example**: ```vb Log.FormListBoxMaxItem = 500 ' Keep last 500 entries Log.FormListBoxMaxItem = 100 ' Keep last 100 entries ``` *** ### ShowLogsViewer Show/hide built-in log viewer window. ```vb Public Property Get ShowLogsViewer() As Boolean Public Property Let ShowLogsViewer(Value As Boolean) ``` **Example**: ```vb ' Show log window Log.ShowLogsViewer = True ' Hide log window Log.ShowLogsViewer = False ' Toggle visibility Log.ShowLogsViewer = Not Log.ShowLogsViewer ``` *** ## Remote Debugging Properties ### WebUserCode Web remote debugging user identification code. ```vb Public WebUserCode As String ``` **How to get**: 1. Visit http://log.vb6.pro 2. Get random string or set your own identification code 3. Fill in this property **Example**: ```vb Log.WebUserCode = "myapp-123" Log.WebUserCode = "550e8400-e29b-41d4-a716-446655440000" ``` *** ## Other Properties ### CacheDatas Log cache collection (read-only). ```vb Public CacheDatas As New Collection ``` **Description**: Written to file and cleared when `Save()` is called *** ### DebugPring Debug print switch. ```vb Public DebugPring As Boolean ``` **Description**: Output to Immediate window in IDE *** ## Complete Configuration Example ```vb Dim Log As New cLogs ' ========== File Configuration ========== Log.LogDir = Environ("APPDATA") & "\MyApp\Logs" Log.LogSubDir = "database" Log.LogFileNameRule = ByDay ' ========== Form Output Configuration ========== Set Log.FormListBox = MainForm.ListLog Log.FormListBoxMaxItem = 1000 Log.SendToFormView = True ' ========== Remote Debug Configuration ========== Log.WebUserCode = "myapp-debug-001" Log.SendToWebView = True ' ========== Level Control ========== Log.LogLevelControl = LvInfo ' Log all levels ' ========== Log Entries ========== Log.Data "Application started", "SYSTEM", LvInfo Log.DataLine("Log system initialization complete") Log.Save ``` *** **Last Updated**: 2026-05-17 --- --- url: /zh/vbman/modbus/master.md --- # cModbusMaster 类参考 ## ? 类概述 `cModbusMaster` 是 Modbus 主站（客户端）实现类，提供连接到 Modbus 从站、发送/接收数据、自动处理协议帧等功能。 *** ## ? 事件列表 | 事件名 | 触发时机 | 参数 | | ---------------- | ------------------ | ------------------------ | | `OnConnect` | 连接成功建立 | 无 | | `OnDisconnect` | 连接已关闭 | 无 | | `OnError` | 发生错误 | `Description` (错误描述) | | `OnDataReceived` | 收到数据（调试用） | `Data()` (字节数组) | *** ## ? 属性参考 ### ProtocolType - 协议类型 **类型**: `ModbusMasterProtocolType` (枚举)\ **读写**: 读写 **值**: | 常量 | 值 | 说明 | | ------------------------ | --- | -------------------- | | `MB_MASTER_PROTOCOL_RTU` | 1 | RTU 模式（串口通信） | | `MB_MASTER_PROTOCOL_TCP` | 2 | TCP 模式（网络通信） | **示例**: ```vb ' 设置为 TCP 模式 mbMaster.ProtocolType = MB_MASTER_PROTOCOL_TCP ' 设置为 RTU 模式 mbMaster.ProtocolType = MB_MASTER_PROTOCOL_RTU ``` *** ### State - 连接状态 **类型**: `ModbusMasterState` (枚举)\ **读写**: 只读 **值**: | 常量 | 值 | 说明 | | ------------------------------ | --- | -------- | | `MB_MASTER_STATE_DISCONNECTED` | 0 | 已断开 | | `MB_MASTER_STATE_CONNECTING` | 1 | 正在连接 | | `MB_MASTER_STATE_CONNECTED` | 2 | 已连接 | | `MB_MASTER_STATE_ERROR` | 3 | 错误状态 | **示例**: ```vb If mbMaster.State = MB_MASTER_STATE_CONNECTED Then Debug.Print "已连接" Else Debug.Print "未连接" End If ``` *** ### SlaveID - 从站 ID **类型**: `Byte`\ **读写**: 读写 **说明**: 目标从站的设备地址（1-247）。0 表示广播地址。 **示例**: ```vb ' 设置从站 ID 为 1 mbMaster.SlaveID = 1 ' 广播到所有从站 mbMaster.SlaveID = 0 ``` *** ### ResponseTimeout - 响应超时 **类型**: `Long`\ **读写**: 读写 **说明**: 等待从站响应的超时时间（毫秒）。默认为 1000ms。 **示例**: ```vb ' 设置超时为 3 秒 mbMaster.ResponseTimeout = 3000 ' 恢复默认值 mbMaster.ResponseTimeout = 1000 ``` *** ### Defaults - 默认常量 **类型**: `ModbusMasterDefaults` (结构体)\ **读写**: 只读 **字段**: | 字段 | 类型 | 说明 | | ---------------------- | ------ | --------------------- | | `TCP_PORT` | Long | 默认 TCP 端口（502） | | `RTU_DEFAULT_BAUDRATE` | Long | 默认波特率（9600） | | `RTU_DEFAULT_DATABITS` | Long | 默认数据位（8） | | `RTU_DEFAULT_PARITY` | String | 默认校验位（"N"） | | `RTU_DEFAULT_STOPBITS` | Long | 默认停止位（1） | | `RTU_DEFAULT_TIMEOUT` | Long | 默认超时（1000ms） | | `MAX_PDU_SIZE` | Long | 最大 PDU 大小（253） | | `MAX_REGISTERS` | Long | 最大寄存器数量（125） | | `MAX_COILS` | Long | 最大线圈数量（2000） | | `TCP_MBAP_SIZE` | Long | MBAP 头大小（7） | **示例**: ```vb Debug.Print "默认端口: " & mbMaster.Defaults.TCP_PORT Debug.Print "最大寄存器: " & mbMaster.Defaults.MAX_REGISTERS ``` *** ### RTU 模式属性 #### SerialPort - 串口名称 **类型**: `String`\ **读写**: 读写 **示例**: ```vb mbMaster.SerialPort = "COM1" ``` #### BaudRate - 波特率 **类型**: `Long`\ **读写**: 读写 **示例**: ```vb mbMaster.BaudRate = 9600 ``` #### DataBits - 数据位 **类型**: `Long`\ **读写**: 读写 **示例**: ```vb mbMaster.DataBits = 8 ``` #### Parity - 校验位 **类型**: `String`\ **读写**: 读写 **值**: "N" (无), "E" (偶校验), "O" (奇校验) **示例**: ```vb mbMaster.Parity = "N" ' 无校验 mbMaster.Parity = "E" ' 偶校验 mbMaster.Parity = "O" ' 奇校验 ``` #### StopBits - 停止位 **类型**: `Long`\ **读写**: 读写 **示例**: ```vb mbMaster.StopBits = 1 ' 1 个停止位 mbMaster.StopBits = 2 ' 2 个停止位 ``` *** ### TCP 模式属性 #### TCPHost - TCP 主机地址 **类型**: `String`\ **读写**: 读写 **示例**: ```vb mbMaster.TCPHost = "192.168.1.100" mbMaster.TCPHost = "127.0.0.1" ``` #### TCPPort - TCP 端口 **类型**: `Long`\ **读写**: 读写 **示例**: ```vb mbMaster.TCPPort = 502 ' Modbus 默认端口 ``` *** ## ? 方法参考 ### Connect - 连接从站 **语法**: ```vb Public Sub Connect(Optional ByVal SerialPort As String = "", _ Optional ByVal TCPHost As String = "", _ Optional ByVal TCPPort As Long = 0) ``` **参数**: | 参数 | 类型 | 说明 | | ------------ | -------------- | ----------------------------------- | | `SerialPort` | String (可选） | RTU 模式：串口名称（COM1, COM2...） | | `TCPHost` | String (可选） | TCP 模式：主机地址或 IP | | `TCPPort` | Long (可选） | TCP 模式：端口号 | **示例**: ```vb ' TCP 连接 mbMaster.ProtocolType = MB_MASTER_PROTOCOL_TCP mbMaster.TCPHost = "192.168.1.100" mbMaster.TCPPort = 502 mbMaster.SlaveID = 1 mbMaster.Connect ' RTU 连接 mbMaster.ProtocolType = MB_MASTER_PROTOCOL_RTU mbMaster.SerialPort = "COM1" mbMaster.BaudRate = 9600 mbMaster.DataBits = 8 mbMaster.Parity = "N" mbMaster.StopBits = 1 mbMaster.SlaveID = 1 mbMaster.Connect "COM1" ``` *** ### Disconnect - 断开连接 **语法**: ```vb Public Sub Disconnect() ``` **示例**: ```vb mbMaster.Disconnect ``` *** ### ReadCoils - 读取线圈 (0x01) **语法**: ```vb Public Function ReadCoils(ByVal StartAddress As Long, ByVal Quantity As Long) As Boolean() ``` **参数**: | 参数 | 类型 | 说明 | | -------------- | ---- | -------------------------- | | `StartAddress` | Long | 起始线圈地址（0-based） | | `Quantity` | Long | 要读取的线圈数量（1-2000） | **返回值**: `Boolean()` - 线圈值数组 **示例**: ```vb Dim baCoils() As Boolean baCoils = mbMaster.ReadCoils(0, 10) Dim i As Long For i = 0 To UBound(baCoils) Debug.Print "Coil[" & i & "] = " & baCoils(i) Next i ``` *** ### ReadDiscreteInputs - 读取离散输入 (0x02) **语法**: ```vb Public Function ReadDiscreteInputs(ByVal StartAddress As Long, ByVal Quantity As Long) As Boolean() ``` **参数**: | 参数 | 类型 | 说明 | | -------------- | ---- | ------------------------------ | | `StartAddress` | Long | 起始离散输入地址（0-based） | | `Quantity` | Long | 要读取的离散输入数量（1-2000） | **返回值**: `Boolean()` - 离散输入值数组 **示例**: ```vb Dim baInputs() As Boolean baInputs = mbMaster.ReadDiscreteInputs(0, 10) Dim i As Long For i = 0 To UBound(baInputs) Debug.Print "Input[" & i & "] = " & baInputs(i) Next i ``` *** ### ReadHoldingRegisters - 读取保持寄存器 (0x03) **语法**: ```vb Public Function ReadHoldingRegisters(ByVal StartAddress As Long, ByVal Quantity As Long) As Integer() ``` **参数**: | 参数 | 类型 | 说明 | | -------------- | ---- | --------------------------- | | `StartAddress` | Long | 起始寄存器地址（0-based） | | `Quantity` | Long | 要读取的寄存器数量（1-125） | **返回值**: `Integer()` - 16位寄存器值数组 **示例**: ```vb Dim iRegs() As Integer iRegs = mbMaster.ReadHoldingRegisters(0, 10) Dim i As Long For i = 0 To UBound(iRegs) Debug.Print "Reg[" & i & "] = " & iRegs(i) Next i ``` *** ### ReadInputRegisters - 读取输入寄存器 (0x04) **语法**: ```vb Public Function ReadInputRegisters(ByVal StartAddress As Long, ByVal Quantity As Long) As Integer() ``` **参数**: | 参数 | 类型 | 说明 | | -------------- | ---- | --------------------------- | | `StartAddress` | Long | 起始寄存器地址（0-based） | | `Quantity` | Long | 要读取的寄存器数量（1-125） | **返回值**: `Integer()` - 16位寄存器值数组 **示例**: ```vb Dim iRegs() As Integer iRegs = mbMaster.ReadInputRegisters(0, 10) Dim i As Long For i = 0 To UBound(iRegs) Debug.Print "InputReg[" & i & "] = " & iRegs(i) Next i ``` *** ### WriteSingleCoil - 写入单个线圈 (0x05) **语法**: ```vb Public Function WriteSingleCoil(ByVal Address As Long, ByVal Value As Boolean) As Boolean ``` **参数**: | 参数 | 类型 | 说明 | | --------- | ------- | ------------------------ | | `Address` | Long | 线圈地址 | | `Value` | Boolean | 要写入的值（True/False） | **返回值**: `Boolean` - 成功返回 True，失败返回 False **示例**: ```vb Dim bSuccess As Boolean bSuccess = mbMaster.WriteSingleCoil(0, True) If bSuccess Then Debug.Print "写入成功" Else Debug.Print "写入失败" End If ``` *** ### WriteMultipleCoils - 写入多个线圈 (0x0F) **语法**: ```vb Public Function WriteMultipleCoils(ByVal StartAddress As Long, ByRef Values() As Boolean) As Boolean ``` **参数**: | 参数 | 类型 | 说明 | | -------------- | --------- | ------------------ | | `StartAddress` | Long | 起始线圈地址 | | `Values()` | Boolean() | 要写入的线圈值数组 | **返回值**: `Boolean` - 成功返回 True，失败返回 False **示例**: ```vb Dim baCoils(4) As Boolean baCoils(0) = True baCoils(1) = False baCoils(2) = True baCoils(3) = False baCoils(4) = True Dim bSuccess As Boolean bSuccess = mbMaster.WriteMultipleCoils(0, baCoils) ``` *** ### WriteSingleRegister - 写入单个寄存器 (0x06) **语法**: ```vb Public Function WriteSingleRegister(ByVal Address As Long, ByVal Value As Integer) As Boolean ``` **参数**: | 参数 | 类型 | 说明 | | --------- | ------- | ------------------ | | `Address` | Long | 寄存器地址 | | `Value` | Integer | 要写入的值（16位） | **返回值**: `Boolean` - 成功返回 True，失败返回 False **示例**: ```vb Dim bSuccess As Boolean bSuccess = mbMaster.WriteSingleRegister(0, 1234) If bSuccess Then Debug.Print "写入成功" Else Debug.Print "写入失败" End If ``` *** ### WriteMultipleRegisters - 写入多个寄存器 (0x10) **语法**: ```vb Public Function WriteMultipleRegisters(ByVal StartAddress As Long, ByRef Values() As Integer) As Boolean ``` **参数**: | 参数 | 类型 | 说明 | | -------------- | --------- | -------------------- | | `StartAddress` | Long | 起始寄存器地址 | | `Values()` | Integer() | 要写入的寄存器值数组 | **返回值**: `Boolean` - 成功返回 True，失败返回 False **示例**: ```vb Dim iRegs(4) As Integer iRegs(0) = 100 iRegs(1) = 200 iRegs(2) = 300 iRegs(3) = 400 iRegs(4) = 500 Dim bSuccess As Boolean bSuccess = mbMaster.WriteMultipleRegisters(0, iRegs) ``` *** ## ? 事件详解 ### OnConnect - 连接成功 **语法**: ```vb Event OnConnect() ``` **示例**: ```vb Private Sub mbMaster_OnConnect() Debug.Print "已成功连接到 Modbus 从站" lblStatus.Caption = "已连接" cmdRead.Enabled = True cmdWrite.Enabled = True End Sub ``` *** ### OnDisconnect - 连接断开 **语法**: ```vb Event OnDisconnect() ``` **示例**: ```vb Private Sub mbMaster_OnDisconnect() Debug.Print "连接已断开" lblStatus.Caption = "已断开" cmdRead.Enabled = False cmdWrite.Enabled = False End Sub ``` *** ### OnError - 发生错误 **语法**: ```vb Event OnError(ByVal Description As String) ``` **示例**: ```vb Private Sub mbMaster_OnError(ByVal Description As String) Debug.Print "错误: " & Description ' 显示错误提示 MsgBox "发生错误: " & Description, vbExclamation ' 记录错误日志 LogError Description ' 更新 UI lblStatus.Caption = "错误" End Sub ``` *** ### OnDataReceived - 收到数据 **语法**: ```vb Event OnDataReceived(Data() As Byte) ``` **说明**: 调试事件，用于查看原始收到的数据。 **示例**: ```vb Private Sub mbMaster_OnDataReceived(Data() As Byte) Debug.Print "收到 " & (UBound(Data) + 1) & " 字节数据" ' 显示十六进制数据 Dim sHex As String Dim i As Long For i = 0 To UBound(Data) sHex = sHex & Hex$(Data(i)) & " " Next i Debug.Print "数据: " & sHex End Sub ``` *** ## ? 完整示例 ### 基本主站示例 ```vb Option Explicit Private WithEvents mbMaster As cModbusMaster Private Sub Form_Load() Set mbMaster = New cModbusMaster mbMaster.ProtocolType = MB_MASTER_PROTOCOL_TCP mbMaster.TCPHost = "127.0.0.1" mbMaster.TCPPort = 502 mbMaster.SlaveID = 1 End Sub Private Sub cmdConnect_Click() mbMaster.Connect End Sub Private Sub cmdRead_Click() Dim iRegs() As Integer iRegs = mbMaster.ReadHoldingRegisters(0, 10) Dim i As Long For i = 0 To UBound(iRegs) lstRegisters.AddItem "Reg[" & i & "] = " & iRegs(i) Next i End Sub Private Sub mbMaster_OnConnect() Debug.Print "已连接" End Sub Private Sub mbMaster_OnDisconnect() Debug.Print "已断开" End Sub Private Sub Form_Unload(Cancel As Integer) mbMaster.Disconnect End Sub ``` ### 带重连的主站 ```vb Option Explicit Private WithEvents mbMaster As cModbusMaster Private WithEvents tmrReconnect As Timer Private m_bAutoReconnect As Boolean Private Sub Form_Load() Set mbMaster = New cModbusMaster Set tmrReconnect = New Timer tmrReconnect.Interval = 5000 ' 5 秒后重连 m_bAutoReconnect = True mbMaster.ProtocolType = MB_MASTER_PROTOCOL_TCP mbMaster.TCPHost = "127.0.0.1" mbMaster.TCPPort = 502 mbMaster.SlaveID = 1 ConnectToServer End Sub Private Sub ConnectToServer() If mbMaster.State = MB_MASTER_STATE_DISCONNECTED Then Debug.Print "正在连接..." mbMaster.Connect End If End Sub Private Sub mbMaster_OnConnect() Debug.Print "已连接" tmrReconnect.Enabled = False End Sub Private Sub mbMaster_OnDisconnect() Debug.Print "连接断开" If m_bAutoReconnect Then Debug.Print "5 秒后重连..." tmrReconnect.Enabled = True End If End Sub Private Sub tmrReconnect_Timer() tmrReconnect.Enabled = False ConnectToServer End Sub Private Sub Form_Unload(Cancel As Integer) tmrReconnect.Enabled = False mbMaster.Disconnect End Sub ``` ### 数据采集示例 ```vb Option Explicit Private WithEvents mbMaster As cModbusMaster Private WithEvents tmrPoll As Timer Private Sub Form_Load() Set mbMaster = New cModbusMaster Set tmrPoll = New Timer tmrPoll.Interval = 1000 ' 每秒采集一次 mbMaster.ProtocolType = MB_MASTER_PROTOCOL_TCP mbMaster.TCPHost = "127.0.0.1" mbMaster.TCPPort = 502 mbMaster.SlaveID = 1 mbMaster.Connect End Sub Private Sub mbMaster_OnConnect() Debug.Print "已连接，开始数据采集" tmrPoll.Enabled = True End Sub Private Sub tmrPoll_Timer() On Error Resume Next Dim iRegs() As Integer iRegs = mbMaster.ReadHoldingRegisters(0, 10) If UBound(iRegs) >= 0 Then ' 更新显示 UpdateDisplay iRegs ' 保存到数据库或文件 SaveToDatabase iRegs End If End Sub Private Sub UpdateDisplay(ByRef iRegs() As Integer) Dim i As Long For i = 0 To UBound(iRegs) Dim sKey As String sKey = "txtReg" & i On Error Resume Next Dim txtBox As Control Set txtBox = Me.Controls(sKey) If Not txtBox Is Nothing Then txtBox.Text = iRegs(i) End If On Error GoTo 0 Next i End Sub Private Sub Form_Unload(Cancel As Integer) tmrPoll.Enabled = False mbMaster.Disconnect End Sub ``` *** **最后更新**: 2026-01-16 ### 更新日志 #### 2026-01-16 (v1.1.0) * 更新枚举命名：`ModbusProtocolType` → `ModbusMasterProtocolType` * 更新状态枚举：`ModbusState` → `ModbusMasterState` * 更新结构体命名：`ModbusDefaults` → `ModbusMasterDefaults` * 所有示例代码已同步更新 --- --- url: /zh/vbman/modbus/slave.md --- # cModbusSlave 类参考 ## ? 类概述 `cModbusSlave` 是 Modbus 从站（服务器）实现类，提供监听连接、处理主站请求、维护数据存储等功能。 *** ## ? 事件列表 | 事件名 | 触发时机 | 参数 | | -------------------- | ---------------------- | -------------------------------------------------- | | `OnStarted` | 服务器启动 | 无 | | `OnStopped` | 服务器停止 | 无 | | `OnClientConnect` | 客户端连接（TCP 模式） | `ClientID` (客户端 ID), `RemoteAddress` (远程地址) | | `OnClientDisconnect` | 客户端断开（TCP 模式） | `ClientID` (客户端 ID), `Reason` (断开原因) | | `OnReadRequest` | 收到读取请求 | `ClientID`, `FunctionCode`, `Address`, `Quantity` | | `OnWriteRequest` | 收到写入请求 | `ClientID`, `FunctionCode`, `Data` | | `OnError` | 发生错误 | `Description` (错误描述) | | `OnDataReceived` | 收到数据（调试用） | `ClientID`, `Data()` (字节数组) | *** ## ? 属性参考 ### ProtocolType - 协议类型 **类型**: `ModbusSlaveProtocolType` (枚举)\ **读写**: 读写 **值**: | 常量 | 值 | 说明 | | ----------------------- | --- | -------------------- | | `MB_SLAVE_PROTOCOL_RTU` | 1 | RTU 模式（串口通信） | | `MB_SLAVE_PROTOCOL_TCP` | 2 | TCP 模式（网络通信） | **示例**: ```vb ' 设置为 TCP 模式 mbSlave.ProtocolType = MB_SLAVE_PROTOCOL_TCP ' 设置为 RTU 模式 mbSlave.ProtocolType = MB_SLAVE_PROTOCOL_RTU ``` *** ### State - 服务器状态 **类型**: `ModbusSlaveState` (枚举)\ **读写**: 只读 **值**: | 常量 | 值 | 说明 | | ------------------------- | --- | -------- | | `MB_SLAVE_STATE_STOPPED` | 0 | 已停止 | | `MB_SLAVE_STATE_STARTING` | 1 | 正在启动 | | `MB_SLAVE_STATE_RUNNING` | 2 | 运行中 | | `MB_SLAVE_STATE_ERROR` | 3 | 错误状态 | **示例**: ```vb If mbSlave.State = MB_SLAVE_STATE_RUNNING Then Debug.Print "服务器运行中" End If ``` *** ### SlaveID - 从站 ID **类型**: `Byte`\ **读写**: 读写 **说明**: 从站设备地址（1-247）。0 表示广播地址。 **示例**: ```vb mbSlave.SlaveID = 1 ``` *** ### Defaults - 默认常量 **类型**: `ModbusSlaveDefaults` (结构体)\ **读写**: 只读 **示例**: ```vb Debug.Print "默认端口: " & mbSlave.Defaults.TCP_PORT ``` *** ### RTU 模式属性 #### SerialPort - 串口名称 **类型**: `String`\ **读写**: 读写 **示例**: ```vb mbSlave.SerialPort = "COM1" ``` #### BaudRate - 波特率 **类型**: `Long`\ **读写**: 读写 **示例**: ```vb mbSlave.BaudRate = 9600 ``` #### DataBits - 数据位 **类型**: `Long`\ **读写**: 读写 **示例**: ```vb mbSlave.DataBits = 8 ``` #### Parity - 校验位 **类型**: `String`\ **读写**: 读写 **值**: "N" (无), "E" (偶校验), "O" (奇校验) **示例**: ```vb mbSlave.Parity = "N" ' 无校验 ``` #### StopBits - 停止位 **类型**: `Long`\ **读写**: 读写 **示例**: ```vb mbSlave.StopBits = 1 ``` *** ### TCP 模式属性 #### Port - 监听端口 **类型**: `Long` (只读)\ **读写**: 只读 **说明**: 获取当前监听的端口。 *** #### BindAddress - 监听地址 **类型**: `String`\ **读写**: 读写 **说明**: TCP 监听地址配置（v1.1.0+）。支持以下取值： * `"0.0.0.0"` 或空字符串 - 监听所有网络接口（默认） * `"127.0.0.1"` - 仅监听本地回环地址 * `"192.168.1.100"` - 监听指定网络接口 **示例**: ```vb ' 仅监听本地连接（更安全） mbSlave.BindAddress = "127.0.0.1" mbSlave.Start 502 ' 监听所有网络接口（默认） mbSlave.BindAddress = "0.0.0.0" mbSlave.Start 502 ' 在 Start 方法中指定监听地址 mbSlave.Start 502, "192.168.1.100" ``` *** ### ClientCount - 连接的客户端数 **类型**: `Long` (只读)\ **读写**: 只读 **说明**: TCP 模式下已连接的客户端数量。 **示例**: ```vb Debug.Print "当前连接数: " & mbSlave.ClientCount ``` *** ## ? 方法参考 ### Start - 启动服务器 **语法**: ```vb Public Sub Start(Optional ByVal PortOrSerial As String = "", Optional ByVal BindAddress As String = "") ``` **参数**: | 参数 | 类型 | 说明 | | -------------- | ------------- | ------------------------------------------------------------------- | | `PortOrSerial` | String (可选) | TCP 模式：端口号；RTU 模式：串口名称 | | `BindAddress` | String (可选) | TCP 模式：监听地址（如 "127.0.0.1"），RTU 模式忽略此参数（v1.1.0+） | **示例**: ```vb ' TCP 模式 - 启动服务器 mbSlave.ProtocolType = MB_SLAVE_PROTOCOL_TCP mbSlave.SlaveID = 1 mbSlave.Start 502 ' TCP 模式 - 指定监听地址 mbSlave.Start 502, "127.0.0.1" ' 仅监听本地 mbSlave.Start 502, "0.0.0.0" ' 监听所有接口 ' RTU 模式 - 启动服务器 mbSlave.ProtocolType = MB_SLAVE_PROTOCOL_RTU mbSlave.SerialPort = "COM1" mbSlave.BaudRate = 9600 mbSlave.DataBits = 8 mbSlave.Parity = "N" mbSlave.StopBits = 1 mbSlave.SlaveID = 1 mbSlave.Start "COM1" ``` *** ### StopMe - 停止服务器 **语法**: ```vb Public Sub StopMe() ``` **说明**: 从 v1.1.0 开始，`Stop` 方法更名为 `StopMe`，避免与 VB 关键字冲突。 **示例**: ```vb mbSlave.StopMe ``` *** ### SetCoil - 设置线圈值 **语法**: ```vb Public Sub SetCoil(ByVal Address As Long, ByVal Value As Boolean) ``` **参数**: | 参数 | 类型 | 说明 | | --------- | ------- | ----------------- | | `Address` | Long | 线圈地址 (0-1990) | | `Value` | Boolean | 线圈值 | **示例**: ```vb mbSlave.SetCoil 0, True mbSlave.SetCoil 1, False ``` *** ### GetCoil - 获取线圈值 **语法**: ```vb Public Function GetCoil(ByVal Address As Long) As Boolean ``` **参数**: | 参数 | 类型 | 说明 | | --------- | ---- | -------- | | `Address` | Long | 线圈地址 | **返回值**: `Boolean` - 线圈值 **示例**: ```vb Dim bValue As Boolean bValue = mbSlave.GetCoil(0) Debug.Print "Coil[0] = " & bValue ``` *** ### SetDiscreteInput - 设置离散输入值 **语法**: ```vb Public Sub SetDiscreteInput(ByVal Address As Long, ByVal Value As Boolean) ``` **参数**: | 参数 | 类型 | 说明 | | --------- | ------- | --------------------- | | `Address` | Long | 离散输入地址 (0-2000) | | `Value` | Boolean | 离散输入值 | **示例**: ```vb mbSlave.SetDiscreteInput 0, True ``` *** ### GetDiscreteInput - 获取离散输入值 **语法**: ```vb Public Function GetDiscreteInput(ByVal Address As Long) As Boolean ``` **参数**: | 参数 | 类型 | 说明 | | --------- | ---- | ------------ | | `Address` | Long | 离散输入地址 | **返回值**: `Boolean` - 离散输入值 **示例**: ```vb Dim bValue As Boolean bValue = mbSlave.GetDiscreteInput(0) ``` *** ### SetHoldingRegister - 设置保持寄存器值 **语法**: ```vb Public Sub SetHoldingRegister(ByVal Address As Long, ByVal Value As Integer) ``` **参数**: | 参数 | 类型 | 说明 | | --------- | ------- | ------------------ | | `Address` | Long | 寄存器地址 (0-125) | | `Value` | Integer | 寄存器值 (16位) | **示例**: ```vb mbSlave.SetHoldingRegister 0, 1234 mbSlave.SetHoldingRegister 1, 5678 ``` *** ### GetHoldingRegister - 获取保持寄存器值 **语法**: ```vb Public Function GetHoldingRegister(ByVal Address As Long) As Integer ``` **参数**: | 参数 | 类型 | 说明 | | --------- | ---- | ---------- | | `Address` | Long | 寄存器地址 | **返回值**: `Integer` - 寄存器值 **示例**: ```vb Dim iValue As Integer iValue = mbSlave.GetHoldingRegister(0) Debug.Print "Reg[0] = " & iValue ``` *** ### SetInputRegister - 设置输入寄存器值 **语法**: ```vb Public Sub SetInputRegister(ByVal Address As Long, ByVal Value As Integer) ``` **参数**: | 参数 | 类型 | 说明 | | --------- | ------- | ------------------ | | `Address` | Long | 寄存器地址 (0-125) | | `Value` | Integer | 寄存器值 (16位) | **示例**: ```vb mbSlave.SetInputRegister 0, 1234 ``` *** ### GetInputRegister - 获取输入寄存器值 **语法**: ```vb Public Function GetInputRegister(ByVal Address As Long) As Integer ``` **参数**: | 参数 | 类型 | 说明 | | --------- | ---- | ---------- | | `Address` | Long | 寄存器地址 | **返回值**: `Integer` - 寄存器值 **示例**: ```vb Dim iValue As Integer iValue = mbSlave.GetInputRegister(0) ``` *** ### ClearAllData - 清空所有数据 **语法**: ```vb Public Sub ClearAllData() ``` **示例**: ```vb mbSlave.ClearAllData ``` *** ## ? 事件详解 ### OnStarted - 服务器启动 **语法**: ```vb Event OnStarted() ``` **示例**: ```vb Private Sub mbSlave_OnStarted() Debug.Print "服务器已启动" lblStatus.Caption = "运行中" cmdStart.Enabled = False cmdStop.Enabled = True End Sub ``` *** ### OnStopped - 服务器停止 **语法**: ```vb Event OnStopped() ``` **示例**: ```vb Private Sub mbSlave_OnStopped() Debug.Print "服务器已停止" lblStatus.Caption = "已停止" cmdStart.Enabled = True cmdStop.Enabled = False End Sub ``` *** ### OnClientConnect - 客户端连接 **语法**: ```vb Event OnClientConnect(ByVal ClientID As String, ByVal RemoteAddress As String) ``` **参数**: | 参数 | 类型 | 说明 | | --------------- | ------ | --------- | | `ClientID` | String | 客户端 ID | | `RemoteAddress` | String | 远程地址 | **示例**: ```vb Private Sub mbSlave_OnClientConnect(ByVal ClientID As String, ByVal RemoteAddress As String) Debug.Print "客户端连接: " & ClientID & " (" & RemoteAddress & ")" lstClients.AddItem ClientID & " - " & RemoteAddress End Sub ``` *** ### OnClientDisconnect - 客户端断开 **语法**: ```vb Event OnClientDisconnect(ByVal ClientID As String, ByVal Reason As String) ``` **参数**: | 参数 | 类型 | 说明 | | ---------- | ------ | --------- | | `ClientID` | String | 客户端 ID | | `Reason` | String | 断开原因 | **示例**: ```vb Private Sub mbSlave_OnClientDisconnect(ByVal ClientID As String, ByVal Reason As String) Debug.Print "客户端断开: " & ClientID & " - " & Reason Dim i As Long For i = 0 To lstClients.ListCount - 1 If InStr(lstClients.List(i), ClientID) > 0 Then lstClients.RemoveItem i Exit For End If Next i End Sub ``` *** ### OnReadRequest - 读取请求 **语法**: ```vb Event OnReadRequest(ByVal ClientID As String, ByVal FunctionCode As ModbusSlaveFunctionCode, ByVal Address As Long, ByVal Quantity As Long) ``` **说明**: 当主站发送读取请求时触发。 **示例**: ```vb Private Sub mbSlave_OnReadRequest(ByVal ClientID As String, ByVal FunctionCode As ModbusSlaveFunctionCode, ByVal Address As Long, ByVal Quantity As Long) Debug.Print "读取请求: " & FunctionCode & ", 地址=" & Address & ", 数量=" & Quantity ' 根据功能码处理 Select Case FunctionCode Case MB_SLAVE_FC_READ_COILS Debug.Print "读取线圈" Case MB_SLAVE_FC_READ_HOLDING_REGISTERS Debug.Print "读取保持寄存器" End Select End Sub ``` *** ### OnWriteRequest - 写入请求 **语法**: ```vb Event OnWriteRequest(ByVal ClientID As String, ByVal FunctionCode As ModbusSlaveFunctionCode, ByVal Address As Long, ByRef Data As Variant) ``` **说明**: 当主站发送写入请求时触发。 **示例**: ```vb Private Sub mbSlave_OnWriteRequest(ByVal ClientID As String, ByVal FunctionCode As ModbusSlaveFunctionCode, ByVal Address As Long, ByRef Data As Variant) Debug.Print "写入请求: " & FunctionCode & ", 地址=" & Address ' 根据功能码处理 Select Case FunctionCode Case MB_SLAVE_FC_WRITE_SINGLE_REGISTER Debug.Print "写入单个寄存器" Case MB_SLAVE_FC_WRITE_MULTIPLE_REGISTERS Debug.Print "写入多个寄存器" End Select End Sub ``` *** ### OnError - 发生错误 **语法**: ```vb Event OnError(ByVal Description As String) ``` **示例**: ```vb Private Sub mbSlave_OnError(ByVal Description As String) Debug.Print "错误: " & Description MsgBox "发生错误: " & Description, vbExclamation LogError Description End Sub ``` *** ### OnDataReceived - 收到数据 **语法**: ```vb Event OnDataReceived(ByVal ClientID As String, Data() As Byte) ``` **说明**: 调试事件，用于查看原始收到的数据。 **示例**: ```vb Private Sub mbSlave_OnDataReceived(ByVal ClientID As String, Data() As Byte) Debug.Print ClientID & " 收到 " & (UBound(Data) + 1) & " 字节" Dim sHex As String Dim i As Long For i = 0 To UBound(Data) sHex = sHex & Hex$(Data(i)) & " " Next i Debug.Print "数据: " & sHex End Sub ``` *** ## ? 完整示例 ### 基本从站示例 ```vb Option Explicit Private WithEvents mbSlave As cModbusSlave Private Sub Form_Load() Set mbSlave = New cModbusSlave End Sub Private Sub cmdStart_Click() mbSlave.ProtocolType = MB_SLAVE_PROTOCOL_TCP mbSlave.SlaveID = 1 mbSlave.Start 502 End Sub Private Sub cmdStop_Click() mbSlave.StopMe End Sub Private Sub mbSlave_OnStarted() Debug.Print "已启动" cmdStart.Enabled = False cmdStop.Enabled = True End Sub Private Sub mbSlave_OnStopped() Debug.Print "已停止" cmdStart.Enabled = True cmdStop.Enabled = False End Sub ``` *** ### 动态数据更新示例 ```vb Option Explicit Private WithEvents mbSlave As cModbusSlave Private WithEvents tmrUpdate As Timer Private Sub Form_Load() Set mbSlave = New cModbusSlave Set tmrUpdate = New Timer tmrUpdate.Interval = 1000 ' 每秒更新 mbSlave.ProtocolType = MB_SLAVE_PROTOCOL_TCP mbSlave.SlaveID = 1 mbSlave.Start 502 End Sub Private Sub mbSlave_OnStarted() tmrUpdate.Enabled = True Debug.Print "开始动态更新数据" End Sub Private Sub tmrUpdate_Timer() Dim i As Long ' 更新时间数据到寄存器 0-5 Dim dtNow As Date dtNow = Now mbSlave.SetHoldingRegister 0, Year(dtNow) mbSlave.SetHoldingRegister 1, Month(dtNow) mbSlave.SetHoldingRegister 2, Day(dtNow) mbSlave.SetHoldingRegister 3, Hour(dtNow) mbSlave.SetHoldingRegister 4, Minute(dtNow) mbSlave.SetHoldingRegister 5, Second(dtNow) ' 更新传感器数据到寄存器 10-20 For i = 10 To 20 Dim iValue As Integer iValue = ReadSensor(i - 10) ' 从传感器读取 mbSlave.SetHoldingRegister i, iValue Next i End Sub Private Function ReadSensor(iSensorID As Long) As Integer ' 模拟传感器数据 ReadSensor = Rnd * 10000 End Function Private Sub Form_Unload(Cancel As Integer) tmrUpdate.Enabled = False mbSlave.StopMe End Sub ``` *** ### 多客户端处理示例 ```vb Option Explicit Private WithEvents mbSlave As cModbusSlave Private m_Clients As Collection Private Sub Form_Load() Set mbSlave = New cModbusSlave Set m_Clients = New Collection mbSlave.ProtocolType = MB_SLAVE_PROTOCOL_TCP mbSlave.SlaveID = 1 mbSlave.Start 502 End Sub Private Sub mbSlave_OnClientConnect(ByVal ClientID As String, ByVal RemoteAddress As String) Debug.Print "客户端连接: " & ClientID & " (" & RemoteAddress & ")" ' 记录客户端信息 Dim clientInfo As New Collection clientInfo.Add ClientID, "ID" clientInfo.Add RemoteAddress, "Address" clientInfo.Add Now, "ConnectTime" m_Clients.Add clientInfo, ClientID ' 发送欢迎数据 mbSlave.SetHoldingRegister 100, Year(Now) mbSlave.SetHoldingRegister 101, Month(Now) End Sub Private Sub mbSlave_OnClientDisconnect(ByVal ClientID As String, ByVal Reason As String) Debug.Print "客户端断开: " & ClientID On Error Resume Next m_Clients.Remove ClientID On Error GoTo 0 End Sub Private Sub GetClientInfo(ByVal ClientID As String) As String On Error Resume Next Dim clientInfo As Collection Set clientInfo = m_Clients(ClientID) If Not clientInfo Is Nothing Then GetClientInfo = "ID: " & clientInfo("ID") & _ ", Address: " & clientInfo("Address") & _ ", ConnectTime: " & Format$(clientInfo("ConnectTime"), "hh:mm:ss") End If End Sub Private Sub Form_Unload(Cancel As Integer) mbSlave.StopMe Set m_Clients = Nothing End Sub ``` *** **最后更新**: 2026-01-16 ### 更新日志 #### 2026-01-16 (v1.1.0) * 新增 `BindAddress` 属性 - 支持配置 TCP 监听地址 * 新增 `Start` 方法重载 - 支持在启动时指定监听地址 * 更新方法命名：`Stop()` → `StopMe()` * 更新枚举命名：添加 `Slave` 后缀区分 * `ModbusFunctionCode` → `ModbusSlaveFunctionCode` * `ModbusExceptionCode` → `ModbusSlaveExceptionCode` * `ModbusState` → `ModbusSlaveState` * `ModbusProtocolType` → `ModbusSlaveProtocolType` * `ModbusDefaults` → `ModbusSlaveDefaults` * 所有示例代码已同步更新 --- --- url: /en/packages/vbccr/lists/comboboxw.md description: >- ComboBoxW Control - VBCCR Development Manual, complete API reference based on source code --- # ComboBoxW Control Enhanced combo box control with support for visual styles, owner-draw, character casing control, and cue banner text. ## Enumerations ### CboStyleConstants | Constant | Value | Description | |----------|-------|-------------| | CboStyleDropDownCombo | 0 | Drop-down combo box | | CboStyleSimpleCombo | 1 | Simple combo box | | CboStyleDropDownList | 2 | Drop-down list | ### CboCharacterCasingConstants | Constant | Value | Description | |----------|-------|-------------| | CboCharacterCasingNormal | 0 | Normal casing | | CboCharacterCasingUpper | 1 | Uppercase | | CboCharacterCasingLower | 2 | Lowercase | ### CboDrawModeConstants | Constant | Value | Description | |----------|-------|-------------| | CboDrawModeNormal | 0 | Normal mode | | CboDrawModeOwnerDrawFixed | 1 | Owner-draw fixed height | | CboDrawModeOwnerDrawVariable | 2 | Owner-draw variable height | ## Properties ### VisualStyles ```vb Property Get VisualStyles() As Boolean Property Let VisualStyles(ByVal Value As Boolean) ``` Whether to enable visual styles. ### BackColor ```vb Property Get BackColor() As OLE_COLOR Property Let BackColor(ByVal Value As OLE_COLOR) ``` Background color. ### ForeColor ```vb Property Get ForeColor() As OLE_COLOR Property Let ForeColor(ByVal Value As OLE_COLOR) ``` Foreground color. ### OLEDropMode ```vb Property Get OLEDropMode() As OLEDropModeConstants Property Let OLEDropMode(ByVal Value As OLEDropModeConstants) ``` OLE drag-drop mode. See common enumerations. ### Redraw ```vb Property Get Redraw() As Boolean Property Let Redraw(ByVal Value As Boolean) ``` Whether to allow redrawing. ### Style ```vb Property Get Style() As CboStyleConstants Property Let Style(ByVal Value As CboStyleConstants) ``` Combo box style. ### Locked ```vb Property Get Locked() As Boolean Property Let Locked(ByVal Value As Boolean) ``` Whether the control is locked (not editable). ### Text ```vb Property Get Text() As String Property Let Text(ByVal Value As String) ``` Edit box text. ### ExtendedUI ```vb Property Get ExtendedUI() As Boolean Property Let ExtendedUI(ByVal Value As Boolean) ``` Extended user interface mode. ### MaxDropDownItems ```vb Property Get MaxDropDownItems() As Long Property Let MaxDropDownItems(ByVal Value As Long) ``` Maximum number of items displayed in the drop-down list. ### IntegralHeight ```vb Property Get IntegralHeight() As Boolean Property Let IntegralHeight(ByVal Value As Boolean) ``` Whether to resize the list to fit complete items only. ### MaxLength ```vb Property Get MaxLength() As Long Property Let MaxLength(ByVal Value As Long) ``` Maximum number of characters in the edit box. ### CueBanner ```vb Property Get CueBanner() As String Property Let CueBanner(ByVal Value As String) ``` Cue banner text (displayed when the edit box is empty). ### UseListBackColor ```vb Property Get UseListBackColor() As Boolean Property Let UseListBackColor(ByVal Value As Boolean) ``` Whether to use a custom list background color. ### ListBackColor ```vb Property Get ListBackColor() As OLE_COLOR Property Let ListBackColor(ByVal Value As OLE_COLOR) ``` Drop-down list background color. ### UseListForeColor ```vb Property Get UseListForeColor() As Boolean Property Let UseListForeColor(ByVal Value As Boolean) ``` Whether to use a custom list foreground color. ### ListForeColor ```vb Property Get ListForeColor() As OLE_COLOR Property Let ListForeColor(ByVal Value As OLE_COLOR) ``` Drop-down list foreground color. ### Sorted ```vb Property Get Sorted() As Boolean Property Let Sorted(ByVal Value As Boolean) ``` Whether to automatically sort items. ### HorizontalExtent ```vb Property Get HorizontalExtent() As Long Property Let HorizontalExtent(ByVal Value As Long) ``` Horizontal scroll range of the drop-down list. ### DisableNoScroll ```vb Property Get DisableNoScroll() As Boolean Property Let DisableNoScroll(ByVal Value As Boolean) ``` Whether to disable the scroll bar instead of hiding it when items do not fill the list. ### CharacterCasing ```vb Property Get CharacterCasing() As CboCharacterCasingConstants Property Let CharacterCasing(ByVal Value As CboCharacterCasingConstants) ``` Character casing mode. ### DrawMode ```vb Property Get DrawMode() As CboDrawModeConstants Property Let DrawMode(ByVal Value As CboDrawModeConstants) ``` Drawing mode. ### IMEMode ```vb Property Get IMEMode() As CCIMEModeConstants Property Let IMEMode(ByVal Value As CCIMEModeConstants) ``` Input method editor mode. See common enumerations. ### ScrollTrack ```vb Property Get ScrollTrack() As Boolean Property Let ScrollTrack(ByVal Value As Boolean) ``` Whether to enable scroll tracking. ### AutoSelect ```vb Property Get AutoSelect() As Boolean Property Let AutoSelect(ByVal Value As Boolean) ``` Whether to automatically select matching items. ### AlwaysFindExact ```vb Property Get AlwaysFindExact() As Boolean Property Let AlwaysFindExact(ByVal Value As Boolean) ``` Whether to always perform exact find. ### ListCount ```vb Property Get ListCount() As Long ``` Number of list items. Read-only. ### List ```vb Property Get List(ByVal Index As Long) As String Property Let List(ByVal Index As Long, ByVal Value As String) ``` Access list items by index. ### ListIndex ```vb Property Get ListIndex() As Long Property Let ListIndex(ByVal Value As Long) ``` Index of the currently selected item. ### ItemData ```vb Property Get ItemData(ByVal Index As Long) As Long Property Let ItemData(ByVal Index As Long, ByVal Value As Long) ``` Item-associated data. ### NewIndex ```vb Property Get NewIndex() As Long ``` Index of the most recently added item. Read-only. ### TopIndex ```vb Property Get TopIndex() As Long Property Let TopIndex(ByVal Value As Long) ``` Index of the top visible item in the list. ### SelStart ```vb Property Get SelStart() As Long Property Let SelStart(ByVal Value As Long) ``` Starting position of selected text. ### SelLength ```vb Property Get SelLength() As Long Property Let SelLength(ByVal Value As Long) ``` Length of selected text. ### SelText ```vb Property Get SelText() As String Property Let SelText(ByVal Value As String) ``` Selected text. ### ItemHeight ```vb Property Get ItemHeight() As Single Property Let ItemHeight(ByVal Value As Single) ``` List item height. ### FieldHeight ```vb Property Get FieldHeight() As Single ``` Edit box height. Read-only. ### DroppedDown ```vb Property Get DroppedDown() As Boolean Property Let DroppedDown(ByVal Value As Boolean) ``` Whether the drop-down list is expanded. ### DropDownWidth ```vb Property Get DropDownWidth() As Long Property Let DropDownWidth(ByVal Value As Long) ``` Drop-down list width. ### DropDownHeight ```vb Property Get DropDownHeight() As Long Property Let DropDownHeight(ByVal Value As Long) ``` Drop-down list height. ### hWndEdit ```vb Property Get hWndEdit() As LongPtr ``` Edit box window handle. Read-only. ### hWndList ```vb Property Get hWndList() As LongPtr ``` List box window handle. Read-only. ### hWnd / hWndUserControl / Font / Enabled / MousePointer / MouseIcon / MouseTrack See common properties. ### Name / Tag / Parent / Container / Left / Top / Width / Height / Visible / ToolTipText / HelpContextID / WhatsThisHelpID / DragIcon / DragMode See standard extender properties. ## Methods ### AddItem ```vb Public Sub AddItem(ByVal Item As String, Optional ByVal Index As Variant) ``` Adds a list item. ### RemoveItem ```vb Public Sub RemoveItem(ByVal Index As Long) ``` Removes a list item. ### Clear ```vb Public Sub Clear() ``` Clears all list items. ### Refresh ```vb Public Sub Refresh() ``` Forces a redraw. ### FindItem ```vb Public Function FindItem(ByVal SearchString As String, Optional ByVal StartIndex As Long, Optional ByVal FindMode As Long) As Long ``` Finds a list item and returns its index. ### GetIdealHorizontalExtent ```vb Public Function GetIdealHorizontalExtent() As Long ``` Gets the ideal horizontal scroll range. ### SelectItem ```vb Public Sub SelectItem(ByVal SearchString As String) ``` Selects a matching list item. ### OLEDrag ```vb Public Sub OLEDrag() ``` Initiates an OLE drag-drop operation. ### Drag / ZOrder / SetFocus / Move See standard methods. ## Events ### Click ```vb Public Event Click() ``` ### DblClick ```vb Public Event DblClick() ``` ### Scroll ```vb Public Event Scroll() ``` Fired when the list scrolls. ### Change ```vb Public Event Change() ``` Fired when the text content changes. ### ContextMenu ```vb Public Event ContextMenu() ``` Context menu event. ### DropDown ```vb Public Event DropDown() ``` Drop-down list is expanding. ### CloseUp ```vb Public Event CloseUp() ``` Drop-down list is closing. ### ItemMeasure ```vb Public Event ItemMeasure(ByVal Index As Long, ByVal ItemWidth As Long, ByVal ItemHeight As Long) ``` Owner-draw measure event. ### ItemDraw ```vb Public Event ItemDraw(ByVal Index As Long, ByVal ItemState As Long, ByVal hDC As LongPtr, ByVal Left As Long, ByVal Top As Long, ByVal Right As Long, ByVal Bottom As Long) ``` Owner-draw paint event. ### KeyDown / KeyUp / KeyPress ### MouseDown / MouseMove / MouseUp / MouseEnter / MouseLeave ### OLECompleteDrag / OLEDragDrop / OLEDragOver / OLEGiveFeedback / OLESetData / OLEStartDrag ## Code Examples ### Basic Usage ```vb ' Add items ComboBoxW1.AddItem "Apple" ComboBoxW1.AddItem "Banana" ComboBoxW1.ListIndex = 0 ' Set cue banner ComboBoxW1.CueBanner = "Please select a fruit..." ' Uppercase mode ComboBoxW1.CharacterCasing = CboCharacterCasingUpper ' Owner-draw mode ComboBoxW1.DrawMode = CboDrawModeOwnerDrawFixed ``` ### Owner-Draw Example ```vb Private Sub ComboBoxW1_ItemDraw(ByVal Index As Long, ByVal ItemState As Long, _ ByVal hDC As LongPtr, ByVal Left As Long, ByVal Top As Long, _ ByVal Right As Long, ByVal Bottom As Long) ' Draw custom list item End Sub ``` --- --- url: /en/packages/vbccr/buttons/commandbuttonw.md description: >- CommandButtonW Control - VBCCR Development Manual, complete API reference based on source code --- # CommandButtonW Control Enhanced CommandButton control with support for visual styles, split button, owner-draw, and coexistence of picture and caption. ## Enumerations ### CmdImageListAlignmentConstants | Constant | Value | Description | |----------|-------|-------------| | CmdImageListAlignmentLeft | 0 | Left alignment | | CmdImageListAlignmentRight | 1 | Right alignment | | CmdImageListAlignmentTop | 2 | Top alignment | | CmdImageListAlignmentBottom | 3 | Bottom alignment | | CmdImageListAlignmentCenter | 4 | Center alignment | ### CmdDrawModeConstants | Constant | Value | Description | |----------|-------|-------------| | CmdDrawModeNormal | 0 | Normal mode | | CmdDrawModeOwnerDraw | 1 | Owner-draw mode | ## Properties ### Default ```vb Property Get Default() As Boolean Property Let Default(ByVal Value As Boolean) ``` Whether this is the default button (triggered by Enter key). ### Cancel ```vb Property Get Cancel() As Boolean Property Let Cancel(ByVal Value As Boolean) ``` Whether this is the cancel button (triggered by Esc key). ### VisualStyles ```vb Property Get VisualStyles() As Boolean Property Let VisualStyles(ByVal Value As Boolean) ``` Whether to enable visual styles. ### Appearance ```vb Property Get Appearance() As CCAppearanceConstants Property Let Appearance(ByVal Value As CCAppearanceConstants) ``` Appearance style. See Common Enumerations. ### BackColor ```vb Property Get BackColor() As OLE_COLOR Property Let BackColor(ByVal Value As OLE_COLOR) ``` Background color. ### ForeColor ```vb Property Get ForeColor() As OLE_COLOR Property Let ForeColor(ByVal Value As OLE_COLOR) ``` Foreground color. ### ImageList ```vb Property Get ImageList() As Variant Property Let ImageList(ByVal Value As Variant) Property Set ImageList(ByVal Value As Variant) ``` Associated ImageList control. ### ImageListAlignment ```vb Property Get ImageListAlignment() As CmdImageListAlignmentConstants Property Let ImageListAlignment(ByVal Value As CmdImageListAlignmentConstants) ``` ImageList icon alignment. ### ImageListMargin ```vb Property Get ImageListMargin() As Single Property Let ImageListMargin(ByVal Value As Single) ``` ImageList icon margin. ### Caption ```vb Property Get Caption() As String Property Let Caption(ByVal Value As String) ``` Caption text. ### Alignment ```vb Property Get Alignment() As VBRUN.AlignmentConstants Property Let Alignment(ByVal Value As VBRUN.AlignmentConstants) ``` Horizontal text alignment. ### VerticalAlignment ```vb Property Get VerticalAlignment() As CCVerticalAlignmentConstants Property Let VerticalAlignment(ByVal Value As CCVerticalAlignmentConstants) ``` Vertical text alignment. See Common Enumerations. ### Picture ```vb Property Get Picture() As IPictureDisp Property Let Picture(ByVal Value As IPictureDisp) Property Set Picture(ByVal Value As IPictureDisp) ``` Picture. ### PictureAndCaption ```vb Property Get PictureAndCaption() As Boolean Property Let PictureAndCaption(ByVal Value As Boolean) ``` Whether to display both picture and caption simultaneously. Requires comctl32.dll 6.1 or later. ### WordWrap ```vb Property Get WordWrap() As Boolean Property Let WordWrap(ByVal Value As Boolean) ``` Whether to enable word wrap. ### Transparent ```vb Property Get Transparent() As Boolean Property Let Transparent(ByVal Value As Boolean) ``` Whether to use a transparent background (effective at run time). ### SplitButton ```vb Property Get SplitButton() As Boolean Property Let SplitButton(ByVal Value As Boolean) ``` Whether to display as a split button. Requires comctl32.dll 6.1 or later. ### SplitButtonAlignment ```vb Property Get SplitButtonAlignment() As CCLeftRightAlignmentConstants Property Let SplitButtonAlignment(ByVal Value As CCLeftRightAlignmentConstants) ``` Split button alignment. See Common Enumerations. ### SplitButtonNoSplit ```vb Property Get SplitButtonNoSplit() As Boolean Property Let SplitButtonNoSplit(ByVal Value As Boolean) ``` Whether the split button hides the split line. ### SplitButtonGlyph ```vb Property Get SplitButtonGlyph() As IPictureDisp Property Let SplitButtonGlyph(ByVal Value As IPictureDisp) Property Set SplitButtonGlyph(ByVal Value As IPictureDisp) ``` Drop-down arrow icon for the split button. ### Style ```vb Property Get Style() As VBRUN.ButtonConstants Property Let Style(ByVal Value As VBRUN.ButtonConstants) ``` Button style (standard or graphical). ### DisabledPicture ```vb Property Get DisabledPicture() As IPictureDisp Property Let DisabledPicture(ByVal Value As IPictureDisp) Property Set DisabledPicture(ByVal Value As IPictureDisp) ``` Disabled state picture. ### DownPicture ```vb Property Get DownPicture() As IPictureDisp Property Let DownPicture(ByVal Value As IPictureDisp) Property Set DownPicture(ByVal Value As IPictureDisp) ``` Pressed state picture. ### UseMaskColor ```vb Property Get UseMaskColor() As Boolean Property Let UseMaskColor(ByVal Value As Boolean) ``` Whether to use mask color. ### MaskColor ```vb Property Get MaskColor() As OLE_COLOR Property Let MaskColor(ByVal Value As OLE_COLOR) ``` Mask color. ### DrawMode ```vb Property Get DrawMode() As CmdDrawModeConstants Property Let DrawMode(ByVal Value As CmdDrawModeConstants) ``` Draw mode. ### Value ```vb Property Get Value() As Boolean Property Let Value(ByVal NewValue As Boolean) ``` Button value; setting to True triggers the Click event. ### Pushed ```vb Property Get Pushed() As Boolean Property Let Pushed(ByVal Value As Boolean) ``` Whether the control is in a pressed state. ### Hot ```vb Property Get Hot() As Boolean ``` Whether the control is in a hot state. Read-only. ### DroppedDown ```vb Property Get DroppedDown() As Boolean Property Let DroppedDown(ByVal Value As Boolean) ``` Whether the split button is dropped down. ### hWnd / hWndUserControl / Font / Enabled / OLEDropMode / MousePointer / MouseIcon / MouseTrack / RightToLeft / RightToLeftLayout / RightToLeftMode See common properties. ### Name / Tag / Parent / Container / Left / Top / Width / Height / Visible / ToolTipText / HelpContextID / WhatsThisHelpID / DragIcon / DragMode See standard extender properties. ## Methods ### Refresh ```vb Public Sub Refresh() ``` Forces a repaint. ### PerformClick ```vb Public Sub PerformClick() ``` Simulates a user clicking the button. ### SetShield ```vb Public Function SetShield(ByVal State As Boolean) As Long ``` Sets the UAC shield icon. Returns 1 on success. Requires comctl32.dll 6.1 or later. ### GetIdealSize ```vb Public Sub GetIdealSize(ByRef Width As Single, ByRef Height As Single) ``` Gets the ideal size for the button. Requires comctl32.dll 6.0 or later. ### OLEDrag ```vb Public Sub OLEDrag() ``` ### Drag / ZOrder / SetFocus / Move See standard methods. ## Events ### Click ```vb Public Event Click() ``` Single click. ### DblClick ```vb Public Event DblClick() ``` Double click. ### HotChanged ```vb Public Event HotChanged() ``` Hot state changed. ### DropDown ```vb Public Event DropDown() ``` Fired when the split button drops down. ### OwnerDraw ```vb Public Event OwnerDraw(ByVal DisplayAsDefault As Boolean, ByVal ItemAction As Long, ByVal ItemState As Long, ByVal hDC As LongPtr, ByVal Left As Long, ByVal Top As Long, ByVal Right As Long, ByVal Bottom As Long) ``` Owner-draw event. ### KeyDown / KeyUp / KeyPress ### MouseDown / MouseMove / MouseUp / MouseEnter / MouseLeave ### OLECompleteDrag / OLEDragDrop / OLEDragOver / OLEGiveFeedback / OLESetData / OLEStartDrag ## Code Examples ### Basic Usage ```vb ' Set as default button CommandButtonW1.Default = True CommandButtonW1.Caption = "OK" ' Graphical button CommandButtonW1.Style = vbButtonGraphical Set CommandButtonW1.Picture = LoadPicture("ok.bmp") ' Picture and caption coexistence CommandButtonW1.PictureAndCaption = True ``` ### Split Button ```vb CommandButtonW1.SplitButton = True Private Sub CommandButtonW1_DropDown() ' Display context menu PopupMenu mnuOptions End Sub ``` ### UAC Shield Icon ```vb CommandButtonW1.SetShield True ``` ### Get Ideal Size ```vb Dim w As Single, h As Single CommandButtonW1.GetIdealSize w, h CommandButtonW1.Width = w CommandButtonW1.Height = h ``` --- --- url: /en/packages/vbccr/buttons/commandlink.md description: >- CommandLink Control - VBCCR Development Manual, complete API reference based on source code --- # CommandLink Control Windows CommandLink button control that displays a caption, hint text, and an optional icon. ## Enumerations No control-specific enumerations. ## Properties ### Default ```vb Property Get Default() As Boolean Property Let Default(ByVal Value As Boolean) ``` Whether this is the default button. ### Cancel ```vb Property Get Cancel() As Boolean Property Let Cancel(ByVal Value As Boolean) ``` Whether this is the cancel button. ### VisualStyles ```vb Property Get VisualStyles() As Boolean Property Let VisualStyles(ByVal Value As Boolean) ``` Whether to enable visual styles. ### BackColor ```vb Property Get BackColor() As OLE_COLOR Property Let BackColor(ByVal Value As OLE_COLOR) ``` Background color. ### ImageList ```vb Property Get ImageList() As Variant Property Let ImageList(ByVal Value As Variant) Property Set ImageList(ByVal Value As Variant) ``` Associated ImageList control. ### Caption ```vb Property Get Caption() As String Property Let Caption(ByVal Value As String) ``` Caption text. ### Hint ```vb Property Get Hint() As String Property Let Hint(ByVal Value As String) ``` Hint text (description text below the caption). ### Picture ```vb Property Get Picture() As IPictureDisp Property Let Picture(ByVal Value As IPictureDisp) Property Set Picture(ByVal Value As IPictureDisp) ``` Icon. ### Transparent ```vb Property Get Transparent() As Boolean Property Let Transparent(ByVal Value As Boolean) ``` Transparent background (effective at run time). ### RightToLeft ```vb Property Get RightToLeft() As Boolean Property Let RightToLeft(ByVal Value As Boolean) ``` Right-to-left display. ### RightToLeftLayout ```vb Property Get RightToLeftLayout() As Boolean Property Let RightToLeftLayout(ByVal Value As Boolean) ``` Right-to-left mirrored layout. ### RightToLeftMode ```vb Property Get RightToLeftMode() As CCRightToLeftModeConstants Property Let RightToLeftMode(ByVal Value As CCRightToLeftModeConstants) ``` Right-to-left mode. See Common Enumerations. ### Value ```vb Property Get Value() As Boolean Property Let Value(ByVal NewValue As Boolean) ``` Button value; setting to True triggers the Click event. ### Pushed ```vb Property Get Pushed() As Boolean Property Let Pushed(ByVal Value As Boolean) ``` Whether the control is in a pressed state. ### Hot ```vb Property Get Hot() As Boolean ``` Whether the control is in a hot state. Read-only. ### hWnd / hWndUserControl / Font / Enabled / OLEDropMode / MousePointer / MouseIcon / MouseTrack See common properties. ### Name / Tag / Parent / Container / Left / Top / Width / Height / Visible / ToolTipText / HelpContextID / WhatsThisHelpID / DragIcon / DragMode See standard extender properties. ## Methods ### Refresh ```vb Public Sub Refresh() ``` Forces a repaint. ### PerformClick ```vb Public Sub PerformClick() ``` Simulates a user click. ### SetShield ```vb Public Function SetShield(ByVal State As Boolean) As Long ``` Sets the UAC shield icon. Returns 1 on success. ### GetIdealHeight ```vb Public Function GetIdealHeight() As Single ``` Gets the ideal height for the control. ### OLEDrag ```vb Public Sub OLEDrag() ``` ### Drag / ZOrder / SetFocus / Move See standard methods. ## Events ### Click ```vb Public Event Click() ``` Single click. ### DblClick ```vb Public Event DblClick() ``` Double click. ### HotChanged ```vb Public Event HotChanged() ``` Hot state changed. ### KeyDown / KeyUp / KeyPress ### MouseDown / MouseMove / MouseUp / MouseEnter / MouseLeave ### OLECompleteDrag / OLEDragDrop / OLEDragOver / OLEGiveFeedback / OLESetData / OLEStartDrag ## Code Examples ### Basic Usage ```vb ' Set up a CommandLink CommandLink1.Caption = "Save File" CommandLink1.Hint = "Save the current document to disk" CommandLink1.Default = True ' Set UAC shield icon CommandLink1.SetShield True ' Get ideal height and adjust CommandLink1.Height = CommandLink1.GetIdealHeight ``` ### Responding to Clicks ```vb Private Sub CommandLink1_Click() MsgBox "You clicked: " & CommandLink1.Caption End Sub ``` --- --- url: /en/packages/vbccr/author.md description: >- Official documentation for VBCCR - VB Common Controls Replacement library, covering StdEXE/OCX usage guide, OCX2StdEXE tool, compilation options and version history. --- # Common Controls Replacement **\[official document]** This page is a translation of the official documentation written by the original author. The original Word document was converted to Markdown using AI by woeoio. ## Utility Note- This document accompanies version 3.3 of the StdEXE utility. The changelog of the utility is in a table at the end of this document. Version 3.3 adds the capability of using VBCCRxx.OCX up to version 1.7 and VBFLXGRDxx.OCX up to the new version 1.6. Since November 2012, a VBForums user named Krool has been developing a set of replacements for the Windows Common Controls. Replacing these controls has been discussed by many and successfully done by none, until now. Krool has been working on this primarily by himself with lots of debugging and feedback within the forum. In the middle of 2017 Krool took on the task of addressing a replacement for the MSFlexGrid control. He decided to do this development in a separate set of threads on the forum although it is very similar to the other replacement controls. This package hopefully will offer you some tips on how to set up and use these controls in your program and guide you to reduce or eliminate dependencies on any files other than your code. Krool’s controls will show up in your Toolbox similar to what is shown below. They function just like other controls that are built-in to VB6. Just drop them onto forms or onto other controls. Those that you can add are shown below. What can these new controls do for you and programs you write or maintain? * They use Unicode. If you look on the Internet you will find a control here and a control there which use Unicode but Krool’s two packages allow you to do 34 Windows common controls in one cohesive package. * They have enhancements beyond what is found in the common controls VB6 and VBA programmers have been using for years. * They can use themes, a complicated set of things made simpler here so that each of your programs can have a modern look and not look like it came out of Windows 95. * The controls can be embedded into your code so that your final EXE file has no dependencies and is just the one executable file that does not require registration or installation (e.g., you could run it from a thumb drive). Alternatively, it can use the traditional control versions (using .OCX files) but with ’side-by-side’ so that the .OCX files don’t have to be registered on the end-user’s PC but rather reside in your program’s folder. These two techniques enable you to have truly portable solutions for your users. * Krool’s code gets more stable all the time but users and the author are available to help with troubleshooting, inserting new features, etc. all the time. * I have included in this package a user guide, not to each of the controls themselves but the packages in their entirety (this document). * A utility named OCX2StdEXE is included that helps you keep up-to-date on the latest controls but also to enable you to use the OCX versions for your program development but use the StdEXE version to make the compiled code program. * The EXE file is totally self-contained and has no external dependencies. It does not need an installer on the end-user’s PC and it does not need to be distributed with an .OCX control file that needs t be registered on the end-user’s PC. * Using Krool’s StdEXE controls (not the traditional .OCX control file) in the IDE is not completely safe although he has worked hard to minimize the crashes in the IDE. Developing in the IDE with the .ocx version is safer and much faster and this utility enables you to have this benefit while at the same time producing you final code with all of the controls embedded in the program, requiring no dependencies. * Using the StdEXE versions of the controls in the IDE not only has some stability risks but it causes the controls code to be re-compiled every time you compile your program (on my PC using the .ocx version causes compile on a typical program to be less than 3 seconds but with the StdEXE controls it takes 25 seconds. Doing this once is okay but gets really cumbersome to do this over and over during development. With the OCX2StdEXE utility you develop using the .ocx version (speed and stability) and then finally compile with the StdEXE to get the file size and no-dependency benefits. ## User Guide Krool has a package of routines that do an incredible number of things but there are many things the programmer should understand to fully utilize these packages. Items addressed include: * Installation * The two different approaches, compiled .OCX controls and controls embedded into your program that get compiled each time with your code. How to choose which version to use and why? Can or should you use both of them? * Set-up * How to set up for the frequent updates to minimize the hassles of frequent updates as bugs are fixed and features are added. * Required type libraries. * What else do you need to use these control packages? * What are visual themes and should I use them? How? * What does ’side-by-side mean? Should I use this and how? * What are manifests, should I use them and how should I use them? ## Introduction VB6 controls come in two versions. The simplest is when the source code for the control is in your program and when your code is compiled the code for the control is compiled with it. The compiled code for the control becomes part of your program. Your program is standalone and does not rely on any external files other than those included with Windows in order to run nor do any files need to be copied to or registered on the users’ PC’s. The disadvantage of this method is that the control’s code must be compiled every time you compile your code as you are developing the program. Also, most companies who author controls do not want to give away their code so they won’t distribute the source code for each control. Thus, this method of making controls is not very common. The other way to do controls is to compile one or more controls into a file that has an OCX extension, (which stands for OLE Control eXtension or just ActiveX controls). The programmer who uses the OCX file never sees the source code and the code doesn’t need to be compiled over and over. One of the disadvantages of this type of control package is that the controls are not a part of the program and must be sent to each end-user and, for reasons well beyond this document, the OCX file must be registered on each user’s computer (we’ll get to side-by-side later). Krool produced the first version of the Common Controls Replacement in late 2012. These were the un-compiled versions of source code that you would include in your code. He calls this version the StdEXE which presumably means that the standard versions of these controls get compiled into your EXE file. A bit over 5 years later (January 2017) he started providing the same controls but in the pre-compiled OCX version. So now we programmers have the same controls available in both forms. There is no user guide for how to use each of the controls but since each of the controls is an enhanced replacement for other common controls it can be argued that such handholding is not needed for the largely very veteran VB6 programmers. However, there are several other aspects of these control sets that without some support makes them more difficult to fully use than they have to be. Hopefully this document addresses some of those points. Well after Krool developed his controls package of common controls he decided to add another one that had been left out of his package, a replacement for the MSFlexGrid control. He decided that although there is a lot of commonality with the first package, it is a separate package and use of it with the original package can be done but it can be confusing. When using the StdEXE version of either set of controls, you need a type library, ’OLEGuids and interface definitions’, while you are in the IDE. Also, when using the StdEXE version of the FlexGrid control, another type library is required. OCX versions do not require type libraries because in essence they are included in the OCX file. One of the major advantages of Krool’s controls is that they are designed with the capability of using ’visual styles’ so that your programs don’t look like they came out of Windows 95. However, in order to use these styles you need to now how to turn this feature on and for many of us this is not intuitively obvious. Once it is turned on, though, it is really impressive. If you use the OCX version of the controls you have to distribute the OCX file to your users with your program. Up until when VB6 came out Windows was designed such that these pre-compiled controls, dynamic link libraries, device drivers, etc. would all be registered on each user’s system and only one version (ostensibly the latest one) would be one each user’s system so that once installed and registered, many programs could make use of the same registered code. This was designed to save space on the hard drive, reduce memory usage, etc. but it caused many more problems than it solved. By the time VB6 came out, a new system had been designed and was being implemented to enable programs to use the centrally-registered files or for a program to have its own support files of its own, not copied to the central repository (the Windows System folder) and registered but instead included ’side by side’ with the program. If you use the StdEXE version of the controls you don’t need this (at least for these controls) because all of the code is compiled into yours but if you use the OCX version this side-by-side solution may be desirable because it enables you to distribute programs that don’t need to be installed and that don’t have components that must be installed and registered. If you use the StdEXE version of the controls there are no ’versions’ and when Krool issues an update you just copy the new files over the old ones and keep going. However, the OCX version does have versions (like all pre-compiled code, see the long paragraph above) and it is not a trivial matter to modify each of your programs to use the newer version. My utility takes care of this for you. Since Krool provides both the OCX and the StdEXE versions of the controls, it is possible to improve your programming experience by enabling you to use the OCX version during development (easier to use and much shorter compile time) but then do the final compile with the StdEXE version to get all of the control code included in the program such that there is no OCX file to include with the program and you don’t have to deal with the side-by-side complications. My utility takes care of this for you as well. ## Overview There are two versions of each control set; one is a single file with the extension of OCX that contains the pre-compiled version of the controls. This would need to be registered on your (programmer) computer. It is available [here](https://www.vbforums.com/showthread.php?698563-CommonControls-\(Replacement-of-the-MS-common-controls\)) on VBForums. You reference this in your program and then you have access to all of the controls. This is simple from a programmer’s perspective but when you distribute your finished EXE or DLL file you have to include the OCX file. Further, this file either needs to be part of a ’side-by-side’ solution or it needs to be copied to and registered on the user’s PC. The other approach Krool calls the StdEXE version. In this one has all of the code in a large group of files (162 currently in 38 folders) that are all un-compiled and have to be added as modules to your program. The latest version of this package is available [here](https://www.vbforums.com/showthread.php?698563-CommonControls-\(Replacement-of-the-MS-common-controls\)) on VBForums. Each time you compile your program all of these controls get compiled too. There is a major hassle of even knowing which files to include in your program for which controls, some of the names of subs, functions and variables can conflict with names you use and compiling each time of all of this control code takes a long time. I have a fairly fast PC and just compiling the ComCtlsDemo program Krool provides takes over 25 seconds. I compile a lot in VB6 as I code, partly just to check syntax and logic errors, and a compile time of 25+ seconds is very irritating especially when I know I can get the same code to compile in the OCX version in under 3 seconds. I love the fact that there are no external dependencies in the final executable but I hate the compile time. If only there was a way to use the OCX version with its fast compile times during development but a final compile using the internal controls to eliminate the need to have a separate OCX file to distribute with the program. My utility does that. Also, there are many updates to these controls. The un-compiled files (the StdEXE version) really don’t have version numbers and as long as you copy the latest files over the earlier ones in the same location you won’t have any issues. However, this is not true of the OCX version. I put mine in C:\Windows\SysWOW64 and as long as we have the same version we can just copy the new OCX file over the old one. But there have been new features added over time so we have had versions 1.1, 1.2, 1.3, 1.4, 1.5, 1.6 and now 1.7. If you developed a program using version 1.6 controls you will have a problem using version 1.7 controls because changes have to be made to each project file, each control file in that project that uses Krool’s controls and the manifest if you use one. My utility takes care of that, allowing you to switch from any OCX version to any other OCX version of the CommonControls that are installed on your PC (including the standalone FlexGrid controls). ## Controls Included Below is a list of controls found in Krool’s packages. All are in the Common Controls replacement package except for VBFlexGrid which is in the VBFlexGrid Control package. | | | | | | -------------- | ---------- | ------------- | --------------- | | Animation | FrameW | MCIWnd | SysInfo | | CheckBoxW | HotKey | MonthView | TabStrip | | ComboBoxW | ImageCombo | OptionButtonW | TextBoxW | | CommandButtonW | ImageList | Pager | ToolBar | | CommandLink | IPAddress | ProgressBar | TreeView | | CommonDialog | LabelW | RichTextBox | UpDown | | CoolBar | LinkLabel | Slider | VirtualBoxCombo | | DTPicker | ListBoxW | SpinBox | VListBox | | FontCombo | ListView | StatusBar | VBFlexGrid | If you have any programming experience, you have undoubtedly seen and used many of these controls. Once you get Krool’s system installed, usage is quite easy since the controls behave very similarly to existing controls. We will mainly cover how to get each of the systems installed and set-up to use. ## Terminology Krool’s controls are wonderful but many of the terms used within and around his packages can be very confusing (to me at least). Here are my interpretations of some of the terms. **ActiveX** - Wikipedia [article](https://en.wikipedia.org/wiki/ActiveX). This is a software framework instituted by Microsoft in 1996 using the earlier OLE and COM technologies. For this document we will consider ActiveX as the basis of our controls. **Control** - A component represented by an icon in your Toolbox that can be placed on a form. Most are visible but some, such as a Timer, are not. The simplest ones in VB6 are included in the as-installed VB6 program package. Others, such as Krool’s controls and many others from Microsoft and other vendors, must be added. For amore information on making your own controls please see [this](https://pages.cpsc.ucalgary.ca/~saul/vb_examples/index.html) web page and especially tutorial #10. **OCX** - Often, all of us use controls that are pre-compiled into files having an extension of .OCX (which stands for OLE Control eXtension or just ActiveX controls). These files have to be registered on the developer’s PC and they have to be distributed and registered on each user of the developer’s program(s). One .OCX file can contain multiple controls. The programmer (you) needs to have an OCX installed and registered on his system but the user needs to have the OCX file on his system too, generally registered but sometimes ’side-by-side’ with the compiled program that is being run which uses the OCX control(s). **StdEXE** - Krool uses this term to designate the other method of including ActiveX controls in a program. There are a number of source code files including standard and class modules, property page files etc. that get compiled into an OCX control. Alternatively, all of these can be distributed by the author and put into each of our programs as source code. Normally the authors of a controls package do not want to distribute the source code for their controls for a variety of reasons but Krool has elected to do that with his packages. The advantage of doing this is that your program has all of the control code compiled within it and thus no files need to be distributed or registered for your program to work. Everything is self-contained in your compiled code. A drawback of this from the programmer’s perspective is that all of the controls code gets compiled over and over as you develop your program and compile it over and over. **VBCCRxx** - VBCCR stands for Visual Basic Common Controls Replacement and ’xx’ refers to the OCX version which at present can be 1.1 (xx=11), 1.2, 1.3, 1.4, 1.5 or 1.6 (xx=16). As code that is distributed in compiled form gets modified and expanded over time, the author (Krool) has to issue different versions and each must be on the user’s PC (and the programmer’s PC). For example, suppose you write a program that uses VBCCR16.ocx and you send it to a colleague who has VBCCR13.ocx installed but not VBCCR16.ocx. It won’t run because it is looking fro the other ocx file when it starts up. That’s a disadvantage of OCX files. If you use the StdEXE version, the code is compiled directly into your code and you don’t have to distribute, install or register any external file to use the controls. The main advantages of the OCX version over the StdExE versions are a) compile time for your programs is almost 10x faster because the form code doesn’t need to be re-compiled each time and b) all of the various .BAS, .CTL, .PAG files that make up each control don’t clutter up the programmers list of files to manage. **ComCtlsDemo** - This is a sample program that shows each of Krool’s controls. This file is updated regularly and is always found at the bottom of the first post in [this](http://www.vbforums.com/showthread.php?698563-CommonControls-\(Replacement-of-the-MS-common-controls\)) thread on VBForums. This package uses the StdEXE concept of compiling the code for all of the controls into the executable. This is much more than just a sample file. The source code in this file is all there is for his package and you will use it (or most of it) when you make your own programs that use his controls. It doesn’t have (or need) version numbers like the OCX version since there are no files to register on the developer or user’s PC’s (it is source code that gets embedded ina program each time the program is compiled). I download most every update and to avoid confusion I rename each of the .zip files to a file on my hard drive with the date of the file in the name of the .zip file. Because of VBForum size limitations, he posts the file with a Word extension of .docx but it is really a .zip file so when you download it you do a Save As and then cut the .docx off of the filename. At the time of this writing, the latest one Krool posted is 11 November 2018 (look at the small italics line at the very bottom of the post below the download link) and the file to download is named ComCtlsDemo.zip.docx so when I downloaded that file I renamed it to ComCtlsDemo 2018-11-11.zip on my hard drive. **VBCCR OCX Version** - After about 4? years of having just the StdEXE version, Krool released a pre-compiled version called VBCCRxx.OCX where xx is the version number. The earliest one is version 1.1 so the first file was VBCCR11.ocx. As of this writing, the latest version is 1.6.13 so the file is VBCCR16.ocx. The latest version is always at the bottom of the 1st post in [this](http://www.vbforums.com/showthread.php?841929-VB6-ActiveX-CommonControls-%28Replacement-of-the-MS-common-controls%29\&p=5129155#post5129155) thread on VBForums. The .zip file online contains the .ocx file as well as some resource files (discussed below) related to ’side-by-side’ execution of the programmer’s EXE file and also making your programs themed so that what you display on-screen doesn’t look like it came out of Windows 95. I save the .zip file with it renamed to include the version number. For example, the latest one which is called ’VBCCR16.OCX.rar.docx’ was copied to my hard drive with the name ’VBCCR.OCX v1.6.13.rar’ (see above note for why the file is available with the .docx extension). In addition to containing the .ocx file, the zip file has all of the code in case you wanted to put make your own .ocx file (not recommended) or just to learn from what Krool has done. Copy the .ocx file to you Windows system folder. If you run 32-bit Windows this will typically be C:\Wnidows\System32 but if you run 64-bit Windows then your 32-bit folder for these types of files is C:\Windows\SysWOW64. (In the unlikely event that you put Windows somewhere other then C:\Window then use that path instead). Since you are copying to a system folder you will need elevated permission. It is okay to copy over a previous version if the xx is the same (in my example the xx is 16 so I can copy over the 1.6.12 or 1.6.11 versions) and if the xx is a new one (like for version 1.6.0) then there is no overwrite but you should use regsvr32 to register this control with your system. This .OCX file is loaded into your project using Ctrl-T in the VB6 IDE (or Project|Components) and selecting the appropriate control. For version 1.6 you would select ’VB Common Controls Replacement 1.6 Library’ by clicking the check mark next to it. With the reference to this OCX, all of the controls with show up in your toolbox for use like any other controls you can put on your forms. Because the .OCX version of the controls is pre-compiled, the controls aren’t compiled every time you compile your program like has to happen with the StdEXE version where the controls are embedded into your code. On the other hand, a drawback is that the .OCX file ahs to accompany your EXE or DLL file when you distribute it because it was not compiled into it. **Type Library** - To get Krool’s VBCCR and VBFlexGrid controls in the StdEXE versions (not the OCX versions) to work you need to use a type library he has provided called ’OLEGuids.tlb’ which is in the ’OLDGuids’ folder he distributes with each of the control packages. I copied oleguids.tlb into my system directory and then I can use Project|References to specify it by clicking on the check box next to ’OLE Guid and interface definitions’. The file he is currently distributing has a date stamp of 9 June 2017 so it hasn’t changed in some time. This file is only needed while you are developing your code if you use the StdEXE version. It does not need to be distributed with the final compiled program. (Note-If you use Krool’s controls with VBA you do ***not*** need this file because you have to use the OCX version which already has this type library compiled into it.) **Visual Styles (Themes)** - This started in XP but didn’t really didn’t see much use until Vista and alter. With visual styles you can get more modern-looking forms but since these came into vogue after VB6 came out, there is no simple method of using these in your VB6 programs. Krool’s code is set up to use these visual styles but without a couple of interesting steps you won’t get them. In any event his code provides Unicode and some enhanced features compared to the original controls but to get visual styles you have to specify this in a manifest and then embed the manifest into a resource file referenced by your program. It sounds harder than it is and I will cover how to do that later. 9Note- VBA doesn’t do styles **Side-by-Side Assemblies** - If your program requires a DLL or an OCX file to run, it can use one if it already exists on the user’s system, has been registered and is the right version. Starting around the time when VB6 came out, there was a movement to get away from this system to avoid what many call ’DLL Hell’ (Google that for some fun). To make a long story short, Windows allows programs to run without having to register support files as long as the support files are located along side the EXE or DLL file (or in a sub-folder of it). A lot of corporate users have their PC’s set to not allow any new programs to be installed by blocking registration of thee support files and this is one way around that. In order to specify that the support files are side-by-side you have to specify this in a manifest (see below). It used to be that it was okay to have the manifest in the same folder as the executable file or embed into the file but later versions of Windows strongly prefer the manifest file to be included in a resource file. All of this sound crazy but Krool provides some support for all of the compelxities and my utility (hopefully) takes the pain out of the rest. **Manifest File** - A manifest file is XML-based and can specify many things for Windows to do to control the program. An example is that you can specify in a manifest that the program needs to run with elevated privileges. For our situation, though, the manifest file is of use to use for 2 reasons: 1) we can tell Windows that we want to use version 6.0 f Microsoft’s CommonContrls dll file which is the one that give us the visual styles with Krool’s code and 2) we can tell give it information such that the .OCX file (if you use that instead of the StdEXE one) is side-by-side with the executable you will be making. This by itself is bad enough but Windows now wants this manifest file included in the program’s resource file. **Resource File** - You can put many things into a VB6 resource file (extension .RES) including icons, graphics images, international strings, etc. You can also put a manifest file and you will do exactly that to get the visual styles and/or the side-by-side stuff going. Krool provides two resource files with the OCX version, one for just side-by-side and one for side-by-side plus visual styles. In the StdEXE package there is a resource file in the Resources folder that provides for visual styles (don’t need side-by-side if you don’t use the .OCX version). A user named LaVolpe has a utility on VBForums ([here](http://www.vbforums.com/showthread.php?845909-VB6-Manifest-Creator-II)) that enables you to pull out the manifest information from a resource file, edit it and then put it back in. Hopefully you won’t have to use that utility (I use a part of LaVolpe’s code in my utility as discussed later). The point of defining it here is to ensure that the programmer knows that side-by-side and visual styles need to specify a resource file and that the resource file needs to specify these internally. **Windows System Folder** - The Windows system folder holds many system-related files including DLL’s, type libraries, registered controls etc. For 32-bit VB6 and 32-bit VBA, this folder can be one of two things. If you are using a 32-bit operating system this folder will be ’C:\Windows\System32’. Unfortunately if you are using a 64-bit Windows operating system, all of its 64-bit DLL’s, type libraries and controls go into the system32 folder (?) so Microsoft puts all of the 32-bit files like this into a folder named ’SysWOW64’ (**W**indows 32-bit **O**n **W**indows **64**-bit). All of the 32-bit files go into ’C:\Windows\SysWOW64’. If you are using all of this in 64-bit VBA you will only deal with the 64-bit Windows folder which is always ’C:\Windows\System32’. **VBFlexGrid** - Krool’s original controls include 35 controls but not a replacement for the MSFlexGrid control (Microsoft provides a file MSFLXGRD.OCX which Krool’s package upgrades and replaces). The approach he has taken is very similar to what he has done with the other controls. There are separate versions that are standalone like the VBCCR ComCtlsDemo package, this one called VBFlexGridDemo found [here](http://www.vbforums.com/showthread.php?848839-VBFlexGrid-Control-\(Replacement-of-the-MSFlexGrid-control\)), and the corresponding OCX version of it, VBFLXGRD12.OCX, found [here](http://www.vbforums.com/showthread.php?855931-VB6-ActiveX-VBFlexGrid-%28Replacement-of-the-MSFlexGrid-control%29\&p=5236525#post5236525). Both of these versions are independent of the VBCCRxx controls. My utility deals with these and the VBCCR controls as if they are all part of the same package. ## User Guide for the Programmer Below is a discussion of usage for each version. After that is a discussion of my recommended use which is a simple hybrid of each option that (hopefully) takes advantage of the best features of each option and then some. VBCCR - Two versions exist for this set of 33 controls (all of the ones in the previous table except the last one). Until now, programmers have had to decide whether to use either the StdEXE or OCX versions; there has been no way to use both of them. After the user guides for the two versions I will show you another, hopefully better, way of using these controls so you can take advantage of the easier and faster OCX version for development yet produce a final executable with the code for the controls in your control with the StdEXE version. ### VBCCR - StdEXE Version This is the version in which all of the control code is compiled into your program. You will include the appropriate source code in your program and when you compile the controls become part of your program. Getting the latest version - You might be tempted to think that there is a download available that has all of the controls, a user guide, etc. but that’s not the case. Krool has a demonstration project on the VBForums web site and from that you get access to all of his controls (interesting approach but it works’). Krools’ demo project with all of the controls has been [here](http://www.vbforums.com/showthread.php?698563-CommonControls-\(Replacement-of-the-MS-common-controls\)) since 10 Nov 2012. There are over 78 pages of comments and discussion in the thread. Most deal with various bugs and user questions and feature addition requests as Krool has worked the package for the past 9 years. The important thing is that at the bottom of the first post is a downloadable file named ’**ComCtlsDemo.zip.docx**’ which is always the latest version to download. It has the .DOCX extension because VBForums has a lower size limit on .ZIP files than .DOCX files and this file exceeds the file size limit for .ZIP files. It really is a .ZIP file so as you download it (or after) rename it by knocking off the .DOCX part of the name, leaving the file ComCtlsDemo.zip. The name of this file on the web site is always the same. I recommend that you look at the last line in this first post and note the date and then put the date in the filename. For example, I am looking at the first post and at the bottom it says that it was last edited by Krool on November 11, 2018 so when I right-click on the link I tell it to save it into a set of folders where I keep all of my downloaded archive files and I save it with the name ’**ComCtlsDemo 2018-11-11.zip**’ so I can differentiate it from prior copies I have downloaded. Now here is an important observation. ComCtlsDemo contain all of the files for the controls and these files are not supposed to be altered so you can put these files into a central location that all of your programs will access (a library). This location doesn’t need to change and you can always delete the existing files and put the newest version’s files in the same folders. Also, all of your programs access all of these files where they are so you don’t need to copy all of these files into your individual project folders. That greatly simplifies usage and updating for newer versions. Where to put the downloaded files when unzipping - I have a library folder into which I put all sorts of files for use in my programs. I do not put files into here that will change. This contains files I can use in all or my programs without modifications. In my Library folder I have a sub-folder for Controls & Forms. Within that I have a folder for Krool’s controls named VBCCR and in that I have made a sub-folder called ’Current’. Whenever I download the latest update from Krool, I first delete all the files and folders in Current and then I unzip the new files into Current. This is important because programs I am working on that already that use these controls will continue to find these controls in the same places and won’t even know they are the new versions. Fortunately Krool keeps the names of his files and folders the same as he debugs and adds features to the controls. So now that we have the files on our PC in a location where we can use them for all of our programs, we can just start using them. Right? Well, sort of. There are some additional steps to take in order to use his controls. Follow the steps below for any new or modified program you create. Type library - You need to be able to access a type library named ’OLEGuids.tlb’ that is included with Krool’s sample program. This file is in a sub-folder of Current named ’OLEGuids’. You will need this file during your editing and compiling but your compiled program doesn’t need it and you don’t distribute it with your executable. I put mine into my Windows System folder so I always know where it is and I register it in Windows 10 with regsvr32. Fortunately this type library file doesn’t change very often so you don’t have to do this step often. OLEGuids.tlb is dated 9 June 2017 so it hasn’t changed in 18 months. In VB6 you will use the commands Project | References to select this type library. If you have registered this file using regsvr32 then you can find it in the list of Available References with the name ’OLE Guid and interface definitions’ but if you haven’t registered it yet you can click on ’Browse’’ and go find it. Visual Styles - In order to use visual styles (themes) in your programs so they don’t look like old Windows programs you have to specify the use of Windows’ Common Controls library version 6.0 because it has support for visual styles. The way to do that is to include the specification for this in a manifest file. It used to be that you made a file including the name of your executable that had a ’.Manifest’ extension and when you distributed your program you included this file in the same folder as your executable file. Later versions of Windows discourage this but recommend that you include the manifest in the EXE file as part of an embedded resource file. VB6 can use resource files to hold a number of different things such as internationalization strings, icons, etc. in addition to manifests. So we have to get the visual style specification into a manifest and then get the manifest file inside of a VB6 resource file. In Krool’s package look in Current\Resources to find a file named ’Resources.res’ which is a resource file Krool made that contains the directions to enable visual styles (or theming). If you are not using a resource file for anything else you can simply copy this Resources.res file to wherever you project file (.VBP) resides. I will show you in a minute how to embed that in your project. But for now let’s consider what to do if you already have a resource file and we want to add our manifest information to that resource file (whether it already has manifest information in it or not). Please note that the VB6 IDE was not designed to use visual styles. [Here](http://www.vbforums.com/showthread.php?693111-VB6-IDE-solving-UAC-and-Visual-Style-issues\&highlight=) is a VBForums post by Krool that shows how to get a resource file with embedded manifest that will run VB6 with elevated UAC as well as incorporating visual styles. You don’t need this to use Krool’s controls but if you want to see the ’prettier’ forms then this may be worth it to you. Note that it involves using another utility called ResourceHacker to get the resource file into the VB6.EXE file. An easier approach is to get the file vb6.exe.manifest from [here](http://www.vbaccelerator.com/home/VB/Code/Libraries/XP_Visual_Styles/Using_XP_Visual_Styles_in_VB/article.asp) and put it into the same folder where you have vb6 (typically C:\Program Files (x86)\Microsoft Visual Studio\VB98). As far as using visual styles in your programs, I find it strange that the instructions to use visual styles are part of a manifest file which we have to embed into a resource file which is then embedded within our executable files. Krool supplies a resource file with visual styles in the Resources folder under Current that you can copy to your project and embed. Advanced resource/manifest/visual styles note - You may want other things in your resource file in addition to the visual styles setting. It is not a trivial thing to work with these files. The manifest part is XML and it is contained in a non-XML resource file. I have found another utility on VBForums by a user named LaVolpe ([here](http://www.vbforums.com/showthread.php?845909-VB6-Manifest-Creator-II)) that lets us make or edit a manifest from scratch or from a manifest file or extracted from a resource file so that we can edit it and then we can specify that it is put into a resource file. Below is a screenshot of LaVolpe’s utility running with Resources.res loaded. I highlighted the section that specifies Windows Common Controls version 6.0.0.0 to be used. This is what specifies visual styles. In general for a new program you should be able to just copy the Resources.res to your project folder and use it without having to edit it. BTW, you don’t *need* this file but you won’t get any of the modern looking controls in your program without it. So now you have a resource file that specifies using visual styles. How do we get it into our project? In VB6, go to AddIns | AddIn Manager’ and you will see something like the following. Select ’VB6 Resource Editor’ and ensure that ’Loaded/Unloaded’ and ’Load On Startup’ are both checked. Then, back in your main project go to Project | Add New Resource File’ and then select your .res file from the dialog box that pops up. Now your resource file should show up in the navigator pane under Related Documents. Side-by-Side - One reason for using the StdEXE version is that unless you use some other specialized controls or other files, your executable has no dependencies so there is no reason to be concerned about side-by-side. I will discuss it more in the user guide for the OCX version of Krool’s controls. Files to Include in Your Project - Each of the controls has a number of files specific to the control which need to be inserted into your project as shown below. | **Control** | **Files in Current Folder** | | -------------------------------------- | --------------------------------------------------------------------------- | | Animation | Builds\Animation\Animation.ctl | | | Builds\Animation\PPAnimationGeneral.pag | | CheckBoxW | Builds\CheckBoxW\CheckBoxW.ctl | | ComboBoxW | Builds\ComboBoxW\ComboBoxW.ctl | | CommandButtonW | Builds\CommandButtonW\CommandButtonW.ctl | | CommandLink | Builds\CommandLink\CommandLink.ctl | | | Builds\CommandLink\PPCommandLinkGeneral.pag | | CoolBar | Builds\CoolBar\CbrBand.cls | | | Builds\CoolBar\CbrBandProperties.cls | | | Builds\CoolBar\CbrBands.cls | | | Builds\CoolBar\CoolBar.ctl | | | Builds\CoolBar\PPCoolBarBands.pag | | | Builds\CoolBar\PPCoolBarGeneral.pag | | DTPicker | Builds\DTPicker\DTPicker.ctl | | | Builds\DTPicker\PPDTPickerGeneral.pag | | FontCombo | Builds\FontCombo\FontCombo.ctl | | FrameW | Builds\FrameW\FrameW.ctl | | HotKey | Builds\HotKey\HotKey.ctl | | ImageCombo | Builds\ImageCombo\ImageCombo.ctl | | | Builds\ImageCombo\ImcComboItem.cls | | | Builds\ImageCombo\ImcComboItems.cls | | | Builds\ImageCombo\PPImageComboGeneral.pag | | ImageList | Builds\ImageList\ImageList.ctl | | | Builds\ImageList\ImlListImage.cls | | | Builds\ImageList\ImlListImages.cls | | | Builds\ImageList\PPImageListGeneral.pag | | | Builds\ImageList\PPImageListImages.pag | | IPAddress | Builds\IPAddress\IPAddress.ctl | | LabelW | Builds\LabelW\LabelW.ctl | | LinkLabel | Builds\LinkLabel\LinkLabel.ctl | | | Builds\LinkLabel\LlbLink.cls | | | Builds\LinkLabel\LlbLinks.cls | | | Builds\LinkLabel\PPLinkLabelGeneral.pag | | ListBoxW | Builds\ListBoxW\ListBoxW.ctl | | ListView | Builds\ListView\ListView.ctl | | | Builds\ListView\LvwColumnHeader.cls | | | Builds\ListView\LvwColumnHeaders.cls | | | Builds\ListView\LvwGroup.cls | | | Builds\ListView\LvwGroups.cls | | | Builds\ListView\LvwListItem.cls | | | Builds\ListView\LvwListItems.cls | | | Builds\ListView\LvwListSubItem.cls | | | Builds\ListView\LvwListSubItems.cls | | | Builds\ListView\LvwVirtualListItem.cls | | | Builds\ListView\LvwVirtualListItems.cls | | | Builds\ListView\PPListViewGeneral.pag | | | Builds\ListView\PPListViewImageLists.pag | | | Builds\ListView\PPListViewSorting.pag | | MCIWnd | Builds\MCIWnd\MCIWnd.ctl | | MonthView | Builds\MonthView\MonthView.ctl | | | Builds\MonthView\PPMonthViewGeneral.pag | | OptionButtonW | Builds\OptionButtonW\OptionButtonW.ctl | | Pager | Builds\Pager\Pager.ctl | | | Builds\Pager\PPPagerGeneral.pag | | ProgressBar | Builds\ProgressBar\PPProgressBarGeneral.pag | | | Builds\ProgressBar\ProgressBar.ctl | | RichTextBox | Builds\RichTextBox\PPRichTextBoxGeneral.pag | | | Builds\RichTextBox\RichTextBox.ctl | | | Builds\RichTextBox\RichTextBoxBase.bas | | Slider | Builds\Slider\PPSliderAppearance.pag | | | Builds\Slider\PPSliderGeneral.pag | | | Builds\Slider\Slider.ctl | | SpinBox | Builds\SpinBox\PPSpinBoxGeneral.pag | | | Builds\SpinBox\SpinBox.ctl | | StatusBar | Builds\StatusBar\PPStatusBarGeneral.pag | | | Builds\StatusBar\PPStatusBarPanels.pag | | | Builds\StatusBar\SbrPanel.cls | | | Builds\StatusBar\SbrPanelProperties.cls | | | Builds\StatusBar\SbrPanels.cls | | | Builds\StatusBar\StatusBar.ctl | | SysInfo | Builds\SysInfo\SysInfo.ctl | | TabStrip | Builds\TabStrip\PPTabStripGeneral.pag | | | Builds\TabStrip\PPTabStripTabs.pag | | | Builds\TabStrip\TabStrip.ctl | | | Builds\TabStrip\TbsTab.cls | | | Builds\TabStrip\TbsTabs.cls | | TextBoxW | Builds\TextBoxW\PPTextBoxWText.pag | | | Builds\TextBoxW\TextBoxW.ctl | | ToolBar | Builds\ToolBar\PPToolBarButtons.pag | | | Builds\ToolBar\PPToolBarGeneral.pag | | | Builds\ToolBar\TbrButton.cls | | | Builds\ToolBar\TbrButtonMenu.cls | | | Builds\ToolBar\TbrButtonMenus.cls | | | Builds\ToolBar\TbrButtonProperties.cls | | | Builds\ToolBar\TbrButtons.cls | | | Builds\ToolBar\ToolBar.ctl | | TreeView | Builds\TreeView\PPTreeViewGeneral.pag | | | Builds\TreeView\TreeView.ctl | | | Builds\TreeView\TvwNode.cls | | | Builds\TreeView\TvwNodes.cls | | UpDown | Builds\UpDown\PPUpDownGeneral.pag | | | Builds\UpDown\UpDown.ctl | | VirtualCombo (on or after 15 Aug 2020) | Builds\VirtualCombo.ctl Builds\VirtualCombo.ctx Builds\VirtualComboBase.bas | | VListBox (on or after 15 Aug 2020) | Builds\VListBox\VListBox.ctl Buids\VListBox\VListBox.ctx | If you want any individual control to be available in your project, from within the IDE, press Ctrl-D and then navigate to the appropriate folder and highlight all of the files in the folder to import and press Enter. A challenge is that Krool’s package includes all of the controls and it is unlikely you will need all of them. The demo program utilizes all of them and the EXE file resulting from this is 4.2 MB so if you include all of the controls in your program you will add about 4 MB to the file size. In these days of multi-gigabyte RAM and hard drives this may not be the consideration that it once was. There are also some files that have to be present whether you use one control or all of them. These are: | | | ------------------------------------------------- | | Builds\ComCtlsBase.bas | | Builds\VTableHandle.bas | | Builds\VTableSubclass.cls (only until 5 Jan 2020) | | Builds\ISubclass.cls | | Common\Common.bas | | Common\VisualStyles.bas | Finally, if you use the control MCIWnd.ctl or property pages for CoolBar, Imagelist, RichTextBox or StatusBar you must also include the file ’Builds\CommonDialog.cls’ in your project. You may be tempted to not include code for controls you are not using. You do save some size in your final executable file but just know that the control(s) left out do not appear in your toolbox for even possible use without including the above code for the individual controls. If you are sure you won’t use a given control it is okay to leave it out. Each of the controls is independent of the others. There is one more file in Krool’s ComCtlsDemo package, Common\Startup.bas, which is really for the demo program. You don’t need this file but there are some concepts in that file that need to be part of your program. Sub Main - Krool’s controls rely on some Microsoft code that needs to run before any forms are loaded or shown. To use the new controls you must specify the Startup Object as Sub Main instead of any Form and you must have the correct start-up code in Sub main before you reference any control. This is set in Project | Properties on the General tab. If you don’t have a start-up routine in a Sub named Main you need to put one in your program. You need to have a call to one of Krool’s routines to provide protection for callbacks etc. built into his programs so that you don’t crash in the IDE. Also, there is some start-up code required for your program to use the visual styles enabled by using Microsoft’s Common Controls 6.0. Thus, the first two lines in your Sub Main should be: ```vb Call ComCtlsInitIDEStopProtection ' in Builds\ComCtlsBase.bas ' above is only needed if you are using Krool’s package before 13 Aug 2020) Call InitVisualStyles ' in Common\VisualStyles.bas ``` Now you can put the rest of your code to show Forms, do calculations etc. Unless you use other .OCX control files, your final executable will contain all of the code including the controls so the executable is standalone and does not need anything other than the standard VB6 support files included with Windows by Microsoft. You may have some issues with names of subroutines and variables being the same as ones that you use. If you use the .OCX version of the controls, most of that is hidden and is not a concern. However, when you include all of the various files for the controls to be compiled within your program, you now have 153 new files and you may have some naming conflicts. If you decide to keep your names and change Krool’s, just know that every time you download and use and update your will have to edit his files to rename these (not just the name of the subroutine but every other routine that calls it). I reluctantly decided to change some conflicting names in my code so I wouldn’t have to keep updating his files with new downloads. I don’t like this but it is a small price to pay for these controls. Note - I don’t use the above approach because I don’t like the long compile times although I do like a fully self-contained executable. That’s part of the reason I wrote the utility I will discuss later. It allows you to develop using the .OCX version (compiles so much faster) and then do the final compile through my utility with the StdEXE version so you have the self-contained executable. ### VBCCR OCX Version Guide Krool has the equivalent of the StdEXE package for VBCCR in a pre-compiled form as a more typical single controls file with an OCX extension found [here](http://www.vbforums.com/showthread.php?841929-VB6-ActiveX-CommonControls-%28Replacement-of-the-MS-common-controls%29\&p=5129155#post5129155). Advantages versus the StdEXE-based controls are: 1) simpler to use as it needs one .OCX file instead of 153 individual files to include in each of your programs, 2) compile times for your program are faster since the OCX file is already compiled and 3) programmers are used to OCX systems available from Microsoft and other vendors. Disadvantages are: 1) the OCX file has to accompany the executable to the users, 2) the OCX file must either be registered on the user’s PC or employ a more-complicated side-by-side solution. Getting the latest version - From [this site](http://www.vbforums.com/showthread.php?841929-VB6-ActiveX-CommonControls-%28Replacement-of-the-MS-common-controls%29\&p=5129155#post5129155) download the file at the bottom of the first post. We are now in version 1.6 of the OCX version of the controls so the file is listed for download as ’VBCCR16.OCX.rar.docx’. It has the .docx extension due to size limitations of other types of files on VBForums. It is really a RAR file. I include the current version in the filename when I download the file so I can keep track of the various downloads. The first post says the current version if 1.6.13 so when I downloaded this file is used SaveAs and I named it ’VBCCR16.OCX v1.6.13.rar’ (I drop the .docx extension and add the new version number). Inside this file is the .OCX file and a zip file containing the source code if you wanted to generate your own version of the .OCX (I don’t recommend this because it will now be a separate package from Krool’s; it basically has the same files that the StdEXE version has). Use of the files in your program - Now in your new program you will use all of these files. Press Ctrl-T or do Project|Compenents and select ’VB Common Controls Replacement 1.6 Library’ (that’s file vbccr16.ocx). To get these into a VBA project do Tools | Additional Controls’ in the VBA IDE. Finally, you need to set the resource file that contains the manifest to enable visual styles and optionally side-by-side (VB6 only; not applicable for VBA). There are also 2 VB6 resource files in the first post on VBForums: ’VBCCR16SideBySide.res’ and ’VBCCR16SideBySideAndVisualStyles.res’ which are for exactly what they say in the title. These are not zipped but instead are the actual resource files so you should just save the links as files and use them. I will cover how to use one of these in just a bit. Setting up your project - Just like with the StdEXE version you cannot start your program with a Form; you must have a Sub Main and start it first so you can run some code that is required to be run before your first form is called or referenced. The easiest thing to do is to include the standard module VisualStyles.bas from the StdEXE version and then in your program, make sure in the General tab of Project | Properties is set to use Sub Main and in your Sub Main you should have the following line of code before loading, referencing or showing any forms: InitVisualStyles Now you are ready to go. All of the controls will show up in your Toolbox for use in your forms. Note - In the StdEXE version there is some code Krool has included to provide crash protection when you use the controls in the IDE. You need the same protections with the OCX version but thy have been compiled into the OCX so you don’t need to call the IDE protection code. Compiling your code - Nothing special here other than using that procedure discussed above in Sub Main. Krool says his code is IDE-safe and that has been my experience as well. You have an option of using a manifest file to specify two things that may be of interest to you. First, I think you will want to take advantage of themes/visual styles since this capability is built into Krool’s code and is relatively easily accessed. Also, the manifest can specify that you want a ’side-by-side’ assembly. Normally you have to include separate controls and ActiveX DLL’s with your program and they must be registered on the user’s system in the Windows System folder. Some organizations don’t allow this so they can’t even use a program with external dependencies such as the VBCCRxx.OCX controls file discussed here. Around the time VB6 came out there was a move to get away from this and to allow something else. In theory, having the latest version of controls (.OCX’s) and DLL’s in your system folder is efficient because many programs can access that one file instead of each program having its own OCX’s or DLL’s. In practice this caused a lot of problems (for fun, Google ’DLL Hell’ sometime). So with the right manifest you can specify that the OCX and/or DLL files your program uses can be with your programs and they don’t have to be registered with the user’s system. It is not quite as slick as including the code inside the program (like with the StdEXE version of Krool’s code) but it is the next best thing. Manifests can include other things but for purposes of this user guide we will focus only on the two that can affect Krool’s package. ’Back in the day’ you used to be able to put the manifest file next to the EXE when you distributed your package to your users but recent versions of Windows really want you to include the manifest in the program. There really isn’t a way to do that so the manifest gets included inside a resource file which can be and is used by many programming languages including VB6. Manifests are in XML and are strange because the file size must be exactly a multiple of 4 bytes. Fortunately Krool has provided two resource files that I discussed 2 pages back that can just be included into your program. One is for side-by-side and the other is for enabling visual styles plus side-by-side. Suppose you have downloaded from Krool’s web site the file ’VBCCR16SideBySideAndVisualStyles.res’ and want to use it. Obviously this is the one that provides both visual styles and side-by-side. You do not need to edit this file but you do need to reference it. Note - The resource file can be left in a common location as a library file used by multiple of your programs. Note though if you add to it or modify the file as you centrally use it, these changes will show up in all programs using that resource file. If you are concerned about this, simply copy the resource file to your project folder (same on that holds your .vbp file) and reference it separately for your project. So how do you get this resource file into your project? In VB6, go to AddIns | AddIn Manager’ and you will see something like the following: Select ’VB6 Resource Editor’ and ensure that ’Loaded/Unloaded’ and ’Load On Startup’ are both checked. Then, back in your main project go to Project | Add New Resource File’ and then select your .res file from the dialog box that pops up. Now your resource file should show up in the navigator pane under Related Documents which is listed below all of the forms, standard and class modules. Now you are ready to go and to use your compiled program. Using the EXE or DLL - You do not need a manifest to be included with the files you distribute since by including it in the resource file it is now part of your executable. You do need to include VBCCRxx.OCX with your program. If you use the side-by-side approach you can include it in the same folder or a sub-folder of the folder you put the executable file in. Please note that if you do use side-by-side, Windows looks for this OCX file in the executable’s folder even on your PC or anyone else’s even though you may have copied it to the System folder and registered it (at least that’s my experience). So I recommend that you do not move the OCX file out of the system folder but rather make a copy of it in the same folder where you have your EXE file on your PC. Please check my utility before you decide to do side-by-side. I have a solution whereby you use the OCX version of the controls during development then use the utility to do a commandline compile with the StdEXE version of the controls so you don’t need any side-by-side solutions since the code is all embedded in the executable (at least for Krool’s controls; if you use someone else’s OCX files you may still want to do side-by-side for their controls). If you don’t specify side-by-side you won’t need to do anything on your PC since you already have it registered but you need to have your installation program install it to the user’s system directory and register it. ### VBFlexGrid User Guide The MSFlexgrid replacement package from Krool is almost identical to what we have discussed above for the other 33 Common Control replacements Krool has done. This one came much later than the others so Krool decided to keep it separate. Perhaps at some point these two packages get merged but for now just think of VBFLXGRD as just like VBCCR except it has one control instead of 33. You can download the StdEXE version from VBForums [here](http://www.vbforums.com/showthread.php?848839-VBFlexGrid-Control-\(Replacement-of-the-MSFlexGrid-control\)) and the OCX version [here](http://www.vbforums.com/showthread.php?855931-VB6-ActiveX-VBFlexGrid-%28Replacement-of-the-MSFlexGrid-control%29\&p=5236525#post5236525). All of the issues relating to the VBCCR counterpart are the same with the FlexGrid control. My utility will help you manage both of these seamlessly. ### VBA Usage The StdEXE version of the VBCCR and VBFLXGRD controls will not work in VBA because VBA does not allow you to have controls embedded into the code. Any controls in addition to the ones built-in to VBA must be ActiveX controls (i.e., the OCX version). The OCX versions do work in VBA. The type library is not required since it is effectively compiled into the OCX file. Each user have the OCX file registered and referenced in his VBA project on whatever PC’s are running the code. Also, there are no styles in VBA so this feature is not available. If your VBA forms are ugly this code won’t help that. These controls do give the VBA user access to Unicode versions of the controls although many VBA controls in recent years display Unicode characters anyway (don’t allow Unicode text in properties at design-time though). It does not enable Unicode in the IDE code editor; the editor remains ANSI with or without these controls. Finally, many of Krool’s controls are enhanced versus what Microsoft provides so this could be an advantage. ## OCX2StdExe Utility I have used these for a while and have thought about how to manage these to not drive myself crazy and to get an efficient coding environment. Things I don’t like are: * The StdEXE versions enable a standalone executable file with no dependencies which is great but the compile times are a killer. * The OCX versions compile much more quickly but now you have an OCX to distribute and possibly register for each executable you make. * Updates to the OCX packages are great because they have a lot of bug fixes and feature additions but it is a real pain when a new version comes out. For each of your programs you have to find which forms use the controls from the text in the project file, manually change the references to the new name of VBCCRxx.OCX and/or VBFLXGRDxx.OCX in each form manually with a text editor, if you use a manifold with side-by-side you have to replace all of the names and GUID strings in the manifest part of the resource file and lastly you have to manually edit the project file (.vbp) to reference the new ocx file(s). Once is an experience and many times is nuts. * Since Krool’s OCX version doesn’t come with a sample file it is not entirely straightforward how to get the OCX version to use visual styles even though it might be referenced in the manifest/resource file. There is some initialization code that is required that is not included in the OCX package. You can make one from the StdEXE version but it takes parts of several standard modules. * I have a lot of other initialization code and I don’t want my code to get mixed up with Krool’s code. So I wrote a VB6 utility that manages these issues and more: * You set up your development program to use the OCX version(s) because it is simpler (1 file instead of 153) and your project compiles much faster than the StdEXE version during development. * You can use VBCCRxx.OCX or VBFLXGRDxx.OCX or both. I am trying to treat these two control packages as if they are one and the same (I have no inside knowledge but my expectation is that Krool will combine these in the not-too-distant future anyway). * Whenever a new version of VBCCRxx.OCX or VBFLxGRDxx.OCX comes out, you download it and copy it to your system folder and register it. If you have1.7.13 which is in VBCCR17.OCX and your overwrite the version 1.7.12 copy that was already registered and in the system folder you don’t have to do anything extra but it you have a program that is using version 1.6 and you now download version 1.7.xx you can use my utility to specify that your existing program that had been using VBCCR16.OCX should be upgraded to VBCCR17.OCX. the utility takes care of making the appropriate changes to your project file (.vbp), all form files (.frm and .frx) and even to the data in the resource file (.res) that references the old file for visual styles and/or side-by-side. All of your existing files are saved so you can easily restore them if for some reason you wanted to regress to an earlier version (not recommended). In fact, the utility can take projects using any version and switch to an earlier version. So you could go from version 1.7 down to 1.1 (why you would want to do this I don’t know but you could). * You can develop and maintain your project as you normally do with other projects when you use OCX controls. At some point, though, you likely will want to switch the compile to use the StdEXE version so you can get the single file, no dependency program and you don’t mind the compile time just this once. You can easily do this and not change any of your existing files. You just get a new self-contained executable file. * Your compiled code is smaller with the StdEXE commandline compilation because it includes only those controls that are actually used in the project. Your original files are not modified. I make temporary files that contain references to the StdEXE controls (the 153 files) instead of the one OCX. You have the option of retaining the temporary files (have different names than the files for the OCX version) so you can recompile the new StdEXE version again if you need or want to. Also, the property pages are optionally not included in the StdExE version reducing the executable file size because the commandline compile does not make use of property pages anyway (IDE does). * An option which has been added is to have the utility make a folder beneath your project folder called StdExe. The utility is (hopefully) easy to use. This document covers the version of the utility written for VB6; there is an almost identical version written for Excel if you prefer to do that. The Excel version is included in the package along with the VB6 version. Below is a screen shot of the VB6 version. At the top of the form is the VB6 project file to be updated or compiled. You can enter the path in the text box or click on the button to the left to search for it. The project file needs to be a project that uses the OCX versions of Krool’s controls (either or both). The OCX versions have versions and it is not trivial to change from one of the versions to a newer one because references to the OCX file to be used is embedded in code for the forms that use the controls, the resource file if it has an embedded manifest and the project file itself. If you specify a project file for a project that either doesn’t use Krool’s controls or uses the StdEXE version then you won’t be able to do either the OCX upgrade or the commandline compile. **Update OCX References** Our form advises you what current version of either VBCCRxx.OCX and/or VBFLXGRD.OCX you are using in the project. The sample above shows that the specified project is using VBCCR15.OCX and VBFLXGRD12.OCX. It also shows the versions of each that you have installed on the PC running this utility, defaulting to the most recent. In the sample above, it is showing VBCCR17.OCX and VBFLXGRD14.OCX which are the latest available at the time of this document. Although you can’t see it from the picture, the drop-downs include some earlier versions as well. You have an option to keep or delete the old version files after the upgrade. In general you won’t need to keep the old files but if you choose to keep them, you can find them in the same folder(s) as the new ones but with the extensions added not the names of the old OCX version numbers. For example, if you used Krool’s controls on ’myForm.frm’ when it is converted to version 16 from 15, the old file can be retained and if it is it would be named ’myForm.frm.ocxCCR15ocxFlex12’ so you can clearly identify it as the old file left behind after an upgrade. I recommend that once you develop trust in this utility that it won’t delete files it shouldn’t, there really is no reason to save the old versions so you can click on the choice to delete the old files. You can actually go to earlier versions of the controls that the current one if the older OCX file(s) is registered on your PC. In general, newer versions have more features but more importantly they also have bug fixes so I discourage going back to an earlier version. Another item to consider is that VBCCR16 added a new control (ComboFont) and VBCCR17 added VirtualCombo and VListBox that don’t exist in earlier versions so if you specify going from version 1.6 or later to version 1.5 or earlier, references to these controls have to be cut out which is likely not what you want (assuming you have used it). Once you have chosen the version(s) to go to and whether or not to save the old files, you just click on ’Update .OCX References’ to get your project changed. All of the controls will have the same settings as before you upgraded to the new version. **Note** - This utility does not use any of Krool’s controls so a) it is only ANSI and b) it doesn’t matter which versions of the OCX you have installed on your PC. **Compile Without the OCX Files** This choice from the main menu allows you to compile your program with the StdEXE files embedded into your program such that after the compilation you will not need the OCX file any more. It does not change any of your files that you have been using for development using the OCX versions of the controls. This option should be used *after* you get your program to compile and run with the OCX version. It is much easier and more productive to develop the program using the OCX version and then use the StdEXE version to make an executable file that can be distributed. Note that all of this presumes that you have downloaded and registered the OCX version(s) of VBCCR and VBFlexGrid and also have downloaded and unzipped the equivalent versions of the StdEXE version(s) as well. If you click on the Options button on the Main form, you will see the following: At the top of the form are options for which of Krool’s support files that are not part of each of the controls you wish to include. Some of these are general files used by many of the individual controls and some are just general support files. For example, the Common.bas is a general purpose module whose routines are used by many of the controls. I always leave this one checked because it is so core to all of the functions. On the other hand, VisualStyles.bas contains code that I have already incorporated into my core module so I don’t use it in the options above. The class module CommonDialog.cls is interesting. Only one control uses it (MCIWnd.ctl) and 4 of the .pag files that are used in the IDE use it (CoolBar, ImageList, RichTextBox and StatusBar). I have code that looks to see if any of these are used and if not it is automatically excluded so my suggestion is that unless you specifically have included CommonDialog.cls in your code for other uses, just leave it checked above. Note that there is an option for a module named VTableSubClass.bas but if you use a version of ComCtrlsDemo on or after 5 Jan 2020 this option is not needed and is not shown. In the middle of the form are choices for file locations for the compile. The utility will not affect your existing project files but it does need to modify them to change the references from the .OCX controls to the StdEXE controls. You have two choices of doing this: 1) make copies of all of the affected files and put an XXX in front of the name of the newly copied file or 2) copy all of the project files to a separate folder where you can make the appropriate changes for the compile. I recommend the option of copying to a separate folder because you dn’t leave XXX files scattered all over your programming system. **Copy all files into a StdEXE sub-folder and then compile that** - If you choose this option, all of the files associated with your project are copied into a sub-folder named StdEXE of the folder where the project file is located. A copy of the project file is put into this sub-folder and all of the references are adjusted to the files now in this sub-folder. After the compile, the EXE file will be located in this folder. This project will differ from the parent project in that the OCX references are gone, replaced by references to the StdEXE control files. However, in addition to the project being fed to the commandline VB6 compiler, it can also be opened like a normal project in the VB6 IDE. If/when you ever want to get rid of this project just delete the contents of the sub-folder. Note- Krool’s control files are treated as a library and so are not changed in any way for a compile so they are not copied into the StdEXE folder. They are referenced rom wherever you have put them on. **Rename all support files with XXX prefix before compile and then’** - When you select this option, you get 3 sub-options below it. To protect the original project, we make copies of all of the changed files by putting ’XXX\_’ in front of the name, including the EXE generated from the commandline compiler. You can tell the program to delete these support files after the compile; you can save these XXX\_ files so that later you can re-compile the new project file (which also has XXX\_ prepr=ended to its name); or you can choose to keep all of the support files for all of Krool’s controls, even those that are not used in your project. (Note - If you use the Excel version of this utility the prefix is YYY\_ instead of XXX\_.) Note - If you elect to save the support files so you can open the StdEXE version in the VB6 IDE, there are some modifications I have to make that are transparent to you but are important to note so you aren’t surprised. For example, I do not include any control property page files (.pag extension) since these are only used within the IDE and we skip the IDE with the commandline compile. However, if you want to save the support files so you can later open this in the IDE then we need to make sure that we adjust your project file to reference the appropriate .PAG files so you can open it in the IDE. So after the commandline compile, references to the .PAG files are placed into the .VBP project file. Until early August 2020, Krool had a mechanism built in to the StdEXE set of files that tried to ensure safety of using these controls in the IDE. After 13 Aug 2020 he removed these safeguards. If you are still using a StdEXE version before then (highly not recommended) then we have some code in place that will help you put this attempted safeguard into you code post-compile it isn’t needed in the.OCX version but is in the earlier StdEXE versions. **Which controls are included** When you do a commandline compile, only the controls you actually used are included in the compiled code. This makes the resulting .EXE file be the smallest possible because you do not include references to unused controls. However, if you want to later edit this StdEXE version it could be that you want the option of adding more or all of the controls you aren’t using now into the project. There is a choice on the Options form to specify inclusion of all of the controls into the new project or you can click on ’Special’ and include specific ones. In general I recommend against this because it is easier to just keep using the original project that refrences the .OCX file where you have all of the controls available and then just re-run this utility when you want to generate the .EXE file with the controls included in the .EXE. There is a special case where you have to use the ’Special’ button. If you define a control at run-time and the name of the control is in a variable, my utility cannot see that and it would get extremely complicated to track down all possible assignments to the string. Since you write the programming code you should know which controls you are adding at run-time so you wan specify which additional controls to include, if any. If you already use a specific control in your program you don’t even need this since that use already makes that control be included in the compile. **Base File Locations** At the bottom of the Compile Options form is a section for ’Base File Locations’. In order to do a commandline compile we need to know where VB6 is located and also where Krool’s control files are located. If you are going to compile the project by swapping the OCX version for a temporary StdEXE version then you need to know where VB6.EXE is because this utility will execute it later when you click on ’Compile w/o .OCX’s’ in the main form. When you click on the VB6.EXE’ button, we will try to locate VB6 automatically for you. If we don’t find it, you can navigate to it or manually enter it. There are two locations towards the bottom of the form to specify the locations of Krool’s StdEXE versions (ComCtlsDemo and VBFlexGridDemo) for you to specify. You do not need these to specify an update to the OCX versions but you do need to specify these if you wish to do a commandline compilation with the StdExE controls instead of the OCX version of the controls. These files do not ever get modified so I put them in my library and I always keep the latest versions in a folder called ’Current’. You don’t need to call the folder by that name but you do need somewhere to put the new files downloaded for VBCCRxx and/or VBFLXGRDxx After you make whatever changes you want to this Compile Options form, if you click on ’Accept changes & return’ your entries will all be saved in an INI file for re-use the next time you run the StdEXE utility. The INI file is saved in the same folder where you keep the StdEXE utility. I am assuming as a programmer you will not install this into ’Program Files’ so it is more convenient to keep your settings with the program since you won’t have to worry about trying to save to ’Program Files’ requiring a UAC elevation. **Compiling** When you click on the ’Compile w/o .OCX’s’ button on the main form, the utility will look through your project file, all of your controls, modules and the manifest/resource file for references to the OCX controls and it changes them to the StdEXE controls and the references to the StdEXE controls are put in the .vbp file which is then compiled using the VB6.EXE program from a commandline (we shell out to an elevated command prompt). None of your original project files are modified. **NOTE** - Please know that the first few times you use this utility to do a commandline compilation you are likely to get some naming conflicts. The names of all of the control, page property, class files etc. (basically everything inside of the Builds folder) are ’hidden’ in the OCX but all of the file names and all of the public variables, types, procedures enums, etc. are all visible when you have your program compile with all of these controls included with your program. At this point you get to decide whether to rename your code or Krool's. I would like to have kept mine and renamed Krool's (I had 2 conflicts) but I did not because I didn’t want to track down each use of his and because I didn’t want to go through the renaming hassle every time I downloaded and update. But either way will work. Below are two screen shots, one of a successful compile and one that failed. ### Running OCX2StdEXE with Commandline Options There is now a commandline version of the utility that can do either OCX version upgrade or OCX compile using the StdEXE version just like described above but without the input form. Note that in both cases if the full path to your project has any spaces in it that the full path must be in quotes. **Compiling via the Commandline** OCX2StdExe ProjectPathAndName \[/s\[1]\[2]\[3]] \[/A\[-]\[+]] This means do a compile of the project that uses the OCX version with the StdEXE version to embed the code in the executable. If you specify /S then no files are saved after the compile other than the executable (assuming a successful compile). If you specify /S1 then the support files for the used controls are saved and if you specify /S2 then all support files for all controls are saved regardless of whether the controls are used in the project. Specifying /S3 means make a copy of the whole project in a StdEXE sub-folder and then compile that one. If you do not specify a /S switch then whatever value was saved from the last time you used the program with the dialog box is re-used. You can also specify whether or not all of the StdEXE controls are used in the commandline compile (this is different from whether any of the files are saved after the compile). Specifying /A or /A+ says use all controls and /A- means do not use all controls. If you do not specify the /A switch then whatever the currently saved value for /A is from you last run is used. Switch case does not matter. /S is the same as /s. The compiled version of the program (if successful compile) will be found in one of 2 places. If you specify /S3 then the StdEXE sub-fodler will contain not only copies of all the project files but also the compiled .EXE file. On the other hand, using any of the other SaveControls options will make the compiled EXE in the same folder as the original project file and the executable will have ’XXX\_’ appended to the front of the file name. **Updating the .OCX version in a project** OCX2StdExe ProjectPathAndName /u \[/CCRxx] \[/FLEXxx] \[/d] This causes the specified project to have its OCX controls changed to the values specified in /CCRxx or /FLExxx switches. The ’xx’ specifies the version to use (must be registered on this PC first). If no ’xx’ is specified then the latest version registered on the PC running the utility is used. As with the regular version of OCX2STDExe, the old files are saved with a new extension. Specifying /d or /D causes all of those old files containing the old OCX references to be deleted. ## How I Manage Krool’s System As you probably have figured out, I use Krool’s OCX versions of the controls during development and then use my utility to switch to a compile using Krool’s StdEXE version so I have a self-contained executable to distribute. There are a few techniques I have learned that will hopefully make this whole process very simple. * OCX Version of the Controls * I always use the latest version of the OCX files found [here](http://www.vbforums.com/showthread.php?841929-VB6-ActiveX-CommonControls-%28Replacement-of-the-MS-common-controls%29\&p=5129155#post5129155) for VBCCRxx and [here](http://www.vbforums.com/showthread.php?855931-VB6-ActiveX-VBFlexGrid-%28Replacement-of-the-MSFlexGrid-control%29\&p=5236525#post5236525) for VBFLXGRDxx. The latest versions are at the end of post #1. When you save the VBCCRxx file note that you do a Save As and drop the .docx extension since it is a trick Krool does to avoid a file size limit on VBForums for zip files. I recommend putting the file on your hard drive with the current version as part of the name. The current VBCCRxx file is version 1.7.0 so I save the file ’VBCCR17.OCX.rar.docx’ as ’VBCCR16.OCX v1.7.0.rar’. the latest VBFLXGRDxx version is 1.4.27 at least for now the file size is small enough that is still ahs the .zip extension. I would save this file which is ’VBFLXGRD14.OCX.zip’ as ’VBFLXGRD12.OCX v1.4.27.zip’. While you are on the web page getting the OCX files you should also get the .RES files (resource files) because those will be helpful a bit later. * Now you have to get the OCX files that are inside the .RAR and .ZIP files into your System folder to use them. If you are using a 32-bit version of Windows you will want to get the OCX files into C:\Windows\System32 and if you are using a 64-bit version of Windows, put them in C:\Windows\SysWOW64. Note that the OCX file doesn’t have the minor version in the file name. For example, two recent VBCCRxx.OCX versions are 1.7.12 and 1.7.13 but each is a file named VBCCR17.OCX. If an older version is already in your system folder you can just overwrite it. Note that with any operating system after XP you will have to use an elevated CMD prompt or a file manager such as Directory Opus (my favorite) that takes care of elevation for you. You don’t have to put the OCX file in the system folder but I always do that if for no other reason than I know where it is. * If you haven’t used Krool’s OCX controls at all or you have an updated version (say 1.7 instead of 1.5) then you will need to register the OCX file using regsver32 from an elevated command prompt (don’t need if you just overwrote an older file of the same name). * If you have updated OCX versions (e.g. from 1.5 to 1.7) then you will want to run my utility for each of your projects that use the earlier version and update to the most recent OCX version. * StdEXE Version of the Controls * One confusing aspect of the StdEXE version of the controls is that there are no version numbers like for the .OCX version of the controls. When Krool updates his StdEXE controls I download that package and put the date of the issue in the download file name. Then I extract the files into the same folder structure I used from before so that I always have the latest version of the controls available. Krool has cautioned against developing with these controls because they are not IDE-safe but by using this compile utility you can develop with the stable .OCX version and then commandline compile with the stdEXE version to include the controls you use into your EXE file so that you don’t need the .OCX file to distribute with your .EXE program. * You need to look into the OLEGuids folder of either VBCCRxx or VBFLXGRDxx and copy the type library OLEGuids.tlb to you system folder and register it. Fortunately this file doesn’t change very often (current version is dated 15 April 2020) but it is worth checking every now and then to make sure you aren’t using an out-of-date type library. Note that tis type library is not required for the .OCX version because it is effectively compiled into the .OCX file but it is needed for the StdEXE version. * In your program you must reference the type library in the IDE via Project | References and put a check mark by ’OLE Guid and interface definitions’. Again, this is only needed fro the StdEXE version. I take care of this for you when you use this utility and it is modifying a copy of your project that uses the OCX version to instead use the StdEXE version. * Enable the controls in the IDE via Project | Components (or Ctrl-T) and then select the appropriate controls files. For VBCCR version 1.7 you would put a check mark by ’VB Common Controls Replacement 1.7 Library’. For VBFLXGRD version 1.4 you would put a check mark by ’VB FlexGrid Control 1.4’. All of the controls should now show up in your toolbox in the IDE. * The default start action in a VB6 program is to load and display a form. You can’t do this with these controls because there is some initialization code that needs to run before any form is referenced, loaded or displayed. First you need to have Sub Main in a standard module in your project. Then you need to change the setting in Project | Properties on the General tab to make the Startup Object be a call to Sub Main instead of any forms. Then within Sub Main you need some initialization code so that you don’t crash when you call the first form. There are 2 ways to do this. * The first is to use Krool’s code directly, albeit in a strange way. The OCX control package doesn’t contain any guides or code on how to use it (it does have some code in later versions that would enable you to make your own OCX file from source code but that isn’t the same as a go-by for use). If you download the StdEXE version you will find a folder called ’Common’ and inside that are files ’Common.bas’ and ’VisualStyles.bas’. There is a sub in VisualStyles.bas called ’InitVisualStyles’ which is what you need to run before calling a form but if you just include VisualStyles.bas in your program you will find that it needs some routines from Common.bas so you have to load it too. So if you include these two files in your project, your first line in your Sub Main would be a call to InitVisualStyles and then you can call your forms. * The route I use (as you can see in the source code for my utility), I have a general standard module in my library called mVB6Core.bas in which I put enough of the code from Common.bas and VisualStyles.bas so that I can run the sub InitVisualStyles and I can do a lot of other stuff I always do (checking whether we are in the IDE or running compiled code, the current Windows version, etc.). Below is the code I have in my general initialization routine called UCCoreInit (line 1971): ```vb If OSVer >= Vista Then Dim ICC As InitCC If App.LogMode <> 0 Then Call InitReleaseVisualStyles(AddressOf ReleaseVisualStyles) ICC.dwSize = LenB(ICC) ICC.dwICC = &H4000& InitCommonControlsEx ICC Else InitCommonControls End If ``` * You would think you are good to go. Not quite yet. We have to setup visual styles for each control on each form when they are loaded. Somewhere in the initialization code for each form you need to call SetupVisualStyles and pass the form to the sub. This code is in VisualStyles.bas and it is also part of my mVB6Core.bas library. This sub SetupVisualStyles makes sure that all of the controls on the form are able to use visual styles. So you either put this call in the Form\_Load sub for each form you use. My method is close to this. I always have my forms use my class library clResizer.cls and even if I turn resizing off for a form I still have in the initialization code for my form a call to this class module which in turn calls the sub SetupVisualStyles. This way I didn’t have to make that call be a part of the code for each new form since my class library handles it. But either way works just as well. * On to manifest and resource files. Krool’s controls have nothing to do with resource files per se other than being a container for a manifest file. You are not required to use a manifest or a resource file but if you want to take advantage of visual styles, side-by-side or high DPI monitors then you must use a manifest and embed it into a resource file and then load that resource file into your executable. If you are planning to continue to use the OCX version and not do the final compile with the StdEXE version of the controls then you will likely want to use the side-by-side option. I do ***not*** do this. There is no advantage to specifying side-by-side on your development PC and in fact it causes a hassle because when you make the EXE file on your PC with the OCX version, if you have specified side-by-side on your own PC you have to have the OCX file in the same folder as your EXE to run the EXE even if it also resides and is registered in your Windows system folder. Instead, I use a resource file named OCX2StdEXE.res for all new projects (included with my utility) that specifies the use of visual styles and high DPI monitors but does not specify the use of side-by-side. If there are other files you need to have side-by-side it is okay to put them in the resource file, just don’t bother putting Krool’s OCX controls in there. Note - Even if you specify side-by-side and then decide to use my utility for compilation nothing bad will happen. My utility will strip out the side-by-side specification from inside the resource file since it is not needed or wanted when all of the code for the controls is included in the executable. As usual, your original files (the ones you have been using to develop with the OCX version) are unchanged by this. * Now it is time to plan a bit for later. If you are using a version of the StdExe controls as part of Krool’s ComCtrlDemo project that is later than 13 Aug 2020 the discussion below can be skipped because of changes Krool made to his code that makes the following only applicable to older versions. Since his controls are free it doesn’t seem to make sense why you would want to use the older versions anyway. * We are using the OCX controls for development. We do not need to worry about using these in the IDE and crashing it because Krool has taken that into account in his OCX. When you do a commandline compile I handle that as well. An issue arises when we take code that does not need it (the OCX controls themselves plus your code) and you specify that you want a commandline compile but you want to save the support files so you can open it later in the IDE. Krool controls the IDE Stop protection code via a conditional compilation constant called ’ImplementIDEStopProtection’. In his demo for the StdEXE version there is a file named ComCtlsBase and on line 3 is this conditional compilation constant set to True which later in that module cause the IDE stop protection code to be compiled. We don’t want that to happen in the commandline compile so for the commandline compile I use a copy of ComCtlsBas.bas with the conditional compilation constant commented out. In the post-commandline compile not only do you want this constant set True for all modules you want to call the sub ’ComCtlsInitIDEStopProtection’ which turns on the IDE Stop protection when you run your/his code in the IDE. I account for this in the library standard module I include with the utility called mVB6Core.bas. If you look on line 1980 you will see the following code: ```vb #If ImplementIDEStopProtection = True Then ' If you use Krool's controls, the OCX version does not need IDE protection ' but the StdEXE version does. If you are using the OCX version and then compile using ' this utility (commandline with switch to StdEXE) and elect to keep the files you will ' need to execute the following sub. At the end of the compile part of my utility I add ' ImplementIDEStopProtection = True to the list of compilation constants in the new ' .vbp project file (the one that now references the individual controls not the OCX. ' The following sub is in ComCtlsBase.bas ComCtlsInitIDEStopProtection ' constant set to False for commandline compile of Krool's controls #End If ``` Since normally the conditional compilation constant is 0 (it is not a visible part of the OCX version of the controls) then the call above to ComCtlsInitIDEStopProtection does not occur (and it shouldn’t) but if you specify to save support files in the utility, the saved project file sill have an additional conditional compilation constant ImplementIDEStopProtection set to -1 (True). The only time the procedure ComCtlsInitIDEStopProtection is even present is in this post-commandline compile situation with the saved support files so the above code does nothing outside of that situation. If you use your own initialization code you need something like this in your code if you want to be able to open the post-commandline compile support file version. Note that this is not really necessary. If you are able to compile your program with the OCX version of the controls then it is extremely likely that the commandline compile of your code with the StdEXE version of the controls will be successful and you will never need to even look at the support files (and will likely not even keep them). * So now you can develop your program. You will be using the OCX version of the controls. You can use the VBCCRxx.OCX &/or the VBFLXGRDxx.OCX packages. * If a new version of the OCX controls comes out ([here](http://www.vbforums.com/showthread.php?841929-VB6-ActiveX-CommonControls-%28Replacement-of-the-MS-common-controls%29\&p=5129155#post5129155) for VBCCRxx and [here](http://www.vbforums.com/showthread.php?855931-VB6-ActiveX-VBFlexGrid-%28Replacement-of-the-MSFlexGrid-control%29\&p=5236525#post5236525) for VBFLXGRDxx) that has the same main version as the one you are using (say you have 1.7.10 installed and 1.7.13 comes out) just copy the OCX file over the existing one. If a new main version comes out (current is 1.7 so 1.8 will be the next one) simply copy the OCX to your system folder and use regsvr32.exe to register it and then use my utility to adjust each of your programs that use the older version to the new version. * Also keep track of the StdEXE releases as part of Krool’s ComCtlsDemo ([here](http://www.vbforums.com/showthread.php?698563-CommonControls-\(Replacement-of-the-MS-common-controls\))) and the VBFlexGridDemo ([here](http://www.vbforums.com/showthread.php?848839-VBFlexGrid-Control-\(Replacement-of-the-MSFlexGrid-control\))). There are no versions per se but the most recent version on the web site corresponds very closely (if not exactly) with the latest OCX version. There used to be some differences (OCX version tended to lag a bit behind in terms of bug fixes and additional features) but for the past couple of years Krool has done a very good job of keeping the two the same. * Whenever you want to send out a version of your executable, run my utility and select the option to compile without the .OCX’s. * When doing a commandline compile you will need files for each control. The utility determines which ones are needed and includes them. However, there are some general files in the Common and Builds folder of ComCtlsDemo that may or may not be included. Whatever values you set for these in the Options form of my utility will be re-l As the developer I give you the choice of including any of them or not. You will find these in the Function DoCompile in the module zVBandVBA starting on line 191. My values are shown below. ```vb Public IncludeStartupbas As Boolean Public IncludeCommonbas As Boolean Public IncludeVisualStylesbas As Boolean Public IncludeISubclasscls As Boolean Public IncludeVTableHandlebas As Boolean Public IncludeVTableSubclasscls As Boolean Public IncludeCommonDialogcls As Boolean ``` I do not include Startup.bas in my programs because it is specific to Krool’s demo program although I have used bits of his routine in my own. I do not include VisualStyles.bas because I have incorporated that code into my initialization routine for both the OCX and StdEXE versions. VisuaStyles requires some functions and subs from Common.bas but I only took a part of them along with VisualStyles and made them Private so that for the commandline compile I can bring in the whole of Common.bas. Finally, specify that CommonDialog.bas can be included. Note that it is not automatically included. It is only included if/when the control MCIWnd.ctl is used or one or more of the property pages for CoolBar, ImageList, RichtextBox or StatusBar are used. Property pages are not used in the commandline compile option but if you elect to save the support files for later re-compiling then the property page files are included. ## Version History | **Version** | **Date** | **Comments** | | ----------- | ----------- | ------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------ | | 0.9.0 | 2 Jul 2017 | \* Initial VB6 & Excel releases for beta test. | | 0.9.1 | 4 Jul 2017 | \_ Works with no controls but 1 or more references to CommonDialog \_ Comparisons within the .vbp file are done uppercase \* Does not include reference to stdol2.tlb if the .vbp file already has that reference. | | 0.9.2 | 9 Jul 2017 | \* Correctly handles situation where no controls are used but CommonDialog is called in a Form (used to just check for this in class and standard modules). | | 0.9.3 | 31 Jul 2017 | \* Fixed path error for forms in new .vbp file | | 0.9.4 | 23 Aug 2017 | \* Reworked some relative path stuff | | 0.9.6 | 11 Jul 2018 | \* Adjusted to function name change in mUCCore of myQuickOpen to FileCreateOrOpen. | | 0.9.7 | 1 Oct 2018 | \_ Add support for VBCCR16 \_ Broke out VB6 core code into own mVB6Core.bas, parallel with mUCCore for VBA | | 0.9.8 | 24 Nov 2018 | \* Many, many changes | | 0.9.9 | 1 Dec 2018 | \_ Add support for VBFLXGRD.OCX and VBFlexGridDemo.vbp (StdEXE) \_ Combined all input onto 1 form in VB6 version \_ Made 3 option buttons for amount of post-compile support file saves (none, controls used, all controls) \_ Modified logic to include or exclude various modules from Common and Builds in compile \_ Modified logic around conditional compilation constant ImplementIDEStopProtection especially for post-compile re-use \_ New logic for include or exclude of CommonDialog.cls in compile &/or post-compile support file save. \_ Use enums to help manage code around whether VBCCRxx &/or VBFLXGRDxx are used in a given project. \_ Added commandline option for Upgrade or Compile. | | 0.9.10 | 11 Dec 2018 | \_ Fixed bug in DoCompile if VBCCRxx or VBFLXGRDxx was not installed/registered \_ Fixed bug in DoCompile on extracting manifest from resource file when resource file had no embedded manifest | | 0.9.11 | 12 Dec 2018 | \_ In DoCompile look in class and standard modules for references to VBCCRxx and/or VBFLXGRDxx (had done forms and the resource file but not .bas and .cls files) \_ On fmInput, cbutProjFile defaulted to this program's path even when a current file was already in the dialog box. Now, goes to that file's folder. | | 0.9.12 | 13 Dec 2018 | \* New check box on fmInput for DoCompile to force the use of all of StdEXE controls in the compile which is not mornally needed but if someone puts a reference to a property of a control in the OCX-based project we can see it as part of VBCCRxx but without going through each of the properties for each control we wouldn't know which control it is connected to. I don't think this is a normal occurrence so I put it there just in case someone did this in their OCX-based code. | | 0.9.13 | 19 Dec 2018 | \_ Code clean-up \_ Moved all compile options to 2nd form | | 2.0.0 | 1 Jul 2020 | \_ VBFlexGrid OCX version 1.4 is covered. \_ Krool’s controls have been replaced with standard VB6 controls. This sounds counterproductive but an update utility should not rely on a given version of the controls during the update. A small part of the change is that the manifest and side-by-side compilation has been removed. \_ It seems that Krool is close to issuing major updates to VBCCR.OCX to version1.7 and VBFlexGrid to 1.5 and this utility is now set-up to quickly add the capability to update ot these new versions. \_ The utility uses a new class module called clINI.cls that saves and restores settings between various runs of the utility in an INI file. The previous version saved settings to the registry. That is still an option but I have moved away from using the registry at all for a variety of reasons so it would require some code modification. Presently the utility will save the INI file into the same folder where the program files are copied. \* Incorporated a tooltips module by The Trick on VBForums. | | 2.1.0 | 2 Jul 2020 | \* Miscellaneous bug fixes. | | 2.1.1 | 3 Jul 2020 | \* Uploaded version did not have local version of the tooltips module. | | 2.2.0 | 20 Aug 2020 | \_ Different method for new tooltips included in clResize.cls & old one removed from VB6Core.bas \_ Works with VBCCR17.OCX. \* Slight improvements in registry reading in a couple of spots. | | 2.3.0 | 28 Aug 2020 | \_ Now includes an option to first copy the project file (& all of its modules etc.) to a sub-folder of your project called StdEXE for potential later use. \_ Lots of minor bug fixes. | | 2.3.1 | 31 Aug 2020 | \* Bug Fix - If you had your own UserControl &/or PropertyPage in your project (not Krool's controls; your own), these would not get copied into the StdExe folder for that self-contained project compile. Fixed now. | | 3.0.0 | 27 Mar 2021 | \_ You can specify individual controls to be included in a compile with the StdExe. This feature was added because of the example in post #34 where he wanted to add a control in a standard module with the control name in a variable. I didn't want to have to chase down variable assignments in your code so there is now a feature to deal with that (you should know what controls you add like this so you can turn on those controls to be included in the EXE file). Previously this was an all or nothing proposition. \_ StdExe compilation option includes looking inside all project files for references to Krool's controls including .BAS files. \_ Bug fixes in StdExe compilation section \_ VirtualCombo and VirtualListbox had been effectively ignored. \_ CommonDialog.cls was left out even if specified to be in. \_ Conditional compilation constants from user project file sometimes were left out. \_ The .PAG files were not referenced in the final .VBP file in the Copy to a sub-folder option. \_ Handling of the commandline compile output from the MS compiler/linker was improved. \* Base file locations are now required before a compile with StdExe options from the commandline. If you have not entered these file location values, you will be prompted for them before you can continue. | | 3.1.0 | 17 Nov 2021 | \_ Handles VBCCR17.OCX version 1.1 (previously only handles 1.0) \_ Set\_xx\_CCR and Set\_xx\_Flex are now only called once \* Arrays GUIDxxCCR() and GUIDccFlex() are now Public (were embedded into Set\_xx\_CCR & Set\_xx\_Flex) | | 3.2.0 | 20 Dec 2021 | \* Handles VBCCRxx.OCX up through version 1.7. Handles all VBFLXGRDxx.OCX versions including the just-released v1.5. | | 3.3.0 | 24 Jun 2023 | \_ Now works with VBFleGrd16 \_ Each OCX version is independent. VBCCR16.OCX is totally separate from VBCCR17.OCX etc. It is unusual for any of these to have multiple versions so there is as version 1.0, 1.2 and now 1.2. This version number shows up in the VBP file and also each of the .FRM files. I had assumed that version 1.0 was the version number for each .OCS because all of them only had 1,0 but now VBCCR17.OCX has 1.0, 1.1 and 1.2. Failing to recognize versions greater than 1.0 caused some problem. It is now fixed. \* Trivia- VBCCR11.OCX had a version 1.1 but that was in 2015 and I am fairly certain nobody uses that one any more. | --- --- url: /en/packages/vbccr/system/commondialog.md description: >- CommonDialog Control - VBCCR Development Manual, Complete API Reference Based on Source Code --- # CommonDialog Control Provides a wrapper class for Windows standard dialogs (Open, Save, Color, Font, Print, Help, Page Setup, Folder Browser, Find, Replace). ## Enumerations ### CdlErrorConstants | Constant | Value | Description | |------|-----|------| | CdlCancel | 32755 | User selected "Cancel" | | CdlBufferTooSmall | 20476 | File name buffer is too small | | CdlInvalidFileName | 20477 | Invalid file name | | CdlSubclassFailure | 20478 | Subclassing failed | | CdlMaxLessThanMin | 24573 | Minimum value is greater than maximum | | CdlNoFonts | 24574 | No fonts available | | CdlPrinterNotFound | 28660 | Printer not found | | CdlCreateICFailure | 28661 | Failed to create information context | | CdlDndmMismatch | 28662 | DEVMODE mismatch | | CdlNoDefaultPrn | 28663 | No default printer | | CdlNoDevices | 28664 | No print devices | | CdlInitFailure | 28665 | Print dialog initialization failed | | CdlGetDevModeFail | 28666 | Failed to get DEVMODE | | CdlLoadDrvFailure | 28667 | Failed to load printer driver | | CdlRetDefFailure | 28668 | Failed to return default DEVMODE | | CdlParseFailure | 28669 | Parse failure | | CdlHelp | 32751 | Help request | | CdlBufferLengthZero | 36848 | Buffer length is zero | ### CdlPRORConstants | Constant | Value | Description | |------|-----|------| | CdlPRORPortrait | vbPRORPortrait | Portrait orientation | | CdlPRORLandscape | vbPRORLandscape | Landscape orientation | ### CdlPRPSConstants | Constant | Value | Description | |------|-----|------| | CdlPRPSLetter | vbPRPSLetter | Letter | | CdlPRPSLetterSmall | vbPRPSLetterSmall | Letter Small | | CdlPRPSTabloid | vbPRPSTabloid | Tabloid | | CdlPRPSLedger | vbPRPSLedger | Ledger | | CdlPRPSLegal | vbPRPSLegal | Legal | | CdlPRPSStatement | vbPRPSStatement | Statement | | CdlPRPSExecutive | vbPRPSExecutive | Executive | | CdlPRPSA3 | vbPRPSA3 | A3 | | CdlPRPSA4 | vbPRPSA4 | A4 | | CdlPRPSA4Small | vbPRPSA4Small | A4 Small | | CdlPRPSA5 | vbPRPSA5 | A5 | | CdlPRPSB4 | vbPRPSB4 | B4 | | CdlPRPSB5 | vbPRPSB5 | B5 | | CdlPRPSFolio | vbPRPSFolio | Folio | | CdlPRPSQuarto | vbPRPSQuarto | Quarto | | CdlPRPS10x14 | vbPRPS10x14 | 10x14 | | CdlPRPS11x17 | vbPRPS11x17 | 11x17 | | CdlPRPSNote | vbPRPSNote | Note | | CdlPRPSEnv9 | vbPRPSEnv9 | Envelope #9 | | CdlPRPSEnv10 | vbPRPSEnv10 | Envelope #10 | | CdlPRPSEnv11 | vbPRPSEnv11 | Envelope #11 | | CdlPRPSEnv12 | vbPRPSEnv12 | Envelope #12 | | CdlPRPSEnv14 | vbPRPSEnv14 | Envelope #14 | | CdlPRPSCSheet | vbPRPSCSheet | C Sheet | | CdlPRPSDSheet | vbPRPSDSheet | D Sheet | | CdlPRPSESheet | vbPRPSESheet | E Sheet | | CdlPRPSEnvDL | vbPRPSEnvDL | Envelope DL | | CdlPRPSEnvC5 | vbPRPSEnvC5 | Envelope C5 | | CdlPRPSEnvC3 | vbPRPSEnvC3 | Envelope C3 | | CdlPRPSEnvC4 | vbPRPSEnvC4 | Envelope C4 | | CdlPRPSEnvC6 | vbPRPSEnvC6 | Envelope C6 | | CdlPRPSEnvC65 | vbPRPSEnvC65 | Envelope C65 | | CdlPRPSEnvB4 | vbPRPSEnvB4 | Envelope B4 | | CdlPRPSEnvB5 | vbPRPSEnvB5 | Envelope B5 | | CdlPRPSEnvB6 | vbPRPSEnvB6 | Envelope B6 | | CdlPRPSEnvItaly | vbPRPSEnvItaly | Envelope Italy | | CdlPRPSEnvMonarch | vbPRPSEnvMonarch | Envelope Monarch | | CdlPRPSEnvPersonal | vbPRPSEnvPersonal | Envelope Personal | | CdlPRPSFanfoldUS | vbPRPSFanfoldUS | Fanfold US | | CdlPRPSFanfoldStdGerman | vbPRPSFanfoldStdGerman | Fanfold Std German | | CdlPRPSFanfoldLglGerman | vbPRPSFanfoldLglGerman | Fanfold Lgl German | | CdlPRPSUser | vbPRPSUser | User-defined | ### CdlPRBNConstants | Constant | Value | Description | |------|-----|------| | CdlPRBNUpper | vbPRBNUpper | Upper paper bin | | CdlPRBNLower | vbPRBNLower | Lower paper bin | | CdlPRBNMiddle | vbPRBNMiddle | Middle paper bin | | CdlPRBNManual | vbPRBNManual | Manual paper feed | | CdlPRBNEnvelope | vbPRBNEnvelope | Envelope bin | | CdlPRBNEnvManual | vbPRBNEnvManual | Envelope manual feed | | CdlPRBNAuto | vbPRBNAuto | Auto feed | | CdlPRBNTractor | vbPRBNTractor | Tractor feed | | CdlPRBNSmallFmt | vbPRBNSmallFmt | Small format bin | | CdlPRBNLargeFmt | vbPRBNLargeFmt | Large format bin | | CdlPRBNLargeCapacity | vbPRBNLargeCapacity | Large capacity bin | | CdlPRBNCassette | vbPRBNCassette | Cassette bin | ### CdlPRPQConstants | Constant | Value | Description | |------|-----|------| | CdlPRPQHigh | vbPRPQHigh | High quality | | CdlPRPQMedium | vbPRPQMedium | Medium quality | | CdlPRPQLow | vbPRPQLow | Low quality | | CdlPRPQDraft | vbPRPQDraft | Draft quality | ### CdlPRCMConstants | Constant | Value | Description | |------|-----|------| | CdlPRCMMonochrome | vbPRCMMonochrome | Monochrome printing | | CdlPRCMColor | vbPRCMColor | Color printing | ### CdlPRDPConstants | Constant | Value | Description | |------|-----|------| | CdlPRDPSimplex | vbPRDPSimplex | Single-sided printing | | CdlPRDPHorizontal | vbPRDPHorizontal | Double-sided horizontal flip | | CdlPRDPVertical | vbPRDPVertical | Double-sided vertical flip | ### CdlOFNConstants | Constant | Value | Description | |------|-----|------| | CdlOFNReadOnly | \&H1 | Show read-only checkbox | | CdlOFNOverwritePrompt | \&H2 | Prompt before overwriting file | | CdlOFNHideReadOnly | \&H4 | Hide read-only checkbox | | CdlOFNNoChangeDir | \&H8 | Do not change current directory | | CdlOFNHelpButton | \&H10 | Show help button | | CdlOFNNoValidate | \&H100 | Do not validate file name | | CdlOFNAllowMultiSelect | \&H200 | Allow multiple selections | | CdlOFNExtensionDifferent | \&H400 | Extension is different | | CdlOFNPathMustExist | \&H800 | Path must exist | | CdlOFNFileMustExist | \&H1000 | File must exist | | CdlOFNCreatePrompt | \&H2000 | Prompt to create file | | CdlOFNShareAware | \&H4000 | Ignore sharing errors | | CdlOFNNoReadOnlyReturn | \&H8000& | Do not return read-only files | | CdlOFNNoNetworkButton | \&H20000 | Hide network button | | CdlOFNExplorer | \&H80000 | Use Explorer-style dialog | | CdlOFNNoDereferenceLinks | \&H100000 | Do not dereference shortcuts | | CdlOFNDontAddToRecent | \&H2000000 | Do not add to recent files | | CdlOFNForcesShowHidden | \&H10000000 | Show hidden files | ### CdlOFNShareViResultConstants | Constant | Value | Description | |------|-----|------| | CdlOFNShareViResultWarn | \&H0 | Warn on sharing violation | | CdlOFNShareViResultNoWarn | \&H1 | Do not warn on sharing violation | | CdlOFNShareViResultFallThrough | \&H2 | Ignore sharing violation | ### CdlCCConstants | Constant | Value | Description | |------|-----|------| | CdlCCRGBInit | \&H1 | Use initial color | | CdlCCFullOpen | \&H2 | Fully open the dialog | | CdlCCPreventFullOpen | \&H4 | Prevent full open | | CdlCCHelpButton | \&H8 | Show help button | | CdlCCSolidColor | \&H80 | Solid colors only | | CdlCCAnyColor | \&H100 | Any color | ### CdlCFConstants | Constant | Value | Description | |------|-----|------| | CdlCFScreenFonts | \&H1 | Screen fonts | | CdlCFPrinterFonts | \&H2 | Printer fonts | | CdlCFHelpButton | \&H4 | Show help button | | CdlCFEffects | \&H100 | Enable effects options | | CdlCFApply | \&H200 | Enable Apply button | | CdlCFScriptsOnly | \&H400 | Script fonts only | | CdlCFNoVectorFonts | \&H800 | Exclude vector fonts | | CdlCFLimitSize | \&H2000 | Limit font size | | CdlCFFixedPitchOnly | \&H4000 | Fixed-pitch fonts only | | CdlCFForceFontExist | \&H10000 | Font must exist | | CdlCFScalableOnly | \&H20000 | Scalable fonts only | | CdlCFTTOnly | \&H40000 | TrueType fonts only | | CdlCFNoFaceSel | \&H80000 | No font name selected | | CdlCFNoStyleSel | \&H100000 | No style selected | | CdlCFNoSizeSel | \&H200000 | No size selected | | CdlCFSelectScript | \&H400000 | Select script | | CdlCFNoScriptSel | \&H800000 | No script selected | | CdlCFNoVertFonts | \&H1000000 | Exclude vertical fonts | ### CdlPDConstants | Constant | Value | Description | |------|-----|------| | CdlPDAllPages | \&H0 | All pages | | CdlPDSelection | \&H1 | Selection | | CdlPDPageNums | \&H2 | Page range | | CdlPDNoSelection | \&H4 | Disable selection | | CdlPDNoPageNums | \&H8 | Disable page range | | CdlPDCollate | \&H10 | Collate copies | | CdlPDPrintToFile | \&H20 | Print to file | | CdlPDPrintSetup | \&H40 | Show print setup | | CdlPDNoWarning | \&H80 | No warning | | CdlPDReturnDC | \&H100 | Return device context | | CdlPDReturnIC | \&H200 | Return information context | | CdlPDReturnDefault | \&H400 | Return default printer | | CdlPDHelpButton | \&H800 | Show help button | | CdlPDUseDevModeCopies | \&H40000 | Use DEVMODE copy count | | CdlPDUseDevModeCopiesAndCollate | \&H40000 | Use DEVMODE copies and collate | | CdlPDDisablePrintToFile | \&H80000 | Disable print to file | | CdlPDCurrentPage | \&H400000 | Current page | | CdlPDHidePrintToFile | \&H100000 | Hide print to file | | CdlPDNoNetworkButton | \&H200000 | Hide network button | | CdlPDNoCurrentPage | \&H800000 | Disable current page | ### CdlPDResultConstants | Constant | Value | Description | |------|-----|------| | CdlPDResultCancel | \&H0 | User cancelled | | CdlPDResultPrint | \&H1 | User chose print | | CdlPDResultApply | \&H2 | User chose apply | ### CdlHelpConstants | Constant | Value | Description | |------|-----|------| | CdlHelpContext | \&H1 | Context help | | CdlHelpQuit | \&H2 | Quit help | | CdlHelpIndex | \&H3 | Help index | | CdlHelpContents | \&H3 | Help contents | | CdlHelpHelpOnHelp | \&H4 | Help on help | | CdlHelpSetIndex | \&H5 | Set help index | | CdlHelpSetContents | \&H5 | Set help contents | | CdlHelpContextPopup | \&H8 | Context popup help | | CdlHelpForceFile | \&H9 | Force help file | | CdlHelpKey | \&H101 | Keyword help | | CdlHelpCommandHelp | \&H102 | Command help | | CdlHelpPartialKey | \&H105 | Partial keyword help | ### CdlPSDConstants | Constant | Value | Description | |------|-----|------| | CdlPSDDefaultMinMargins | \&H0 | Default minimum margins | | CdlPSDMinMargins | \&H1 | Allow setting minimum margins | | CdlPSDMargins | \&H2 | Allow setting margins | | CdlPSDInThousandthsOfInches | \&H4 | In thousandths of inches | | CdlPSDInHundredthsOfMillimeters | \&H8 | In hundredths of millimeters | | CdlPSDDisableMargins | \&H10 | Disable margins | | CdlPSDDisablePrinter | \&H20 | Disable printer button | | CdlPSDNoWarning | \&H80 | No warning | | CdlPSDDisableOrientation | \&H100 | Disable orientation | | CdlPSDDisablePaper | \&H200 | Disable paper | | CdlPSDReturnDefault | \&H400 | Return default settings | | CdlPSDHelpButton | \&H800 | Show help button | | CdlPSDDisablePagePainting | \&H80000 | Disable page painting | | CdlPSDNoNetworkButton | \&H200000 | Hide network button | ### CdlBIFConstants | Constant | Value | Description | |------|-----|------| | CdlBIFReturnOnlyFSDirs | \&H1 | Return file system directories only | | CdlBIFDontGoBelowDomain | \&H2 | Do not go below domain | | CdlBIFStatusText | \&H4 | Include status text | | CdlBIFReturnFSAncestors | \&H8 | Return file system ancestors | | CdlBIFEditBox | \&H10 | Include edit box | | CdlBIFValidate | \&H20 | Validate input | | CdlBIFNewDialogStyle | \&H40 | New dialog style | | CdlBIFBrowseIncludeURLs | \&H80 | Include URLs | | CdlBIFUseNewUI | \&H50 | Use new UI | | CdlBIFUAHint | \&H100 | User hint | | CdlBIFNoNewFolderButton | \&H200 | Hide new folder button | | CdlBIFNoTranslateTargets | \&H400 | Do not translate targets | | CdlBIFBrowseForComputer | \&H1000 | Browse for computer only | | CdlBIFBrowseForPrinter | \&H2000 | Browse for printer only | | CdlBIFBrowseIncludeFiles | \&H4000 | Include files | | CdlBIFShareable | \&H8000& | Shareable | | CdlBIFBrowseFileJunctions | \&H10000 | Browse file junctions | ### CdlFRConstants | Constant | Value | Description | |------|-----|------| | CdlFRDown | \&H1 | Search downward | | CdlFRWholeWord | \&H2 | Match whole word | | CdlFRMatchCase | \&H4 | Case-sensitive | | CdlFRFindNext | \&H8 | Find next | | CdlFRReplace | \&H10 | Replace | | CdlFRReplaceAll | \&H20 | Replace all | | CdlFRHelpButton | \&H80 | Show help button | | CdlFRNoUpDown | \&H400 | Disable direction selection | | CdlFRNoMatchCase | \&H800 | Disable case selection | | CdlFRNoWholeWord | \&H1000 | Disable whole word selection | | CdlFRHideUpDown | \&H4000 | Hide direction selection | | CdlFRHideMatchCase | \&H8000& | Hide case selection | | CdlFRHideWholeWord | \&H10000 | Hide whole word selection | ## Properties ### Object ```vb Property Get Object() As Object ``` Returns the instance of the object itself. ### CancelError ```vb Property Get/Let CancelError() As Boolean ``` Indicates whether an error is raised when the user selects "Cancel". ### HookEvents ```vb Property Get/Let HookEvents() As Boolean ``` Indicates whether the dialog can raise events that require hook callbacks. ### Tag ```vb Property Get/Let Tag() As String ``` Stores additional data needed by the program. ### hDC ```vb Property Get hDC() As LongPtr ``` Returns the device context handle (read-only). ### Flags ```vb Property Get/Let Flags() As Long ``` Returns/sets the dialog option flags. ### DialogTitle ```vb Property Get/Let DialogTitle() As String ``` Sets the string displayed in the dialog title bar. ### MaxFileSize ```vb Property Get/Let MaxFileSize() As Long ``` Returns/sets the maximum size of the open file name. ### FileName ```vb Property Get/Let FileName() As String ``` Returns/sets the path and file name of the selected file. ### FileTitle ```vb Property Get FileTitle() As String ``` Returns the file name of the selected file (without path, read-only). ### FileOffset ```vb Property Get FileOffset() As Integer ``` Returns the zero-based offset from the beginning of the path to the file name (read-only). ### Filter ```vb Property Get/Let Filter() As String ``` Returns/sets the filter displayed in the dialog type list box. ### FilterIndex ```vb Property Get/Let FilterIndex() As Long ``` Returns/sets the default filter index. ### InitDir ```vb Property Get/Let InitDir() As String ``` Returns/sets the initial file directory. ### DefaultExt ```vb Property Get/Let DefaultExt() As String ``` Returns/sets the default file extension. ### Color ```vb Property Get/Let Color() As Long ``` Returns/sets the selected color. ### CustomColors ```vb Property Get/Let CustomColors() As Variant ``` Returns/sets the custom colors available for user selection. ### FontName ```vb Property Get/Let FontName() As String ``` Returns/sets the font name. ### FontSize ```vb Property Get/Let FontSize() As Single ``` Returns/sets the font size (in points). ### FontBold ```vb Property Get/Let FontBold() As Boolean ``` Returns/sets the bold font style. ### FontItalic ```vb Property Get/Let FontItalic() As Boolean ``` Returns/sets the italic font style. ### FontStrikethru ```vb Property Get/Let FontStrikethru() As Boolean ``` Returns/sets the strikethrough font style. ### FontUnderline ```vb Property Get/Let FontUnderline() As Boolean ``` Returns/sets the underline font style. ### FontCharset ```vb Property Get/Let FontCharset() As Integer ``` Returns/sets the font character set. ### FontWeight ```vb Property Get/Let FontWeight() As Integer ``` Returns/sets the font weight (0=Don'tCare, 100=Thin, 200=ExtraLight, 300=Light, 400=Normal, 500=Medium, 600=SemiBold, 700=Bold, 800=ExtraBold, 900=Heavy). ### Min ```vb Property Get/Let Min() As Long ``` Returns/sets the minimum font size (Font dialog) or minimum print page range (Print dialog). ### Max ```vb Property Get/Let Max() As Long ``` Returns/sets the maximum font size (Font dialog) or maximum print page range (Print dialog). ### FromPage ```vb Property Get/Let FromPage() As Long ``` Returns/sets the starting print page. ### ToPage ```vb Property Get/Let ToPage() As Long ``` Returns/sets the ending print page. ### Orientation ```vb Property Get/Let Orientation() As CdlPRORConstants ``` Returns/sets the print orientation. ### PaperSize ```vb Property Get/Let PaperSize() As CdlPRPSConstants ``` Returns/sets the print paper size. ### Copies ```vb Property Get/Let Copies() As Integer ``` Returns/sets the number of print copies. ### PaperBin ```vb Property Get/Let PaperBin() As CdlPRBNConstants ``` Returns/sets the default paper bin. ### PrintQuality ```vb Property Get/Let PrintQuality() As CdlPRPQConstants ``` Returns/sets the print resolution. ### ColorMode ```vb Property Get/Let ColorMode() As CdlPRCMConstants ``` Returns/sets the printer color mode. ### Duplex ```vb Property Get/Let Duplex() As CdlPRDPConstants ``` Returns/sets the duplex printing mode. ### PrinterDefault ```vb Property Get/Let PrinterDefault() As Boolean ``` Returns/sets whether the user selection changes the default printer. ### PrinterDefaultInit ```vb Property Get/Let PrinterDefaultInit() As Boolean ``` Returns/sets whether to always initialize the default printer. ### PrinterDriver ```vb Property Get/Let PrinterDriver() As String ``` Returns/sets the non-default printer driver name. ### PrinterName ```vb Property Get/Let PrinterName() As String ``` Returns/sets the non-default printer device name. ### PrinterPort ```vb Property Get/Let PrinterPort() As String ``` Returns/sets the non-default printer port name. ### HelpFile ```vb Property Get/Let HelpFile() As String ``` Returns/sets the help file name associated with the project. ### HelpCommand ```vb Property Get/Let HelpCommand() As CdlHelpConstants ``` Returns/sets the online help type. ### HelpContext ```vb Property Get/Let HelpContext() As LongPtr ``` Returns/sets the context ID for the help topic. ### HelpKey ```vb Property Get/Let HelpKey() As String ``` Returns/sets the keyword that identifies the help topic. ### PageLeftMargin ```vb Property Get/Let PageLeftMargin() As Long ``` Returns/sets the left margin of the paper (device units). ### PageTopMargin ```vb Property Get/Let PageTopMargin() As Long ``` Returns/sets the top margin of the paper (device units). ### PageRightMargin ```vb Property Get/Let PageRightMargin() As Long ``` Returns/sets the right margin of the paper (device units). ### PageBottomMargin ```vb Property Get/Let PageBottomMargin() As Long ``` Returns/sets the bottom margin of the paper (device units). ### PageLeftMinMargin ```vb Property Get/Let PageLeftMinMargin() As Long ``` Returns/sets the minimum left margin of the paper (device units). ### PageTopMinMargin ```vb Property Get/Let PageTopMinMargin() As Long ``` Returns/sets the minimum top margin of the paper (device units). ### PageRightMinMargin ```vb Property Get/Let PageRightMinMargin() As Long ``` Returns/sets the minimum right margin of the paper (device units). ### PageBottomMinMargin ```vb Property Get/Let PageBottomMinMargin() As Long ``` Returns/sets the minimum bottom margin of the paper (device units). ### RootFolder ```vb Property Get/Let RootFolder() As Variant ``` Returns/sets the root folder for the folder browser dialog. ### FindWhat ```vb Property Get/Let FindWhat() As String ``` Returns/sets the search string for the Find dialog. ### ReplaceWith ```vb Property Get/Let ReplaceWith() As String ``` Returns/sets the replacement string for the Replace dialog. ### Action ```vb Property Let Action() As Integer ``` Sets the type of dialog to display (write-only, 1=Open, 2=Save, 3=Color, 4=Font, 5=Print, 6=Help, 7=Page Setup, 8=Folder Browser, 9=Find, 10=Replace). ## Methods ### ShowOpen ```vb Public Function ShowOpen() As Boolean ``` Displays the Open dialog. Returns True on success. ### ShowSave ```vb Public Function ShowSave() As Boolean ``` Displays the Save dialog. Returns True on success. ### ShowColor ```vb Public Function ShowColor() As Boolean ``` Displays the Color dialog. Returns True on success. ### ShowFont ```vb Public Function ShowFont() As Boolean ``` Displays the Font dialog. Returns True on success. ### ShowPrinter ```vb Public Function ShowPrinter() As Boolean ``` Displays the Print dialog. Returns True on success. ### ShowPrinterEx ```vb Public Function ShowPrinterEx() As Boolean ``` Displays the extended Print dialog (PrintDlgEx). Returns True on success. ### ShowHelp ```vb Public Sub ShowHelp() ``` Displays help. ### ShowPageSetup ```vb Public Function ShowPageSetup() As Boolean ``` Displays the Page Setup dialog. Returns True on success. ### ShowFolderBrowser ```vb Public Function ShowFolderBrowser() As Boolean ``` Displays the Folder Browser dialog. Returns True on success. ### ShowFind ```vb Public Function ShowFind() As Boolean ``` Displays the Find dialog. Returns True on success. ### ShowReplace ```vb Public Function ShowReplace() As Boolean ``` Displays the Replace dialog. Returns True on success. ## Events ### InitDialog ```vb Public Event InitDialog(ByVal Action As Integer, ByVal hDlg As Long) ``` Occurs when the dialog has completed initialization. ### Help ```vb Public Event Help(ByRef Handled As Boolean, ByVal Action As Integer, ByVal hDlg As Long) ``` Occurs when the user clicks the help button in the dialog. ### FileShareViolation ```vb Public Event FileShareViolation(ByVal FileName As String, ByRef Result As CdlOFNShareViResultConstants, ByVal hDlg As Long) ``` Occurs when the user clicks OK in the Open or Save dialog and a network sharing violation occurs. ### FileValidate ```vb Public Event FileValidate(ByVal FileName As String, ByVal FileTitle As String, ByVal FileOffset As Integer, ByRef Cancel As Boolean, ByVal hDlg As Long) ``` Occurs when the user clicks OK in the Open or Save dialog. ### ColorValidate ```vb Public Event ColorValidate(ByRef RGBColor As Long, ByRef Cancel As Boolean, ByVal hDlg As Long) ``` Occurs when the user clicks OK in the Color dialog. ### FontApply ```vb Public Event FontApply(ByVal Flags As Long, ByVal FontName As String, ByVal FontSize As Single, ByVal FontBold As Boolean, ByVal FontItalic As Boolean, ByVal FontStrikethru As Boolean, ByVal FontUnderline As Boolean, ByVal FontCharset As Integer, ByVal RGBColor As Long, ByVal hDlg As Long) ``` Occurs when the user clicks the "Apply" button in the Font dialog. ### FolderBrowserValidateFailed ```vb Public Event FolderBrowserValidateFailed(ByVal Text As String, ByRef Cancel As Boolean, ByVal hDlg As Long) ``` Occurs when the user enters an invalid name in the Folder Browser dialog. ### FindNext ```vb Public Event FindNext() ``` Occurs when the user clicks the "Find Next" button in the Find or Replace dialog. ### Replace ```vb Public Event Replace() ``` Occurs when the user clicks the "Replace" button in the Replace dialog. ### ReplaceAll ```vb Public Event ReplaceAll() ``` Occurs when the user clicks the "Replace All" button in the Replace dialog. ## Code Examples ### Basic Usage ```vb Private Sub cmdOpen_Click() Dim dlg As CommonDialog Set dlg = New CommonDialog dlg.Filter = "Text Files (*.txt)|*.txt|All Files (*.*)|*.*" dlg.FilterIndex = 1 dlg.CancelError = True On Error GoTo Cancelled If dlg.ShowOpen() Then MsgBox "Selected: " & dlg.FileName End If Exit Sub Cancelled: If Err.Number = CdlCancel Then Exit Sub MsgBox "Error: " & Err.Description End Sub ``` ### Using Event Hooks ```vb Private WithEvents dlg As CommonDialog Private Sub cmdFont_Click() Set dlg = New CommonDialog dlg.HookEvents = True dlg.Flags = CdlCFScreenFonts Or CdlCFEffects Or CdlCFLimitSize dlg.Min = 8 dlg.Max = 72 dlg.ShowFont End Sub Private Sub dlg_FontApply(ByVal Flags As Long, ByVal FontName As String, _ ByVal FontSize As Single, ByVal FontBold As Boolean, ByVal FontItalic As Boolean, _ ByVal FontStrikethru As Boolean, ByVal FontUnderline As Boolean, _ ByVal FontCharset As Integer, ByVal RGBColor As Long, ByVal hDlg As Long) Me.Font.Name = FontName Me.Font.Size = FontSize Me.Font.Bold = FontBold Me.Font.Italic = FontItalic End Sub ``` --- --- url: /en/vbman/redis/examples.md --- # Complete Examples This document contains comprehensive usage examples for the Redis client. ## Example 1: Basic String Operations ```vb Sub Example1_BasicString() Dim oRedis As New cRedisClient ' Connect If Not oRedis.Connect() Then Debug.Print "Connection failed: " & oRedis.LastError Exit Sub End If ' Set values oRedis.Set_ "name", "Zhang San" oRedis.Set_ "age", "25" ' Get values Debug.Print "Name: " & oRedis.Get_("name") Debug.Print "Age: " & oRedis.Get_("age") ' Set expiration time oRedis.Expire "name", 300 ' Check remaining time Debug.Print "name remaining TTL: " & oRedis.TTL("name") & " seconds" ' Disconnect oRedis.DisConnect End Sub ``` ## Example 2: Hash Operations ```vb Sub Example2_HashOperations() Dim oRedis As New cRedisClient If Not oRedis.Connect() Then Debug.Print "Connection failed: " & oRedis.LastError Exit Sub End If ' Set user information oRedis.HSet "user:1001", "name", "Li Si" oRedis.HSet "user:1001", "age", "30" oRedis.HSet "user:1001", "city", "Shanghai" oRedis.HSet "user:1001", "email", "lisi@example.com" ' Get single field Debug.Print "User name: " & oRedis.HGet("user:1001", "name") ' Get all fields Dim oDict As Dictionary Set oDict = oRedis.HGetAll("user:1001") Debug.Print vbCrLf & "User details:" Dim vKey As Variant For Each vKey In oDict.Keys Debug.Print " " & vKey & ": " & oDict(vKey) Next oRedis.DisConnect End Sub ``` ## Example 3: List Operations ```vb Sub Example3_ListOperations() Dim oRedis As New cRedisClient If Not oRedis.Connect() Then Debug.Print "Connection failed: " & oRedis.LastError Exit Sub End If ' Clear existing list oRedis.Del "tasks" ' Add tasks oRedis.RPush "tasks", "Task1" oRedis.RPush "tasks", "Task2" oRedis.RPush "tasks", "Task3" oRedis.RPush "tasks", "Task4" oRedis.RPush "tasks", "Task5" ' Get list length Debug.Print "Task list length: " & oRedis.lLen("tasks") ' Get all tasks Dim vTasks As Variant vTasks = oRedis.LRange("tasks", 0, -1) Debug.Print vbCrLf & "All tasks:" Dim i As Long For i = 0 To UBound(vTasks) Debug.Print " " & (i + 1) & ". " & vTasks(i) Next ' Process first task Debug.Print vbCrLf & "Processing task: " & oRedis.LPop("tasks") Debug.Print "Remaining tasks: " & oRedis.lLen("tasks") oRedis.DisConnect End Sub ``` ## Example 4: Transaction Operations ```vb Sub Example4_Transaction() Dim oRedis As New cRedisClient If Not oRedis.Connect() Then Debug.Print "Connection failed: " & oRedis.LastError Exit Sub End If ' Initialize counter oRedis.Set_ "counter", "0" Debug.Print "Initial count: " & oRedis.Get_("counter") ' Start transaction oRedis.Multi ' Execute multiple increment operations oRedis.Incr "counter" oRedis.Incr "counter" oRedis.Incr "counter" ' Commit transaction Dim vResults As Variant vResults = oRedis.Exec() Debug.Print "Transaction execution results:" If IsArray(vResults) Then For i = 0 To UBound(vResults) Debug.Print " Operation " & (i + 1) & " result: " & vResults(i) Next End If Debug.Print "Final count: " & oRedis.Get_("counter") oRedis.DisConnect End Sub ``` ## Example 5: Set and Sorted Set Operations ```vb Sub Example5_Sets() Dim oRedis As New cRedisClient If Not oRedis.Connect() Then Debug.Print "Connection failed: " & oRedis.LastError Exit Sub End If ' Use Set to store tags oRedis.SAdd "post:1:tags", "Technology", "Programming", "Redis", "VB6" Debug.Print "Article tags count: " & oRedis.SCard("post:1:tags") Dim vTags As Variant vTags = oRedis.SMembers("post:1:tags") Debug.Print "All tags:" Dim i As Long For i = 0 To UBound(vTags) Debug.Print " - " & vTags(i) Next ' Use Sorted Set to store leaderboard oRedis.ZAdd "leaderboard", 1000, "Player A" oRedis.ZAdd "leaderboard", 1500, "Player B" oRedis.ZAdd "leaderboard", 800, "Player C" oRedis.ZAdd "leaderboard", 2000, "Player D" Debug.Print vbCrLf & "Leaderboard (sorted by score ascending):" vTags = oRedis.ZRange("leaderboard", 0, -1) For i = 0 To UBound(vTags) Debug.Print " " & (i + 1) & ". " & vTags(i) Next Debug.Print vbCrLf & "Leaderboard (with scores):" vTags = oRedis.ZRange("leaderboard", 0, -1, True) For i = 0 To UBound(vTags) Step 2 If i + 1 <= UBound(vTags) Then Debug.Print " " & vTags(i) & ": " & vTags(i + 1) & " points" End If Next oRedis.DisConnect End Sub ``` ## Example 6: Database Switching and Batch Operations ```vb Sub Example6_MultipleDb() Dim oRedis As New cRedisClient If Not oRedis.Connect() Then Debug.Print "Connection failed: " & oRedis.LastError Exit Sub End If ' Store user data in database 0 oRedis.SelectDb 0 oRedis.Set_ "user:1", "Zhang San" oRedis.Set_ "user:2", "Li Si" Debug.Print "Users in database 0: " Dim vKeys As Variant vKeys = oRedis.Keys("user:*") Dim i As Long If IsArray(vKeys) Then For i = 0 To UBound(vKeys) Debug.Print " " & vKeys(i) & ": " & oRedis.Get_(vKeys(i)) Next End If ' Store configuration data in database 1 oRedis.SelectDb 1 oRedis.Set_ "config:appname", "MyApp" oRedis.Set_ "config:version", "1.0.0" oRedis.Set_ "config:debug", "false" Debug.Print vbCrLf & "Configuration in database 1: " vKeys = oRedis.Keys("config:*") If IsArray(vKeys) Then For i = 0 To UBound(vKeys) Debug.Print " " & vKeys(i) & ": " & oRedis.Get_(vKeys(i)) Next End If ' Batch get configuration Dim vConfigs As Variant vConfigs = oRedis.MGet("config:appname", "config:version") Debug.Print vbCrLf & "Configuration info:" If IsArray(vConfigs) Then For i = 0 To UBound(vConfigs) Debug.Print " " & vConfigs(i) Next End If ' Switch back to database 0 oRedis.SelectDb 0 Debug.Print vbCrLf & "Current database: " & oRedis.DbIndex oRedis.DisConnect End Sub ``` ## Example 7: Comprehensive Application - User Session Management ```vb Sub Example7_UserSession() Dim oRedis As New cRedisClient If Not oRedis.Connect() Then Debug.Print "Connection failed: " & oRedis.LastError Exit Sub End If Dim sUserId As String sUserId = "user:123" ' Use Hash to store user information oRedis.HSet sUserId, "name", "Zhang San" oRedis.HSet sUserId, "email", "zhangsan@example.com" oRedis.HSet sUserId, "login_time", CStr(Now()) ' Use Set to store user tags oRedis.SAdd sUserId & ":tags", "VIP", "Active", "Verified" ' Use List to store recent operations oRedis.RPush sUserId & ":history", "Login" oRedis.RPush sUserId & ":history", "Browse products" oRedis.RPush sUserId & ":history", "Add to cart" ' Set session expiration time (30 minutes) oRedis.Expire sUserId, 1800 oRedis.Expire sUserId & ":tags", 1800 oRedis.Expire sUserId & ":history", 1800 ' Display user information Debug.Print "=== User Information ===" Dim oDict As Dictionary Set oDict = oRedis.HGetAll(sUserId) Dim vKey As Variant For Each vKey In oDict.Keys Debug.Print vKey & ": " & oDict(vKey) Next ' Display user tags Debug.Print vbCrLf & "=== User Tags ===" Dim vTags As Variant vTags = oRedis.SMembers(sUserId & ":tags") For i = 0 To UBound(vTags) Debug.Print "- " & vTags(i) Next ' Display recent operations Debug.Print vbCrLf & "=== Recent Operations ===" Dim vHistory As Variant vHistory = oRedis.LRange(sUserId & ":history", -5, -1) For i = 0 To UBound(vHistory) Debug.Print (i + 1) & ". " & vHistory(i) Next oRedis.DisConnect End Sub ``` ## Example 8: Comprehensive Application - E-commerce System ```vb Sub Example8_ECommerce() Dim oRedis As New cRedisClient If Not oRedis.Connect() Then Debug.Print "Connection failed: " & oRedis.LastError Exit Sub End If ' 1. Product information (Hash) Debug.Print "=== Product Information ===" oRedis.HSet "product:1001", "name", "iPhone 15" oRedis.HSet "product:1001", "price", "5999" oRedis.HSet "product:1001", "stock", "100" Debug.Print "Product: " & oRedis.HGet("product:1001", "name") Debug.Print "Price: ¥" & oRedis.HGet("product:1001", "price") Debug.Print "Stock: " & oRedis.HGet("product:1001", "stock") ' 2. Shopping cart (Hash) Debug.Print vbCrLf & "=== Shopping Cart ===" oRedis.HSet "cart:user123", "product:1001", "2" oRedis.HSet "cart:user123", "product:1002", "1" Dim oCart As Dictionary Set oCart = oRedis.HGetAll("cart:user123") Dim lTotal As Long lTotal = 0 For Each vKey In oCart.Keys Debug.Print vKey & ": " & oCart(vKey) & " items" lTotal = lTotal + CLng(oCart(vKey)) Next Debug.Print "Total items: " & lTotal ' 3. Hot products (Sorted Set) Debug.Print vbCrLf & "=== Hot Products ===" oRedis.ZAdd "hot:products", 100, "product:1001" oRedis.ZAdd "hot:products", 80, "product:1002" oRedis.ZAdd "hot:products", 150, "product:1003" Dim vHot As Variant vHot = oRedis.ZRange("hot:products", -3, -1) For i = UBound(vHot) To 0 Step -1 Dim sProductId As String sProductId = vHot(i) Debug.Print (UBound(vHot) - i + 1) & ". " & oRedis.HGet(sProductId, "name") Next ' 4. Order queue (List) Debug.Print vbCrLf & "=== Order Queue ===" oRedis.RPush "orders:pending", "ORDER001: " & Now() oRedis.RPush "orders:pending", "ORDER002: " & Now() Dim vOrders As Variant vOrders = oRedis.LRange("orders:pending", 0, -1) For i = 0 To UBound(vOrders) Debug.Print vOrders(i) Next ' 5. User tags (Set) Debug.Print vbCrLf & "=== User Tags ===" oRedis.SAdd "user:123:tags", "VIP", "Active", "New user" vTags = oRedis.SMembers("user:123:tags") For i = 0 To UBound(vTags) Debug.Print "- " & vTags(i) Next oRedis.DisConnect End Sub ``` ## Example 9: Error Handling ```vb Sub Example9_ErrorHandling() Dim oRedis As New cRedisClient ' Connect If Not oRedis.Connect() Then Debug.Print "Connection failed: " & oRedis.LastError Exit Sub End If ' Check for errors If oRedis.LastError <> "" Then Debug.Print "Connection error: " & oRedis.LastError oRedis.DisConnect Exit Sub End If ' Execute operations oRedis.Set_ "test", "value" If oRedis.LastError <> "" Then Debug.Print "Operation error: " & oRedis.LastError Else Debug.Print "Operation successful" End If ' Get non-existent key Dim sValue As String sValue = oRedis.Get_("nonexistent") If sValue = "" Then Debug.Print "Key does not exist" End If oRedis.DisConnect End Sub ``` ## Example 10: Connection Management Best Practices ```vb Sub Example10_ConnectionManagement() Dim oRedis As cRedisClient Set oRedis = New cRedisClient ' Connect If Not oRedis.Connect() Then Debug.Print "Connection failed: " & oRedis.LastError GoTo Cleanup End If ' Use connection oRedis.Set_ "key", "value" Debug.Print "Set value: " & oRedis.Get_("key") Cleanup: ' Ensure disconnection If Not oRedis Is Nothing Then If oRedis.Connected Then oRedis.DisConnect End If Set oRedis = Nothing End If End Sub ``` ## Running Examples You can copy the above code directly into a VB6 or VBA environment. Ensure: 1. Added reference to `cRedisClient` class 2. Added reference to `Dictionary` (Microsoft Scripting Runtime) 3. Redis server is running and accessible ## Example Output After running the above examples, you will see similar output in the Immediate Window: ``` === User Information === name: Zhang San email: zhangsan@example.com login_time: 2024-01-01 10:30:00 === User Tags === - VIP - Active - Verified === Recent Operations === 1. Login 2. Browse products 3. Add to cart ``` ## More Examples For more specific scenario examples, please refer to: * [Connection Management](./connection.md) - Connection-related examples * [String Operations](./string-operations.md) - String operation examples * [Hash Operations](./hash-operations.md) - Hash operation examples * [List Operations](./list-operations.md) - List operation examples * [Set Operations](./set-operations.md) - Set operation examples * [Sorted Set Operations](./sorted-set-operations.md) - Sorted set operation examples * [Transaction Operations](./transaction.md) - Transaction operation examples --- --- url: /en/vbman/database/connection.md --- # Connection Management This document details the database connection management features of the cDataBase class, including connection, disconnection, and connection pool. *** ## Table of Contents * [Database Connection](#database-connection) * [Supported Database Types](#supported-database-types) * [Connection String Configuration](#connection-string-configuration) * [Connection State Management](#connection-state-management) * [Connection Pool Management](#connection-pool-management) * [Error Handling](#error-handling) *** ## Database Connection ### Connect Method The `Connect` method is used to establish a database connection. #### Syntax ```vb Function Connect( _ ByVal DbType As enumDbType, _ Optional ByVal DbAddress As String = "127.0.0.1,1433", _ Optional ByVal username As String = "sa", _ Optional ByVal password As String = "Sa123456", _ Optional ByVal DefaultDataBase As String = "master") As Boolean ``` #### Parameters | Parameter | Type | Description | | --------- | ---- | ----------- | | `DbType` | `enumDbType` | Database type (required) | | `DbAddress` | `String` | Database address (optional, default "127.0.0.1,1433") | | `username` | `String` | Username (optional, default "sa") | | `password` | `String` | Password (optional, default "Sa123456") | | `DefaultDataBase` | `String` | Default database (optional, default "master") | #### Return Value * `True` - Connection successful * `False` - Connection failed (view error via `LastErr`) #### Example ```vb Dim db As New VBMAN.cDataBase ' SQL Server connection If db.Connect(VBMAN.enumDbType_MsSql, "127.0.0.1,1433", "sa", "password", "mydb") Then Debug.Print "Connection successful" Else Debug.Print "Connection failed: " & db.LastErr End If ``` *** ## Supported Database Types ### enumDbType Enumeration ```vb Public Enum enumDbType Access = 1 ' Microsoft Access Mysql = 2 ' MySQL MsSql = 3 ' Microsoft SQL Server Csv = 4 ' CSV file End Enum ``` ### SQL Server Connection ```vb ' Basic connection db.Connect VBMAN.enumDbType_MsSql, "127.0.0.1,1433", "sa", "password", "master" ' Using named instance db.Connect VBMAN.enumDbType_MsSql, "SERVER\INSTANCE,1433", "sa", "password", "mydb" ' Using Windows authentication (requires modifying connection string) ' Note: Need to modify connection string internally to support Windows authentication ``` ### MySQL Connection ```vb ' Basic connection (default port 3306) db.Connect VBMAN.enumDbType_Mysql, "localhost:3306", "root", "password", "testdb" ' Specify port db.Connect VBMAN.enumDbType_Mysql, "192.168.1.100:3306", "user", "pwd", "mydb" ' Using Chinese comma (auto-converted) db.Connect VBMAN.enumDbType_Mysql, "localhost，3306", "root", "pwd", "testdb" ``` ### Access Connection ```vb ' Connect to Access database file db.Connect VBMAN.enumDbType_Access, "C:\data\mydb.mdb" ' Using relative path (auto-converted to absolute path) db.Connect VBMAN.enumDbType_Access, "data\mydb.mdb" ``` ### CSV Connection ```vb ' Connect to CSV file directory db.Connect VBMAN.enumDbType_Csv, "C:\data\csvfiles" ' CSV files are treated as tables for querying db.Sql("SELECT * FROM data.csv").Query ``` *** ## Connection String Configuration ### Auto-generated Connection Strings The library automatically generates connection strings based on database type: #### SQL Server ``` Driver={SQL Server};Server=127.0.0.1,1433;Uid=sa;pwd=password;Database=mydb; ``` #### MySQL ``` Driver={MySQL ODBC 5.1 Driver};Server=localhost:3306;Uid=root;pwd=password;Database=testdb; ``` #### Access ``` Driver={Microsoft Access Driver (*.mdb)};Dbq=C:\data\mydb.mdb; ``` #### CSV ``` Driver={Microsoft Text Driver (*.txt; *.csv)};DefaultDir=C:\data\csvfiles ``` ### Custom Connection String If you need to use a custom connection string, set it before connecting: ```vb ' Note: Need to modify internally to support custom connection strings ' Or use ADO Connection object directly Set db.Conn = New ADODB.Connection db.Conn.ConnectionString = "Provider=SQLOLEDB;Data Source=...;..." db.Conn.Open db.IsConnect = True ``` *** ## Connection State Management ### IsConnect Property The `IsConnect` property indicates the current connection state. ```vb ' Check connection state If db.IsConnect Then Debug.Print "Connected" Else Debug.Print "Not connected" End If ``` ### CheckConnection Method The `CheckConnection` method checks the connection state and attempts to reconnect. ```vb ' Check and reconnect If Not db.CheckConnection Then Debug.Print "Connection lost, attempting to reconnect..." db.Connect VBMAN.enumDbType_MsSql, "127.0.0.1,1433", "sa", "pwd", "mydb" End If ``` ### Connection State Check Check connection state before executing operations: ```vb If Not db.IsConnect Then Debug.Print "Database not connected" Exit Sub End If ' Execute query db.Sql("SELECT * FROM users").Query ``` *** ## Connection Pool Management ### ConnInst Method The `ConnInst` method creates or retrieves a database instance from the connection pool. #### Syntax ```vb Function ConnInst(ByVal InstName As String, Optional ByVal IsCloneMasterConnection As Boolean = True) As cDataBase ``` #### Parameters | Parameter | Type | Description | | --------- | ---- | ----------- | | `InstName` | `String` | Instance name (required) | | `IsCloneMasterConnection` | `Boolean` | Whether to clone master connection (optional, default True) | #### Example ```vb Dim db As New VBMAN.cDataBase ' Master connection db.Connect VBMAN.enumDbType_MsSql, "127.0.0.1,1433", "sa", "pwd", "mydb" ' Create connection instance 1 (clone master connection) Dim db1 As VBMAN.cDataBase Set db1 = db.ConnInst("db1", True) db1.Sql("SELECT * FROM table1").Query ' Create connection instance 2 (independent connection) Dim db2 As VBMAN.cDataBase Set db2 = db.ConnInst("db2", False) db2.Connect VBMAN.enumDbType_Mysql, "localhost:3306", "root", "pwd", "testdb" db2.Sql("SELECT * FROM table2").Query ' Get existing instance Set db1 = db.ConnInst("db1") ``` ### ConnInstRemove Method The `ConnInstRemove` method removes an instance from the connection pool. #### Syntax ```vb Sub ConnInstRemove(Optional ByVal InstName As String) ``` #### Example ```vb ' Remove specified instance db.ConnInstRemove "db1" ' Remove all instances db.ConnInstRemove "" ``` ### Connection Pool Usage Scenarios #### Scenario 1: Multi-database Operations ```vb Dim db As New VBMAN.cDataBase ' Main database db.Connect VBMAN.enumDbType_MsSql, "127.0.0.1,1433", "sa", "pwd", "mydb" ' Log database Dim dbLog As VBMAN.cDataBase Set dbLog = db.ConnInst("log", False) dbLog.Connect VBMAN.enumDbType_Mysql, "192.168.1.100:3306", "loguser", "pwd", "logdb" ' Use different databases db.Sql("SELECT * FROM users").Query dbLog.Sql("INSERT INTO logs (msg) VALUES ('test')").Exec ``` #### Scenario 2: Dynamic Database Switching ```vb Dim db As New VBMAN.cDataBase ' Create connections dynamically based on configuration Function GetDatabase(sConfigName As String) As VBMAN.cDataBase Dim dbInst As VBMAN.cDataBase Set dbInst = db.ConnInst(sConfigName, False) ' Connect to different databases based on configuration Select Case sConfigName Case "main" dbInst.Connect VBMAN.enumDbType_MsSql, "127.0.0.1,1433", "sa", "pwd", "maindb" Case "backup" dbInst.Connect VBMAN.enumDbType_Mysql, "192.168.1.100,3306", "user", "pwd", "backupdb" End Select Set GetDatabase = dbInst End Function ' Usage Dim dbMain As VBMAN.cDataBase Set dbMain = GetDatabase("main") dbMain.Sql("SELECT * FROM users").Query ``` *** ## Disconnect Connection ### Disconnect Method The `Disconnect` method closes the database connection. #### Syntax ```vb Function Disconnect() As Boolean ``` #### Functionality * Close database connection * Close recordset * Release resources * Auto rollback incomplete transactions #### Example ```vb ' Disconnect If db.Disconnect Then Debug.Print "Disconnected" End If ``` ### Auto Disconnect The class automatically disconnects when destroyed: ```vb Private Sub Form_Unload(Cancel As Integer) ' No need to manually call Disconnect, class handles automatically Set db = Nothing End Sub ``` *** ## Error Handling ### Error Properties | Property | Type | Description | | -------- | ---- | ----------- | | `LastErr` | `String` | Last error message (full description) | | `LastErrNumber` | `Long` | Last error code | | `LastErrDescription` | `String` | Last error description | ### Error Handling Example ```vb ' Connection error handling If Not db.Connect(VBMAN.enumDbType_MsSql, "127.0.0.1,1433", "sa", "pwd", "mydb") Then Debug.Print "Connection failed" Debug.Print "Error code: " & db.LastErrNumber Debug.Print "Error description: " & db.LastErrDescription Debug.Print "Full info: " & db.LastErr Exit Sub End If ' Query error handling If Not db.Sql("SELECT * FROM users").Query Then Debug.Print "Query failed: " & db.LastErr Exit Sub End If ``` ### Common Connection Errors #### Error 1: Cannot connect to server ``` Error code: -2147467259 Error description: [Microsoft][ODBC SQL Server Driver][DBNETLIB]SQL Server does not exist or access denied ``` **Solution**: * Check if database service is running * Verify server address and port * Check firewall settings #### Error 2: Login failed ``` Error code: -2147467259 Error description: [Microsoft][ODBC SQL Server Driver][SQL Server]Login failed for user 'sa' ``` **Solution**: * Verify username and password * Check SQL Server authentication mode * Confirm user permissions #### Error 3: Database does not exist ``` Error code: -2147467259 Error description: [Microsoft][ODBC SQL Server Driver][SQL Server]Cannot open database requested in login ``` **Solution**: * Verify database name * Check if database exists * Confirm user has access permissions *** ## Best Practices ### 1. Connection Management ```vb ' Recommended: Connect when needed, disconnect when done Private Sub ProcessData() Dim db As New VBMAN.cDataBase If db.Connect(VBMAN.enumDbType_MsSql, "127.0.0.1,1433", "sa", "pwd", "mydb") Then ' Execute operations db.Sql("SELECT * FROM users").Query End If db.Disconnect Set db = Nothing End Sub ``` ### 2. Connection Reuse ```vb ' Recommended: Keep connection for frequent operations Private m_DB As VBMAN.cDataBase Private Sub Form_Load() Set m_DB = New VBMAN.cDataBase m_DB.Connect VBMAN.enumDbType_MsSql, "127.0.0.1,1433", "sa", "pwd", "mydb" End Sub Private Sub Form_Unload(Cancel As Integer) If Not m_DB Is Nothing Then m_DB.Disconnect Set m_DB = Nothing End If End Sub ``` ### 3. Error Handling ```vb ' Recommended: Always check return values and handle errors If Not db.Connect(...) Then MsgBox "Connection failed: " & db.LastErr, vbCritical Exit Sub End If ``` *** **Last Updated**: 2026-01-21 --- --- url: /en/vbman/redis/connection.md --- # Connection Management ## Basic Connection ### Connect to Local Redis Server ```vb Dim oRedis As New cRedisClient ' Connect to local Redis server If oRedis.Connect() Then Debug.Print "Connected successfully!" Else Debug.Print "Connection failed: " & oRedis.LastError End If ``` ### Connect to Specified Server ```vb Dim oRedis As New cRedisClient ' Connect to specified address and port If oRedis.Connect("192.168.1.100", 6379) Then Debug.Print "Connected successfully!" End If ``` ### Connect with Password Authentication ```vb Dim oRedis As New cRedisClient ' Connect and use password authentication If oRedis.Connect("127.0.0.1", 6379, "mypassword") Then Debug.Print "Connected successfully!" End If ``` ### Connect with ACL Username and Password (Redis 6.0+) ```vb Dim oRedis As New cRedisClient ' Use ACL authentication (requires Redis 6.0+ with ACL user configured) If oRedis.Connect("127.0.0.1", 6379, "mypassword", "myusername") Then Debug.Print "ACL authentication connected successfully!" End If ``` ### Set Timeout ```vb Dim oRedis As New cRedisClient ' Set timeout to 10 seconds oRedis.Timeout = 10 If oRedis.Connect() Then Debug.Print "Connected successfully!" End If ``` ### Disconnect ```vb oRedis.DisConnect ``` ## Connection Status Check Check connection status before executing operations: ```vb ' Check internal connection flag If Not oRedis.Connected Then Debug.Print "Not connected to Redis server" End If ' Check actual Socket connection status (more accurate, syncs internal flag) If Not oRedis.IsConnected Then Debug.Print "Socket disconnected, attempting to reconnect..." If Not oRedis.Connect() Then Debug.Print "Reconnection failed: " & oRedis.LastError Exit Sub End If End If ``` ## Event Handling ### OnDisconnected - Disconnection Event ```vb ' Declare WithEvents variable in class module Private WithEvents m_oRedis As cRedisClient Private Sub m_oRedis_OnDisconnected() Debug.Print "Redis connection lost" ' Implement reconnection logic here End Sub ``` ### OnError - Error Event ```vb Private Sub m_oRedis_OnError(ByVal ErrorMsg As String) Debug.Print "Redis error: " & ErrorMsg ' Implement error handling logic here End Sub ``` ## Connection Best Practices ### 1. Using Pattern ```vb Sub DoRedisWork() Dim oRedis As New cRedisClient If Not oRedis.Connect() Then Debug.Print "Connection failed" Exit Sub End If ' Execute operations oRedis.Set_ "key", "value" ' Ensure disconnection oRedis.DisConnect Set oRedis = Nothing End Sub ``` ### 2. Error Handling ```vb Sub SafeRedisOperation() Dim oRedis As New cRedisClient On Error GoTo ErrorHandler If Not oRedis.Connect() Then Debug.Print "Connection failed: " & oRedis.LastError Exit Sub End If ' Execute operations oRedis.Set_ "key", "value" ' Check for errors If oRedis.LastError <> "" Then Debug.Print "Operation error: " & oRedis.LastError End If Exit Sub ErrorHandler: Debug.Print "Error occurred: " & Err.Description If oRedis.Connected Then oRedis.DisConnect End If End Sub ``` ### 3. Heartbeat Keep-alive ```vb Dim oRedis As New cRedisClient ' Connect to Redis If oRedis.Connect("127.0.0.1", 6379, "mypassword") Then ' Set heartbeat interval (seconds), default 30 seconds oRedis.HeartbeatInterval = 30 ' Start heartbeat (periodically sends PING to keep connection active) oRedis.StartHeartbeat ' Execute business operations... oRedis.Set_ "key", "value" ' Stop heartbeat and disconnect oRedis.StopHeartbeat oRedis.DisConnect End If ``` ### 4. Connection Pool Example ```vb ' Simple connection manager example Private m_oRedis As cRedisClient Function GetRedisConnection() As cRedisClient If m_oRedis Is Nothing Then Set m_oRedis = New cRedisClient If Not m_oRedis.Connect() Then Debug.Print "Failed to create connection: " & m_oRedis.LastError Set GetRedisConnection = Nothing Exit Function End If End If ' Check if connection is still valid If Not m_oRedis.Connected Then If Not m_oRedis.Connect() Then Debug.Print "Reconnection failed: " & m_oRedis.LastError Set GetRedisConnection = Nothing Exit Function End If End If Set GetRedisConnection = m_oRedis End Function Sub CloseRedisConnection() If Not m_oRedis Is Nothing Then m_oRedis.StopHeartbeat ' Stop heartbeat first m_oRedis.DisConnect Set m_oRedis = Nothing End If End Sub ``` ## Automatic Reconnection Since v1.x, auto-reconnect is enabled by default. When connection drops unexpectedly: * `Connected` / `IsConnected` returns `False` * Commands will automatically try to reconnect once * If reconnection succeeds, command continues; if fails, error is raised * Combined with heartbeat mechanism to detect dead connections promptly ```vb ' Disable auto-reconnect (not recommended) oRedis.AutoReconnect = False ' Enable auto-reconnect (default) oRedis.AutoReconnect = True ``` --- --- url: /en/CONTACT.md --- # Contact Us Feel free to reach out to us through the following methods: ## Author Information | Item | Information | | ------------ | ------------------------------------- | | Author Name | woeoio | | Website Blog | [https://vb6.pro](https://vb6.pro/) | | Person Site | [https://a-vi.com](https://a-vi.com/) | ## Contact Methods | Type | Content | | -------- | ---------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------- | | Email | 215879458@qq.com | | QQ Group | [Join Group](http://qm.qq.com/cgi-bin/qm/qr?_wv=1027\&k=maQtC3a5Zxb3gMLvwpj6oE5fwmZGCOlY\&authKey=8%2FhBgSMLqADLatzXghFXO5BIBa%2BxSoHO%2FHFvtbZQk2kURUx%2FegxZukzAvhSPX6WJ\&noverify=0\&group_code=915520648) QQGroup: 915520648 | ## Community Join our QQ Group to exchange experiences and share techniques with other VB6 developers: ::: tip Note The group has active VB6 developers. Feel free to ask questions and share your experience. ::: ## Feedback & Suggestions If you encounter any issues or have suggestions during your use, please: 1. Join the QQ Group and provide direct feedback 2. Send an email 3. Ask questions on relevant documentation pages Thank you for your attention and support! --- --- url: /zh/vbman/httpserver/cookie.md --- # Cookie 管理详解 ## 简介 `cHttpServerCookies` 提供完整的 Cookie 管理功能，包括： * 解析请求中的 Cookie * 设置响应的 Cookie * 支持所有标准 Cookie 属性（Domain、Path、Expires、Secure、HttpOnly、SameSite） ## 核心类 | 类名 | 说明 | | ----------------------- | ---------------- | | `cHttpServerCookies` | Cookie 集合管理 | | `cHttpServerCookieAttr` | 单个 Cookie 属性 | ## Cookie 属性详解 ### cHttpServerCookieAttr | 属性 | 类型 | 说明 | | ---------- | ------- | -------------------- | | `Value` | String | Cookie 值 | | `Domain` | String | 作用域名 | | `Path` | String | 作用路径（默认 "/"） | | `Expires` | Variant | 过期时间 | | `Secure` | Boolean | 仅 HTTPS 传输 | | `HttpOnly` | Boolean | 禁止 JavaScript 访问 | | `SameSite` | String | SameSite 策略 | ## 快速开始 ### 读取请求 Cookie ```vb Public Sub ShowCookie(ctx As cHttpServerContext) ' 检查 Cookie 是否存在 If ctx.Cookies.Exists("username") Then Dim username As String username = ctx.Cookies.Cookie("username").Value ctx.Response.Text "用户名: " & username Else ctx.Response.Text "未找到 Cookie" End If End Sub ``` ### 设置响应 Cookie ```vb Public Sub SetCookie(ctx As cHttpServerContext) ' 设置简单 Cookie ctx.Cookies.Cookie("username").Value = "张三" ' 设置带过期时间的 Cookie With ctx.Cookies.Cookie("token") .Value = "abc123" .Expires = DateAdd("d", 7, Now) ' 7天后过期 .Path = "/" End With ' 设置安全 Cookie With ctx.Cookies.Cookie("session") .Value = GenerateToken() .HttpOnly = True ' 禁止 JS 访问 .Secure = True ' 仅 HTTPS .SameSite = "Strict" ' 防止 CSRF .Expires = DateAdd("h", 2, Now) ' 2小时后过期 End With ctx.Response.Json Nothing, 0, "Cookie 已设置" End Sub ``` ### 删除 Cookie ```vb Public Sub DeleteCookie(ctx As cHttpServerContext) ' 将过期时间设为过去即可删除 ctx.Cookies.Cookie("username").Expires = DateAdd("d", -1, Now) ctx.Response.Json Nothing, 0, "Cookie 已删除" End Sub ``` ## 完整示例 ### 记住登录功能 ```vb ' cAuthController.cls ' POST /login Public Sub Login(ctx As cHttpServerContext) Dim username As String, password As String Dim remember As Boolean username = ctx.Request.Form("username") password = ctx.Request.Form("password") remember = (ctx.Request.Form("remember") = "true") ' 验证账号密码 If Not ValidateUser(username, password) Then ctx.Response.Json Nothing, 1, "用户名或密码错误" Exit Sub End If ' 生成 Token Dim token As String token = GenerateToken(username) ' 设置 Session ctx.Session("user_id") = GetUserId(username) ' 设置 Cookie With ctx.Cookies.Cookie("auth_token") .Value = token .Path = "/" .HttpOnly = True .SameSite = "Lax" If remember Then ' 记住登录：7天 .Expires = DateAdd("d", 7, Now) Else ' 不记住：浏览器关闭失效 .Expires = Empty End If End With ctx.Response.Json Nothing, 0, "登录成功" End Sub ' GET /auto-login Public Sub AutoLogin(ctx As cHttpServerContext) ' 检查 Cookie Token If Not ctx.Cookies.Exists("auth_token") Then ctx.Response.State401 "未登录" Exit Sub End If Dim token As String token = ctx.Cookies.Cookie("auth_token").Value ' 验证 Token If Not ValidateToken(token) Then ctx.Response.State401 "登录已过期" Exit Sub End If ' 自动登录成功 Dim username As String username = GetUsernameFromToken(token) ctx.Session("user_id") = GetUserId(username) ctx.Response.Json Nothing, 0, "自动登录成功" End Sub ' GET /logout Public Sub Logout(ctx As cHttpServerContext) ' 清除 Session ctx.Session.Abandon ' 删除 Cookie ctx.Cookies.Cookie("auth_token").Expires = DateAdd("d", -1, Now) ctx.Response.Json Nothing, 0, "退出成功" End Sub ``` ### 多语言支持 ```vb Public Sub SetLanguage(ctx As cHttpServerContext) Dim lang As String lang = ctx.Request.QueryString("lang") ' 设置语言 Cookie，1年过期 With ctx.Cookies.Cookie("language") .Value = lang .Path = "/" .Expires = DateAdd("yyyy", 1, Now) End With ctx.Response.Json Nothing, 0, "语言已设置: " & lang End Sub Public Sub GetLanguage(ctx As cHttpServerContext) Dim lang As String ' 优先从 Cookie 获取 If ctx.Cookies.Exists("language") Then lang = ctx.Cookies.Cookie("language").Value Else ' 默认语言 lang = "zh-CN" End If Dim result As New Dictionary result("language") = lang ctx.Response.Json result End Sub ``` ## SameSite 属性详解 | 值 | 说明 | 场景 | | -------- | --------------------------------- | ---------------------- | | `Strict` | 仅同站请求发送 Cookie | 高安全性（银行、支付） | | `Lax` | 顶级导航时发送，iframe/图片不发送 | 平衡安全与体验（推荐） | | `None` | 所有请求都发送（需配合 Secure） | 跨站需求（OAuth） | ```vb ' Strict - 最严格 ctx.Cookies.Cookie("high_security").SameSite = "Strict" ' Lax - 推荐 ctx.Cookies.Cookie("session").SameSite = "Lax" ' None - 跨站需要 ctx.Cookies.Cookie("oauth_state").SameSite = "None" ctx.Cookies.Cookie("oauth_state").Secure = True ' None 必须配合 Secure ``` ## Cookie 安全建议 ```vb ' 安全配置示例 With ctx.Cookies.Cookie("session_id") ' 值加密存储 .Value = Encrypt(sessionValue) ' 路径限制 .Path = "/api" ' 只在 /api 路径下发送 ' 域名限制 .Domain = ".example.com" ' 子域共享 ' HTTPS 传输 .Secure = True ' 禁止 JS 访问 .HttpOnly = True ' 防止 CSRF .SameSite = "Strict" ' 合理过期时间 .Expires = DateAdd("h", 2, Now) ' 2小时 End With ``` *** **最后更新**: 2026-05-17 --- --- url: /en/vbman/httpserver/cookie.md --- # Cookie Management Guide ## Overview `cHttpServerCookies` provides complete Cookie management functionality: * Parse cookies in requests * Set cookies in responses * Support all standard Cookie attributes (Domain, Path, Expires, Secure, HttpOnly, SameSite) ## Core Classes | Class Name | Description | | ----------------------- | ---------------------------- | | `cHttpServerCookies` | Cookie collection management | | `cHttpServerCookieAttr` | Individual cookie attributes | ## Cookie Attributes Explained ### cHttpServerCookieAttr | Property | Type | Description | | ---------- | ------- | ------------------------- | | `Value` | String | Cookie value | | `Domain` | String | Domain scope | | `Path` | String | Path scope (default "/") | | `Expires` | Variant | Expiration time | | `Secure` | Boolean | HTTPS only transmission | | `HttpOnly` | Boolean | Disable JavaScript access | | `SameSite` | String | SameSite policy | ## Quick Start ### Reading Request Cookies ```vb Public Sub ShowCookie(ctx As cHttpServerContext) ' Check if cookie exists If ctx.Cookies.Exists("username") Then Dim username As String username = ctx.Cookies.Cookie("username").Value ctx.Response.Text "Username: " & username Else ctx.Response.Text "Cookie not found" End If End Sub ``` ### Setting Response Cookies ```vb Public Sub SetCookie(ctx As cHttpServerContext) ' Set simple cookie ctx.Cookies.Cookie("username").Value = "John" ' Set cookie with expiration With ctx.Cookies.Cookie("token") .Value = "abc123" .Expires = DateAdd("d", 7, Now) ' Expires in 7 days .Path = "/" End With ' Set secure cookie With ctx.Cookies.Cookie("session") .Value = GenerateToken() .HttpOnly = True ' Disable JS access .Secure = True ' HTTPS only .SameSite = "Strict" ' Prevent CSRF .Expires = DateAdd("h", 2, Now) ' Expires in 2 hours End With ctx.Response.Json Nothing, 0, "Cookie set" End Sub ``` ### Deleting Cookies ```vb Public Sub DeleteCookie(ctx As cHttpServerContext) ' Set expiration to past to delete ctx.Cookies.Cookie("username").Expires = DateAdd("d", -1, Now) ctx.Response.Json Nothing, 0, "Cookie deleted" End Sub ``` ## Complete Examples ### Remember Login Feature ```vb ' cAuthController.cls ' POST /login Public Sub Login(ctx As cHttpServerContext) Dim username As String, password As String Dim remember As Boolean username = ctx.Request.Form("username") password = ctx.Request.Form("password") remember = (ctx.Request.Form("remember") = "true") ' Validate credentials If Not ValidateUser(username, password) Then ctx.Response.Json Nothing, 1, "Invalid username or password" Exit Sub End If ' Generate token Dim token As String token = GenerateToken(username) ' Set session ctx.Session("user_id") = GetUserId(username) ' Set cookie With ctx.Cookies.Cookie("auth_token") .Value = token .Path = "/" .HttpOnly = True .SameSite = "Lax" If remember Then ' Remember login: 7 days .Expires = DateAdd("d", 7, Now) Else ' Don't remember: expires when browser closes .Expires = Empty End If End With ctx.Response.Json Nothing, 0, "Login successful" End Sub ' GET /auto-login Public Sub AutoLogin(ctx As cHttpServerContext) ' Check cookie token If Not ctx.Cookies.Exists("auth_token") Then ctx.Response.State401 "Not logged in" Exit Sub End If Dim token As String token = ctx.Cookies.Cookie("auth_token").Value ' Validate token If Not ValidateToken(token) Then ctx.Response.State401 "Session expired" Exit Sub End If ' Auto login successful Dim username As String username = GetUsernameFromToken(token) ctx.Session("user_id") = GetUserId(username) ctx.Response.Json Nothing, 0, "Auto login successful" End Sub ' GET /logout Public Sub Logout(ctx As cHttpServerContext) ' Clear session ctx.Session.Abandon ' Delete cookie ctx.Cookies.Cookie("auth_token").Expires = DateAdd("d", -1, Now) ctx.Response.Json Nothing, 0, "Logout successful" End Sub ``` ### Multi-language Support ```vb Public Sub SetLanguage(ctx As cHttpServerContext) Dim lang As String lang = ctx.Request.QueryString("lang") ' Set language cookie, expires in 1 year With ctx.Cookies.Cookie("language") .Value = lang .Path = "/" .Expires = DateAdd("yyyy", 1, Now) End With ctx.Response.Json Nothing, 0, "Language set: " & lang End Sub Public Sub GetLanguage(ctx As cHttpServerContext) Dim lang As String ' Get from cookie first If ctx.Cookies.Exists("language") Then lang = ctx.Cookies.Cookie("language").Value Else ' Default language lang = "en-US" End If Dim result As New Dictionary result("language") = lang ctx.Response.Json result End Sub ``` ## SameSite Attribute Explained | Value | Description | Use Case | | -------- | ----------------------------------------------- | ------------------------------------- | | `Strict` | Only same-site requests send cookie | High security (banking, payment) | | `Lax` | Sent on top-level navigation, not iframe/images | Balance security and UX (recommended) | | `None` | Sent on all requests (requires Secure) | Cross-site needs (OAuth) | ```vb ' Strict - Most strict ctx.Cookies.Cookie("high_security").SameSite = "Strict" ' Lax - Recommended ctx.Cookies.Cookie("session").SameSite = "Lax" ' None - Cross-site required ctx.Cookies.Cookie("oauth_state").SameSite = "None" ctx.Cookies.Cookie("oauth_state").Secure = True ' None requires Secure ``` ## Cookie Security Recommendations ```vb ' Security configuration example With ctx.Cookies.Cookie("session_id") ' Store encrypted value .Value = Encrypt(sessionValue) ' Path restriction .Path = "/api" ' Only sent under /api path ' Domain restriction .Domain = ".example.com" ' Subdomain sharing ' HTTPS transmission .Secure = True ' Disable JS access .HttpOnly = True ' Prevent CSRF .SameSite = "Strict" ' Reasonable expiration time .Expires = DateAdd("h", 2, Now) ' 2 hours End With ``` *** **Last Updated**: 2026-05-17 --- --- url: /en/packages/vbccr/bars/coolbar.md description: >- CoolBar Control - VBCCR Developer Reference, complete API documentation based on source code --- # CoolBar Control Wraps the ReBar system control, providing a draggable, resizable band container bar. ## Enumerations ### CbrOrientationConstants | Constant | Value | Description | |----------|-------|-------------| | CbrOrientationHorizontal | 0 | Horizontal orientation | | CbrOrientationVertical | 1 | Vertical orientation | ### CbrBandStyleConstants | Constant | Value | Description | |----------|-------|-------------| | CbrBandStyleNormal | 0 | Normal style, resizable | | CbrBandStyleFixedSize | 1 | Fixed size | ### CbrBandGripperConstants | Constant | Value | Description | |----------|-------|-------------| | CbrBandGripperNormal | 0 | Default gripper | | CbrBandGripperAlways | 1 | Always show gripper | | CbrBandGripperNever | 2 | Never show gripper | ### CbrHitResultConstants | Constant | Value | Description | |----------|-------|-------------| | CbrHitResultNoWhere | 0 | Empty area | | CbrHitResultCaption | 1 | Caption area | | CbrHitResultClient | 2 | Client area | | CbrHitResultGrabber | 3 | Gripper bar | | CbrHitResultChevron | 4 | Chevron arrow | | CbrHitResultSplitter | 5 | Splitter bar | ## Properties ### VisualStyles ```vb Property Get VisualStyles() As Boolean Property Let VisualStyles(ByVal Value As Boolean) ``` Whether visual styles are enabled. ### Enabled ```vb Property Get Enabled() As Boolean Property Let Enabled(ByVal Value As Boolean) ``` Whether the control is enabled. ### OLEDropMode ```vb Property Get OLEDropMode() As OLEDropModeConstants Property Let OLEDropMode(ByVal Value As OLEDropModeConstants) ``` OLE drag-and-drop mode. See common enumerations. ### MousePointer ```vb Property Get MousePointer() As CCMousePointerConstants Property Let MousePointer(ByVal Value As CCMousePointerConstants) ``` Mouse pointer. See common enumerations. ### MouseIcon ```vb Property Get MouseIcon() As IPictureDisp Property Let MouseIcon(ByVal Value As IPictureDisp) Property Set MouseIcon(ByVal Value As IPictureDisp) ``` Custom mouse icon. ### MouseTrack ```vb Property Get MouseTrack() As Boolean Property Let MouseTrack(ByVal Value As Boolean) ``` Mouse enter/leave tracking. ### RightToLeft ```vb Property Get RightToLeft() As Boolean Property Let RightToLeft(ByVal Value As Boolean) ``` Right-to-left display. ### RightToLeftLayout ```vb Property Get RightToLeftLayout() As Boolean Property Let RightToLeftLayout(ByVal Value As Boolean) ``` Right-to-left mirrored layout. ### RightToLeftMode ```vb Property Get RightToLeftMode() As CCRightToLeftModeConstants Property Let RightToLeftMode(ByVal Value As CCRightToLeftModeConstants) ``` Right-to-left mode. See common enumerations. ### ImageList ```vb Property Get ImageList() As Variant Property Let ImageList(ByVal Value As Variant) Property Set ImageList(ByVal Value As Variant) ``` Associated ImageList control. ### BackColor ```vb Property Get BackColor() As OLE_COLOR Property Let BackColor(ByVal Value As OLE_COLOR) ``` Background color. ### ForeColor ```vb Property Get ForeColor() As OLE_COLOR Property Let ForeColor(ByVal Value As OLE_COLOR) ``` Foreground color. ### BorderStyle ```vb Property Get BorderStyle() As Integer Property Let BorderStyle(ByVal Value As Integer) ``` Border style (0 - no border, 1 - fixed single). ### Orientation ```vb Property Get Orientation() As CbrOrientationConstants Property Let Orientation(ByVal Value As CbrOrientationConstants) ``` Orientation. ### BandBorders ```vb Property Get BandBorders() As Boolean Property Let BandBorders(ByVal Value As Boolean) ``` Whether separator lines are displayed between bands. ### FixedOrder ```vb Property Get FixedOrder() As Boolean Property Let FixedOrder(ByVal Value As Boolean) ``` Whether the user is prevented from reordering bands. ### VariantHeight ```vb Property Get VariantHeight() As Boolean Property Let VariantHeight(ByVal Value As Boolean) ``` Whether bands are allowed to have different heights. ### Picture ```vb Property Get Picture() As IPictureDisp Property Let Picture(ByVal Value As IPictureDisp) Property Set Picture(ByVal Value As IPictureDisp) ``` Background picture. ### DblClickToggle ```vb Property Get DblClickToggle() As Boolean Property Let DblClickToggle(ByVal Value As Boolean) ``` Whether double-click toggles maximize/minimize. ### VerticalGripper ```vb Property Get VerticalGripper() As Boolean Property Let VerticalGripper(ByVal Value As Boolean) ``` Whether a vertical gripper is used in vertical orientation. ### ShowTips ```vb Property Get ShowTips() As Boolean Property Let ShowTips(ByVal Value As Boolean) ``` Whether tooltips are displayed. ### DoubleBuffer ```vb Property Get DoubleBuffer() As Boolean Property Let DoubleBuffer(ByVal Value As Boolean) ``` Whether double buffering is enabled to reduce flicker. ### Bands ```vb Property Get Bands() As CbrBands ``` Bands collection. ### ContainedControls ```vb Property Get ContainedControls() As VBRUN.ContainedControls ``` Contained controls collection. Read-only. ### RowCount ```vb Property Get RowCount() As Long ``` Row count. Read-only. ### hWnd / hWndUserControl / Font See common properties. ### Name / Tag / Parent / Container / Left / Top / Width / Height / Visible / ToolTipText / WhatsThisHelpID / Align / DragIcon / DragMode See standard extender properties. ## Methods ### Refresh ```vb Public Sub Refresh() ``` Forces a redraw. ### HitTest ```vb Public Function HitTest(ByVal X As Single, ByVal Y As Single, Optional ByRef HitResult As CbrHitResultConstants) As CbrBand ``` Hit test; returns the band object at the specified coordinates. ### OLEDrag ```vb Public Sub OLEDrag() ``` ### Drag / ZOrder See standard methods. ## Events ### Click ```vb Public Event Click() ``` Click. ### DblClick ```vb Public Event DblClick() ``` Double-click. ### Resize ```vb Public Event Resize() ``` Size changed. ### HeightChanged ```vb Public Event HeightChanged(ByVal NewHeight As Single) ``` Height changed. ### LayoutChanged ```vb Public Event LayoutChanged() ``` Layout changed. ### MinMax ```vb Public Event MinMax(ByRef Cancel As Boolean) ``` A band is about to be maximized or minimized; can be canceled. ### BandBeforeDrag ```vb Public Event BandBeforeDrag(ByVal Band As CbrBand, ByRef Cancel As Boolean) ``` A band is about to be dragged; can be canceled. ### BandAfterDrag ```vb Public Event BandAfterDrag(ByVal Band As CbrBand, ByVal NewPosition As Long) ``` Band drag completed. ### BandChevronPushed ```vb Public Event BandChevronPushed(ByVal Band As CbrBand, ByVal Left As Single, ByVal Top As Single, ByVal Width As Single, ByVal Height As Single) ``` Chevron arrow clicked. ### BandMouseEnter ```vb Public Event BandMouseEnter(ByVal Band As CbrBand) ``` Mouse entered a band. ### BandMouseLeave ```vb Public Event BandMouseLeave(ByVal Band As CbrBand) ``` Mouse left a band. ### MouseDown / MouseMove / MouseUp / MouseEnter / MouseLeave ### OLECompleteDrag / OLEDragDrop / OLEDragOver / OLEGiveFeedback / OLESetData / OLEStartDrag ## CbrBand Object Band properties and methods. ### Properties #### Index ```vb Property Get Index() As Long ``` Band index in the collection. Read-only. #### Key ```vb Property Get Key() As String Property Let Key(ByVal Value As String) ``` Band key. #### Tag ```vb Property Get Tag() As Variant Property Let Tag(ByVal Value As Variant) Property Set Tag(ByVal Value As Variant) ``` Custom data. #### ID ```vb Property Get ID() As Long ``` Internal identifier. Read-only. #### Caption ```vb Property Get Caption() As String Property Let Caption(ByVal Value As String) ``` Band caption. #### Child ```vb Property Get Child() As Object Property Let Child(ByVal Value As Object) Property Set Child(ByVal Value As Object) ``` Child control contained in the band. #### Style ```vb Property Get Style() As CbrBandStyleConstants Property Let Style(ByVal Value As CbrBandStyleConstants) ``` Band style. #### Image ```vb Property Get Image() As Variant Property Let Image(ByVal Value As Variant) ``` Image index or key in the ImageList. #### ImageIndex ```vb Property Get ImageIndex() As Long ``` Image index. Read-only. #### Width ```vb Property Get Width() As Single Property Let Width(ByVal Value As Single) ``` Band width. Read-only when Style is FixedSize. #### Height ```vb Property Get Height() As Single ``` Band height. Read-only. #### MinWidth ```vb Property Get MinWidth() As Single Property Let MinWidth(ByVal Value As Single) ``` Minimum width. #### MinHeight ```vb Property Get MinHeight() As Single Property Let MinHeight(ByVal Value As Single) ``` Minimum height. #### IdealWidth ```vb Property Get IdealWidth() As Single Property Let IdealWidth(ByVal Value As Single) ``` Ideal width. #### Gripper ```vb Property Get Gripper() As CbrBandGripperConstants Property Let Gripper(ByVal Value As CbrBandGripperConstants) ``` Gripper style. #### ToolTipText ```vb Property Get ToolTipText() As String Property Let ToolTipText(ByVal Value As String) ``` ToolTip text. Requires ShowTips to be True. #### UseCoolBarPicture ```vb Property Get UseCoolBarPicture() As Boolean Property Let UseCoolBarPicture(ByVal Value As Boolean) ``` Whether the CoolBar's background picture is used. #### Picture ```vb Property Get Picture() As IPictureDisp Property Let Picture(ByVal Value As IPictureDisp) Property Set Picture(ByVal Value As IPictureDisp) ``` Band background picture. #### UseCoolBarColors ```vb Property Get UseCoolBarColors() As Boolean Property Let UseCoolBarColors(ByVal Value As Boolean) ``` Whether the CoolBar's foreground/background colors are used. #### BackColor ```vb Property Get BackColor() As OLE_COLOR Property Let BackColor(ByVal Value As OLE_COLOR) ``` Band background color. #### ForeColor ```vb Property Get ForeColor() As OLE_COLOR Property Let ForeColor(ByVal Value As OLE_COLOR) ``` Band foreground color. #### NewRow ```vb Property Get NewRow() As Boolean Property Let NewRow(ByVal Value As Boolean) ``` Whether the band starts on a new row. #### Visible ```vb Property Get Visible() As Boolean Property Let Visible(ByVal Value As Boolean) ``` Whether visible. #### ChildEdge ```vb Property Get ChildEdge() As Boolean Property Let ChildEdge(ByVal Value As Boolean) ``` Whether an edge is displayed around the child control. #### UseChevron ```vb Property Get UseChevron() As Boolean Property Let UseChevron(ByVal Value As Boolean) ``` Whether a chevron arrow is displayed when the band width is less than the ideal width. #### HideCaption ```vb Property Get HideCaption() As Boolean Property Let HideCaption(ByVal Value As Boolean) ``` Whether the caption is hidden. #### FixedBackground ```vb Property Get FixedBackground() As Boolean Property Let FixedBackground(ByVal Value As Boolean) ``` Whether the background picture is fixed in place. #### Position ```vb Property Get Position() As Long Property Let Position(ByVal Value As Long) ``` Band position. ### Methods #### Maximize ```vb Public Sub Maximize() ``` Maximizes the band. #### Minimize ```vb Public Sub Minimize() ``` Minimizes the band. #### PushChevron ```vb Public Sub PushChevron() ``` Programmatically clicks the chevron arrow. ## CbrBands Collection Bands collection object. ### Properties #### Item ```vb Property Get Item(ByVal Index As Variant) As CbrBand ``` Gets a band by index or key. #### ItemFromPosition ```vb Property Get ItemFromPosition(ByVal Position As Long) As CbrBand ``` Gets a band by position. #### Count ```vb Property Get Count() As Long ``` Band count. ### Methods #### Add ```vb Public Function Add(Optional ByVal Index As Long, Optional ByVal Key As String, Optional ByVal Caption As String, Optional ByVal Image As Variant, Optional ByVal NewRow As Boolean, Optional ByVal Child As Variant, Optional ByVal Visible As Boolean = True) As CbrBand ``` Adds a new band. #### Remove ```vb Public Sub Remove(ByVal Index As Variant) ``` Removes a band. #### Clear ```vb Public Sub Clear() ``` Clears all bands. #### Exists ```vb Public Function Exists(ByVal Index As Variant) As Boolean ``` Checks if a band exists. ## CbrBandProperties Object Auxiliary object for band color properties. ### Properties #### BackColor ```vb Property Get BackColor() As OLE_COLOR Property Let BackColor(ByVal Value As OLE_COLOR) ``` Background color. #### ForeColor ```vb Property Get ForeColor() As OLE_COLOR Property Let ForeColor(ByVal Value As OLE_COLOR) ``` Foreground color. ## Code Examples ### Basic Usage ```vb ' Add bands With CoolBar1.Bands .Add Key:="Band1", Caption:="Toolbar", NewRow:=True .Add Key:="Band2", Caption:="Format Bar" End With ' Set child control Set CoolBar1.Bands("Band1").Child = Toolbar1 ' Set band properties CoolBar1.Bands(1).UseChevron = True CoolBar1.Bands(1).IdealWidth = 500 ``` ### Hit Test ```vb Private Sub CoolBar1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) Dim HitResult As CbrHitResultConstants Dim Band As CbrBand Set Band = CoolBar1.HitTest(X, Y, HitResult) If Not Band Is Nothing Then Debug.Print "Clicked: " & Band.Caption End If End Sub ``` ### Chevron Event ```vb Private Sub CoolBar1_BandChevronPushed(ByVal Band As CbrBand, _ ByVal Left As Single, ByVal Top As Single, _ ByVal Width As Single, ByVal Height As Single) ' Display menu at chevron position PopupMenu mnuToolbar, , Left, Top + Height End Sub ``` --- --- url: /zh/vbman/pli/methods.md --- # cPLI 方法参考 ## 🚀 核心方法 ### Request 调用外部程序并返回结果。 ```vb Public Function Request(ParamArray Data() As Variant) As String ``` **参数**: * `Data()` - 可变参数数组，所有参数将使用 Base64 + UTF-8 编码后传递给外部程序 **返回**: 外部程序的标准输出内容 **异常**: * 404 - 找不到 `VBMAN.PLI` 文件 * 超时错误 - 执行时间超过 `TimeOut` 设置 **示例**: ```vb Dim PLI As New cPLI Dim result As String ' 无参数调用 result = PLI.Request() ' 单参数调用 result = PLI.Request("hello") ' 多参数调用 result = PLI.Request("param1", "param2", "param3") ' 传递复杂数据 result = PLI.Request("user", "123", "{\"action\":\"login\")} ``` *** ## ⚙️ 配置属性 ### TimeOut 命令执行超时时间（毫秒）。 ```vb Public TimeOut As Long ``` **默认值**: `30000` (30 秒) **示例**: ```vb Dim PLI As New cPLI ' 设置 10 秒超时 PLI.TimeOut = 10 * 1000 ' 设置 5 分钟超时（长时间任务） PLI.TimeOut = 5 * 60 * 1000 ' 设置 1 秒超时（快速检查） PLI.TimeOut = 1000 Dim result As String result = PLI.Request("long-task") ``` *** ## 📋 完整使用示例 ### 调用 Python 脚本 假设 `VBMAN.PLI` 是一个 Python 打包的可执行程序： ```python # Python 端代码示例 (VBMAN.PLI) import sys import base64 def main(): # 解码参数 args = sys.argv[1:] decoded_args = [base64.b64decode(arg).decode('utf-8') for arg in args] # 处理数据 action = decoded_args[0] data = decoded_args[1] if action == "process": result = process_data(data) print(result) elif action == "analyze": result = analyze_data(data) # 大结果写入文件 with open("VBMAN.DAT", "w") as f: f.write(result) print("VBMAN.DAT") # 返回文件名 def process_data(data): # 处理逻辑 return f"Processed: {data}" def analyze_data(data): # 分析逻辑 return f"Analysis result for: {data}" if __name__ == "__main__": main() ``` ```vb ' VB6 调用端 Private Sub CallPython() Dim PLI As New cPLI Dim result As String ' 简单调用 result = PLI.Request("process", "some data") Debug.Print result ' 输出: Processed: some data ' 长时间任务 PLI.TimeOut = 60 * 1000 ' 1分钟 result = PLI.Request("analyze", "large dataset") Debug.Print result ' 可能返回 "VBMAN.DAT" End Sub ``` ### JSON 数据交换 ```vb Private Sub ExchangeJSON() Dim PLI As New cPLI Dim jsonSend As New cJson Dim jsonRecv As New cJson ' 构造请求数据 jsonSend.AddItem "action", "calculate" jsonSend.AddItem "num1", 100 jsonSend.AddItem "num2", 200 ' 调用外部程序 Dim result As String result = PLI.Request(jsonSend.Encode()) ' 解析返回结果 jsonRecv.Decode result If jsonRecv.GetItem("success") = True Then Debug.Print "结果: " & jsonRecv.GetItem("result") Else Debug.Print "错误: " & jsonRecv.GetItem("error") End If End Sub ``` ### 错误处理 ```vb Private Sub SafeCall() Dim PLI As New cPLI On Error GoTo ErrorHandler Dim result As String result = PLI.Request("risky-operation") Debug.Print "成功: " & result Exit Sub ErrorHandler: Select Case Err.Number Case 404 MsgBox "找不到 PLI 程序，请检查安装" Case Else If Err.Description Like "*超时*" Then MsgBox "操作超时，请重试" Else MsgBox "错误: " & Err.Number & " - " & Err.Description End If End Select End Sub ``` ### 文件处理 ```vb Private Sub ProcessFile() Dim PLI As New cPLI ' 传递文件路径 Dim filePath As String filePath = "C:\data\input.csv" Dim result As String result = PLI.Request("convert", filePath, "json") ' 检查是否返回文件 If result = "VBMAN.DAT" Then ' 读取返回的数据文件 Dim output As String output = ToolsStream.LoadFileAsText(App.Path & "\VBMAN.DAT") ' 处理完成后删除临时文件 Kill App.Path & "\VBMAN.DAT" Debug.Print "处理结果: " & output Else Debug.Print "直接返回: " & result End If End Sub ``` *** ## 🔧 相关组件 * `cSTDIO` - 标准输入输出执行组件 * `ToolsBase64` - Base64 编码工具 * `ToolsStream` - 文件流操作工具 *** **最后更新**: 2026-05-17 --- --- url: /zh/vbman/pli/overview.md --- # cPLI 外部程序接口组件 ## 简介 `cPLI` (Programmable Language Interface) 是一个外部程序调用接口组件，用于在 VB6 应用程序中调用外部可执行程序（如 Python、Node.js 等脚本），并通过标准输入输出进行数据交换。 ## 工作原理 ``` ┌─────────────────┐ ┌─────────────────┐ ┌─────────────────┐ │ VB6 应用程序 │ ──▶ │ cPLI 组件 │ ──▶ │ 外部程序 (PLI) │ │ │ │ │ │ │ │ PLI.Request() │ │ Base64编码参数 │ │ VBMAN.PLI │ │ │ │ 执行命令 │ │ (Python/Exe) │ │ 获取返回结果 │ ◀── │ 返回结果 │ ◀── │ 处理数据 │ └─────────────────┘ └─────────────────┘ └─────────────────┘ ``` ## 文件说明 | 文件 | 说明 | |------|------| | `VBMAN.PLI` | 外部可执行程序（主程序）| | `VBMAN.PSC` | 脚本/配置文件 | | `VBMAN.DAT` | 数据交换文件（大返回值时使用）| ## 特性 * **参数传递**: 使用 Base64 + UTF-8 编码传递参数 * **超时控制**: 可设置命令执行超时时间 * **大返回值**: 支持通过文件返回大量数据 * **自动搜索**: 自动在多个路径查找 PLI 程序 ## 快速开始 ### 基础调用 ```vb Dim PLI As New cPLI Dim result As String ' 调用外部程序 result = PLI.Request("param1", "param2", "param3") Debug.Print "返回结果: " & result ``` ### 设置超时 ```vb Dim PLI As New cPLI ' 设置 60 秒超时（默认 30 秒） PLI.TimeOut = 60 * 1000 Dim result As String result = PLI.Request("data") ``` ### 处理 JSON 数据 ```vb Dim PLI As New cPLI ' 发送 JSON 数据 Dim json As String json = "{\"name\":\"张三\",\"age\":25}" Dim result As String result = PLI.Request(json) ' 解析返回的 JSON Dim response As New cJson response.Decode result Debug.Print response.GetItem("status") ``` ## 文件路径搜索顺序 组件会按以下顺序搜索 `VBMAN.PLI`： 1. `App.Path\VBMAN.PLI` 2. `App.Path\bin\VBMAN.PLI` 3. `App.Path\..\bin\VBMAN.PLI` 如果找不到，会抛出 404 错误。 ## 典型应用场景 | 场景 | 说明 | |------|------| | **Python 脚本** | 调用 Python 进行数据处理、AI 推理 | | **Node.js 程序** | 调用 JavaScript 工具 | | **命令行工具** | 调用系统命令行程序 | | **数据处理** | 复杂计算、格式转换等 | *** **最后更新**: 2026-05-17 --- --- url: /en/vbman/pli/overview.md --- # cPLI External Program Interface Component ## Introduction `cPLI` (Programmable Language Interface) is an external program call interface component used to call external executables (such as Python, Node.js scripts) from VB6 applications and exchange data through standard input/output. ## How It Works ``` ┌─────────────────┐ ┌─────────────────┐ ┌─────────────────┐ │ VB6 App │ ──▶ │ cPLI Component │ ──▶ │ External (PLI) │ │ │ │ │ │ │ │ PLI.Request() │ │ Base64 encode │ │ VBMAN.PLI │ │ │ │ Execute cmd │ │ (Python/Exe) │ │ Get result │ ◀── │ Return result │ ◀── │ Process data │ └─────────────────┘ └─────────────────┘ └─────────────────┘ ``` ## File Description | File | Description | |------|-------------| | `VBMAN.PLI` | External executable (main program) | | `VBMAN.PSC` | Script/config file | | `VBMAN.DAT` | Data exchange file (for large return values) | ## Features * **Parameter Passing**: Uses Base64 + UTF-8 encoding to pass parameters * **Timeout Control**: Can set command execution timeout * **Large Return Values**: Supports returning large data via file * **Auto Search**: Auto searches multiple paths for PLI program ## Quick Start ### Basic Call ```vb Dim PLI As New cPLI Dim result As String ' Call external program result = PLI.Request("param1", "param2", "param3") Debug.Print "Return result: " & result ``` ### Set Timeout ```vb Dim PLI As New cPLI ' Set 60 second timeout (default 30 seconds) PLI.TimeOut = 60 * 1000 Dim result As String result = PLI.Request("data") ``` ### Process JSON Data ```vb Dim PLI As New cPLI ' Send JSON data Dim json As String json = "{\"name\":\"John\",\"age\":25}" Dim result As String result = PLI.Request(json) ' Parse returned JSON Dim response As New cJson response.Decode result Debug.Print response.GetItem("status") ``` ## File Path Search Order Component searches for `VBMAN.PLI` in the following order: 1. `App.Path\VBMAN.PLI` 2. `App.Path\bin\VBMAN.PLI` 3. `App.Path\..\bin\VBMAN.PLI` If not found, throws 404 error. ## Typical Use Cases | Scenario | Description | |----------|-------------| | **Python Scripts** | Call Python for data processing, AI inference | | **Node.js Programs** | Call JavaScript tools | | **Command Line Tools** | Call system command line programs | | **Data Processing** | Complex calculations, format conversion, etc. | *** **Last Updated**: 2026-05-17 --- --- url: /en/vbman/pli/methods.md --- # cPLI Methods Reference ## 🚀 Core Methods ### Request Calls external program and returns result. ```vb Public Function Request(ParamArray Data() As Variant) As String ``` **Parameters:** * `Data()` - Variable parameter array, all parameters will be passed to external program after Base64 + UTF-8 encoding **Returns:** External program's standard output content **Exceptions:** * 404 - `VBMAN.PLI` file not found * Timeout error - Execution time exceeds `TimeOut` setting **Example:** ```vb Dim PLI As New cPLI Dim result As String ' No parameter call result = PLI.Request() ' Single parameter call result = PLI.Request("hello") ' Multiple parameter call result = PLI.Request("param1", "param2", "param3") ' Pass complex data result = PLI.Request("user", "123", "{\"action\":\"login\"}") ``` *** ## ⚙️ Configuration Properties ### TimeOut Command execution timeout (milliseconds). ```vb Public TimeOut As Long ``` **Default:** `30000` (30 seconds) **Example:** ```vb Dim PLI As New cPLI ' Set 10 second timeout PLI.TimeOut = 10 * 1000 ' Set 5 minute timeout (long task) PLI.TimeOut = 5 * 60 * 1000 ' Set 1 second timeout (quick check) PLI.TimeOut = 1000 Dim result As String result = PLI.Request("long-task") ``` *** ## 📋 Complete Usage Examples ### Call Python Script Assuming `VBMAN.PLI` is a Python packaged executable: ```python # Python side code example (VBMAN.PLI) import sys import base64 def main(): # Decode parameters args = sys.argv[1:] decoded_args = [base64.b64decode(arg).decode('utf-8') for arg in args] # Process data action = decoded_args[0] data = decoded_args[1] if action == "process": result = process_data(data) print(result) elif action == "analyze": result = analyze_data(data) # Write large result to file with open("VBMAN.DAT", "w") as f: f.write(result) print("VBMAN.DAT") # Return filename def process_data(data): # Processing logic return f"Processed: {data}" def analyze_data(data): # Analysis logic return f"Analysis result for: {data}" if __name__ == "__main__": main() ``` ```vb ' VB6 call side Private Sub CallPython() Dim PLI As New cPLI Dim result As String ' Simple call result = PLI.Request("process", "some data") Debug.Print result ' Output: Processed: some data ' Long task PLI.TimeOut = 60 * 1000 ' 1 minute result = PLI.Request("analyze", "large dataset") Debug.Print result ' May return "VBMAN.DAT" End Sub ``` ### JSON Data Exchange ```vb Private Sub ExchangeJSON() Dim PLI As New cPLI Dim jsonSend As New cJson Dim jsonRecv As New cJson ' Build request data jsonSend.AddItem "action", "calculate" jsonSend.AddItem "num1", 100 jsonSend.AddItem "num2", 200 ' Call external program Dim result As String result = PLI.Request(jsonSend.Encode()) ' Parse return result jsonRecv.Decode result If jsonRecv.GetItem("success") = True Then Debug.Print "Result: " & jsonRecv.GetItem("result") Else Debug.Print "Error: " & jsonRecv.GetItem("error") End If End Sub ``` ### Error Handling ```vb Private Sub SafeCall() Dim PLI As New cPLI On Error GoTo ErrorHandler Dim result As String result = PLI.Request("risky-operation") Debug.Print "Success: " & result Exit Sub ErrorHandler: Select Case Err.Number Case 404 MsgBox "PLI program not found, please check installation" Case Else If Err.Description Like "*timeout*" Then MsgBox "Operation timeout, please retry" Else MsgBox "Error: " & Err.Number & " - " & Err.Description End If End Select End Sub ``` ### File Processing ```vb Private Sub ProcessFile() Dim PLI As New cPLI ' Pass file path Dim filePath As String filePath = "C:\data\input.csv" Dim result As String result = PLI.Request("convert", filePath, "json") ' Check if returned file If result = "VBMAN.DAT" Then ' Read returned data file Dim output As String output = ToolsStream.LoadFileAsText(App.Path & "\VBMAN.DAT") ' Delete temp file after processing Kill App.Path & "\VBMAN.DAT" Debug.Print "Processing result: " & output Else Debug.Print "Direct return: " & result End If End Sub ``` *** ## 🔧 Related Components * `cSTDIO` - Standard input/output execution component * `ToolsBase64` - Base64 encoding utility * `ToolsStream` - File stream operation utility *** **Last Updated**: 2026-05-17 --- --- url: /zh/vbman/qrcode/overview.md --- # cQRcode 二维码组件概述 ## 简介 `cQRcode` 是一个二维码生成组件，基于 Nayuki 的 QR Code Generator Library (MIT License) 实现。支持生成标准 QR 码图片，可自定义内容、大小、颜色。 ## 特性 | 特性 | 说明 | |------|------| | **纯 VB 实现** | 无需外部依赖 | | **链式调用** | 流畅的 API 设计 | | **纠错等级** | 支持 L/M/Q/H 四级纠错 | | **自动编码** | 支持数字、字母、字节多种模式 | | **剪贴板输出** | 支持直接复制到剪贴板 | | **图片返回** | 返回 StdPicture 对象，可直接显示 | ## 纠错等级 | 等级 | 常量 | 容错率 | 适用场景 | |------|------|--------|----------| | L | `QRCodegenEcc_LOW` | 约 7% | 干净环境 | | M | `QRCodegenEcc_MEDIUM` | 约 15% | 一般场景 | | Q | `QRCodegenEcc_QUARTILE` | 约 25% | 有一定污损 | | H | `QRCodegenEcc_HIGH` | 约 30% | 严重污损 | ## 快速开始 ### 基础用法 ```vb Dim QR As New cQRcode ' 简单生成 Set Image1.Picture = QR.Generate() ``` ### 链式设置 ```vb Dim QR As New cQRcode ' 链式调用设置属性并生成 Set Image1.Picture = QR _ .SetText("https://www.vb6.pro") _ .SetSize(200) _ .SetForeColor(vbBlue) _ .Generate() ``` ### 复制到剪贴板 ```vb Dim QR As New cQRcode ' 生成并复制到剪贴板 QR.SetText("Hello World").Generate True ' 现在可以粘贴到其他应用程序 ``` ### 保存为图片文件 ```vb Dim QR As New cQRcode ' 生成并保存 Set QR.Picture = QR.SetText("Save me!").Generate() SavePicture QR.Picture, App.Path & "\qrcode.bmp" ``` ## 文件结构 | 文件 | 说明 | |------|------| | `cQRcode.cls` | 二维码类，提供简单接口 | | `mQRcodeGen.bas` | 核心生成算法模块 | ## 底层函数（高级用法） 如需更精细控制，可直接使用模块函数： ```vb ' 直接使用底层函数 Set Picture1.Picture = QRCodegenBarcode( _ TextOrByteArray:="Hello", _ clrFore:=vbBlack, _ Ecl:=QRCodegenEcc_MEDIUM, _ MinVersion:=1, _ MaxVersion:=5, _ Mask:=QRCodegenMask_AUTO, _ BoostEcl:=True, _ PicSize:=300 _ ) ``` *** **最后更新**: 2026-05-17 --- --- url: /zh/vbman/qrcode/methods.md --- # cQRcode 方法参考 ## 🔗 链式设置方法 ### SetText 设置二维码内容。 ```vb Public Function SetText(ByVal Content As Variant) As cQRcode ``` **参数**: * `Content` - 二维码文本内容（String 或 Byte Array） **返回**: 返回自身实例，支持链式调用 **示例**: ```vb ' 设置文本 QR.SetText("Hello World") ' 设置 URL QR.SetText("https://www.vb6.pro") ' 设置 WiFi 配置 QR.SetText("WIFI:T:WPA;S:MyWiFi;P:password;;") ' 链式调用 QR.SetText("内容").SetSize(200).Generate ``` *** ### SetSize 设置二维码图片大小（像素）。 ```vb Public Function SetSize(ByVal Size As Long) As cQRcode ``` **参数**: * `Size` - 图片尺寸（像素） **默认值**: 50 **示例**: ```vb ' 设置小尺寸 QR.SetSize(100) ' 设置大尺寸（高清） QR.SetSize(500) ' 根据容器自适应 QR.SetSize(Picture1.Width) ``` *** ### SetForeColor 设置二维码前景色。 ```vb Public Function SetForeColor(ByVal ForeColor As OLE_COLOR) As cQRcode ``` **参数**: * `ForeColor` - 颜色值（VB 颜色常量或 RGB 值） **默认值**: `vbBlack` **示例**: ```vb ' 使用 VB 常量 QR.SetForeColor(vbRed) QR.SetForeColor(vbBlue) ' 使用 RGB QR.SetForeColor(RGB(255, 0, 0)) ' 红色 QR.SetForeColor(RGB(0, 128, 0)) ' 绿色 QR.SetForeColor(&HFF6600) ' 橙色 ' 链式调用 QR.SetText("Color").SetForeColor(vbBlue).Generate ``` *** ## 🎯 生成方法 ### Generate 生成二维码图片。 ```vb Public Function Generate(Optional ByVal IsCopyToClipboard As Boolean) As StdPicture ``` **参数**: * `IsCopyToClipboard` - 是否同时复制到剪贴板（默认 False） **返回**: `StdPicture` 对象 **示例**: ```vb Dim QR As New cQRcode ' 基础生成 Set Image1.Picture = QR.Generate() ' 生成并复制到剪贴板 QR.Generate True ' 完整流程 Set Image1.Picture = QR _ .SetText("https://vb6.pro") _ .SetSize(300) _ .SetForeColor(vbBlack) _ .Generate() ``` *** ## 📋 常见使用场景 ### 生成 URL 二维码 ```vb Private Sub GenerateURLQR() Dim QR As New cQRcode Set Image1.Picture = QR _ .SetText("https://www.microsoft.com") _ .SetSize(200) _ .Generate() End Sub ``` ### 生成 WiFi 二维码 ```vb Private Sub GenerateWiFiQR() Dim QR As New cQRcode Dim wifiConfig As String ' WiFi 配置格式 wifiConfig = "WIFI:T:WPA;S:" & txtSSID.Text & ";P:" & txtPassword.Text & ";;" Set Image1.Picture = QR _ .SetText(wifiConfig) _ .SetSize(250) _ .Generate() End Sub ``` ### 生成联系人二维码 (vCard) ```vb Private Sub GenerateVCardQR() Dim QR As New cQRcode Dim vCard As String vCard = "BEGIN:VCARD" & vbCrLf & _ "VERSION:3.0" & vbCrLf & _ "N:张三" & vbCrLf & _ "TEL:13800138000" & vbCrLf & _ "EMAIL:zhangsan@example.com" & vbCrLf & _ "END:VCARD" Set Image1.Picture = QR _ .SetText(vCard) _ .SetSize(300) _ .Generate() End Sub ``` ### 批量生成二维码 ```vb Private Sub BatchGenerate() Dim QR As New cQRcode Dim items As Variant Dim i As Long items = Array("Item1", "Item2", "Item3", "Item4", "Item5") For i = LBound(items) To UBound(items) ' 生成二维码 Set Image1.Picture = QR _ .SetText(items(i)) _ .SetSize(150) _ .Generate() ' 保存文件 SavePicture Image1.Picture, App.Path & "\QR_" & items(i) & ".bmp" Next i End Sub ``` ### 打印二维码 ```vb Private Sub PrintQR() Dim QR As New cQRcode ' 生成高质量二维码 Set Image1.Picture = QR _ .SetText("Print Test") _ .SetSize(500) _ .Generate() ' 打印 Printer.PaintPicture Image1.Picture, 500, 500 Printer.EndDoc End Sub ``` *** **最后更新**: 2026-05-17 --- --- url: /en/vbman/qrcode/methods.md --- # cQRcode Methods Reference ## 🔗 Chainable Setting Methods ### SetText Sets QR code content. ```vb Public Function SetText(ByVal Content As Variant) As cQRcode ``` **Parameters:** * `Content` - QR code text content (String or Byte Array) **Returns:** Returns self instance for chainable calls **Example:** ```vb ' Set text QR.SetText("Hello World") ' Set URL QR.SetText("https://www.vb6.pro") ' Set WiFi config QR.SetText("WIFI:T:WPA;S:MyWiFi;P:password;;") ' Chainable call QR.SetText("Content").SetSize(200).Generate ``` *** ### SetSize Sets QR code image size (pixels). ```vb Public Function SetSize(ByVal Size As Long) As cQRcode ``` **Parameters:** * `Size` - Image size (pixels) **Default:** 50 **Example:** ```vb ' Set small size QR.SetSize(100) ' Set large size (HD) QR.SetSize(500) ' Adaptive to container QR.SetSize(Picture1.Width) ``` *** ### SetForeColor Sets QR code foreground color. ```vb Public Function SetForeColor(ByVal ForeColor As OLE_COLOR) As cQRcode ``` **Parameters:** * `ForeColor` - Color value (VB color constant or RGB value) **Default:** `vbBlack` **Example:** ```vb ' Use VB constants QR.SetForeColor(vbRed) QR.SetForeColor(vbBlue) ' Use RGB QR.SetForeColor(RGB(255, 0, 0)) ' Red QR.SetForeColor(RGB(0, 128, 0)) ' Green QR.SetForeColor(&HFF6600) ' Orange ' Chainable call QR.SetText("Color").SetForeColor(vbBlue).Generate ``` *** ## 🎯 Generation Methods ### Generate Generates QR code image. ```vb Public Function Generate(Optional ByVal IsCopyToClipboard As Boolean) As StdPicture ``` **Parameters:** * `IsCopyToClipboard` - Whether to copy to clipboard at same time (default False) **Returns:** `StdPicture` object **Example:** ```vb Dim QR As New cQRcode ' Basic generation Set Image1.Picture = QR.Generate() ' Generate and copy to clipboard QR.Generate True ' Complete flow Set Image1.Picture = QR _ .SetText("https://vb6.pro") _ .SetSize(300) _ .SetForeColor(vbBlack) _ .Generate() ``` *** ## 📋 Common Use Scenarios ### Generate URL QR Code ```vb Private Sub GenerateURLQR() Dim QR As New cQRcode Set Image1.Picture = QR _ .SetText("https://www.microsoft.com") _ .SetSize(200) _ .Generate() End Sub ``` ### Generate WiFi QR Code ```vb Private Sub GenerateWiFiQR() Dim QR As New cQRcode Dim wifiConfig As String ' WiFi config format wifiConfig = "WIFI:T:WPA;S:" & txtSSID.Text & ";P:" & txtPassword.Text & ";;" Set Image1.Picture = QR _ .SetText(wifiConfig) _ .SetSize(250) _ .Generate() End Sub ``` ### Generate Contact QR Code (vCard) ```vb Private Sub GenerateVCardQR() Dim QR As New cQRcode Dim vCard As String vCard = "BEGIN:VCARD" & vbCrLf & _ "VERSION:3.0" & vbCrLf & _ "N:John" & vbCrLf & _ "TEL:13800138000" & vbCrLf & _ "EMAIL:john@example.com" & vbCrLf & _ "END:VCARD" Set Image1.Picture = QR _ .SetText(vCard) _ .SetSize(300) _ .Generate() End Sub ``` ### Batch Generate QR Codes ```vb Private Sub BatchGenerate() Dim QR As New cQRcode Dim items As Variant Dim i As Long items = Array("Item1", "Item2", "Item3", "Item4", "Item5") For i = LBound(items) To UBound(items) ' Generate QR code Set Image1.Picture = QR _ .SetText(items(i)) _ .SetSize(150) _ .Generate() ' Save file SavePicture Image1.Picture, App.Path & "\QR_" & items(i) & ".bmp" Next i End Sub ``` ### Print QR Code ```vb Private Sub PrintQR() Dim QR As New cQRcode ' Generate high-quality QR code Set Image1.Picture = QR _ .SetText("Print Test") _ .SetSize(500) _ .Generate() ' Print Printer.PaintPicture Image1.Picture, 500, 500 Printer.EndDoc End Sub ``` *** **Last Updated**: 2026-05-17 --- --- url: /en/vbman/qrcode/overview.md --- # cQRcode QR Code Component Overview ## Introduction `cQRcode` is a QR code generation component based on Nayuki's QR Code Generator Library (MIT License). Supports generating standard QR code images with customizable content, size, and colors. ## Features | Feature | Description | |---------|-------------| | **Pure VB Implementation** | No external dependencies | | **Chainable API** | Fluent API design | | **Error Correction Levels** | Supports L/M/Q/H four-level error correction | | **Auto Encoding** | Supports numeric, alphanumeric, byte multiple modes | | **Clipboard Output** | Supports direct copy to clipboard | | **Image Return** | Returns StdPicture object, can display directly | ## Error Correction Levels | Level | Constant | Error Tolerance | Use Case | |-------|----------|-----------------|----------| | L | `QRCodegenEcc_LOW` | ~7% | Clean environment | | M | `QRCodegenEcc_MEDIUM` | ~15% | General scenarios | | Q | `QRCodegenEcc_QUARTILE` | ~25% | Some damage | | H | `QRCodegenEcc_HIGH` | ~30% | Severe damage | ## Quick Start ### Basic Usage ```vb Dim QR As New cQRcode ' Simple generation Set Image1.Picture = QR.Generate() ``` ### Chainable Settings ```vb Dim QR As New cQRcode ' Chainable call to set properties and generate Set Image1.Picture = QR _ .SetText("https://www.vb6.pro") _ .SetSize(200) _ .SetForeColor(vbBlue) _ .Generate() ``` ### Copy to Clipboard ```vb Dim QR As New cQRcode ' Generate and copy to clipboard QR.SetText("Hello World").Generate True ' Now can paste to other applications ``` ### Save as Image File ```vb Dim QR As New cQRcode ' Generate and save Set QR.Picture = QR.SetText("Save me!").Generate() SavePicture QR.Picture, App.Path & "\qrcode.bmp" ``` ## File Structure | File | Description | |------|-------------| | `cQRcode.cls` | QR code class with simple interface | | `mQRcodeGen.bas` | Core generation algorithm module | ## Low-level Functions (Advanced Usage) For more fine-grained control, you can directly use module functions: ```vb ' Directly use low-level functions Set Picture1.Picture = QRCodegenBarcode( _ TextOrByteArray:="Hello", _ clrFore:=vbBlack, _ Ecl:=QRCodegenEcc_MEDIUM, _ MinVersion:=1, _ MaxVersion:=5, _ Mask:=QRCodegenMask_AUTO, _ BoostEcl:=True, _ PicSize:=300 _ ) ``` *** **Last Updated**: 2026-05-17 --- --- url: /zh/vbman/redis/README.md --- # cRedisClient - Redis 客户端 ## 简介 `cRedisClient` 是一个简单易用的 Redis 数据库客户端，采用 VB6/VBA 编写。它支持 Redis RESP 协议，提供了常用的 Redis 命令接口，包括连接管理、基础操作、数据结构操作和事务等功能。 ## 特性 * 支持基础 Redis 命令 (GET, SET, DEL, EXISTS, KEYS 等) * 支持多种数据结构：String、Hash、List、Set、Sorted Set * 支持管道模式 * 支持事务模式 * 自动重连机制（默认开启） * 内置心跳保持连接 * 支持 Redis 密码认证和 ACL 认证（Redis 6.0+） * 支持多数据库切换 * 同步操作，简单易用 ## 文档目录 * [连接管理](./connection.md) - 连接和断开 Redis 服务器 * [基础命令](./basic-operations.md) - 认证、数据库选择、信息查询等基础操作 * [String 操作](./string-operations.md) - 键值对操作 * [Hash 操作](./hash-operations.md) - 哈希表操作 * [List 操作](./list-operations.md) - 列表操作 * [Set 操作](./set-operations.md) - 集合操作 * [Sorted Set 操作](./sorted-set-operations.md) - 有序集合操作 * [事务操作](./transaction.md) - 事务管理 * [完整示例](./examples.md) - 综合使用示例 * [单元测试](./testing.md) - 功能测试用例与覆盖范围 ## 属性说明 | 属性 | 类型 | 说明 | | ----------------- | -------- | ----------------------------------- | | Host | String | 获取 Redis 服务器地址 | | Port | Long | 获取 Redis 服务器端口 | | Connected | Boolean | 获取是否已连接（内部标志） | | IsConnected | Boolean | 获取 Socket 实际连接状态 | | Username | String | 获取 ACL 认证用户名 | | DbIndex | Long | 获取或设置当前数据库索引 (0-15) | | Timeout | Double | 获取或设置超时时间（秒） | | AutoReconnect | Boolean | 获取或设置是否自动重连（默认 True） | | HeartbeatInterval | Long | 获取或设置心跳间隔（秒，默认 30） | | InTransaction | Boolean | 获取是否在事务中 | | InPipeline | Boolean | 获取是否在管道模式 | | LastError | String | 获取最后一次错误信息 | | Socket | cWinsock | 获取底层的 Socket 对象 | ## 注意事项 1. **连接管理**：使用完毕后记得调用 `DisConnect` 方法释放连接 2. **错误处理**：建议在操作前后检查连接状态和 `LastError` 属性 3. **超时设置**：根据网络环境合理设置 `Timeout` 属性 4. **数据类型**：Redis 中的所有值都以字符串形式存储，数值操作需要转换 5. **事务安全**：事务中的命令不会立即执行，直到调用 `Exec` 或 `Discard` 6. **批量操作**：使用 `MGet`、`MSet` 等批量操作可以提高性能 7. **资源释放**：在对象不再使用时，将其设为 `Nothing` 释放资源 ## 依赖项 * `cWinsock` - Socket 通信组件 * `ToolsUtf8` - UTF-8 编解码工具 * `Dictionary` - 用于 `HGetAll` 返回字典对象 ## 快速开始 ```vb Dim oRedis As New cRedisClient ' 连接到本地 Redis 服务器 If oRedis.Connect() Then Debug.Print "连接成功!" ' 设置键值 oRedis.Set_ "name", "张三" ' 获取值 Debug.Print "姓名: " & oRedis.Get_("name") ' 断开连接 oRedis.DisConnect Else Debug.Print "连接失败: " & oRedis.LastError End If ``` ## 许可证 请参考项目主文档了解许可证信息。 --- --- url: /en/vbman/redis/README.md --- # cRedisClient - Redis Client ## Overview `cRedisClient` is a simple and easy-to-use Redis database client written in VB6/VBA. It supports the Redis RESP protocol and provides common Redis command interfaces, including connection management, basic operations, data structure operations, and transactions. ## Features * Supports basic Redis commands (GET, SET, DEL, EXISTS, KEYS, etc.) * Supports multiple data structures: String, Hash, List, Set, Sorted Set * Supports pipeline mode * Supports transaction mode * Automatic reconnection mechanism (enabled by default) * Built-in heartbeat keep-alive * Supports Redis password authentication and ACL authentication (Redis 6.0+) * Supports multiple database switching * Synchronous operations, simple and easy to use ## Documentation * [Connection Management](./connection.md) - Connect and disconnect from Redis server * [Basic Commands](./basic-operations.md) - Authentication, database selection, information query, etc. * [String Operations](./string-operations.md) - Key-value operations * [Hash Operations](./hash-operations.md) - Hash table operations * [List Operations](./list-operations.md) - List operations * [Set Operations](./set-operations.md) - Set operations * [Sorted Set Operations](./sorted-set-operations.md) - Sorted set operations * [Transaction Operations](./transaction.md) - Transaction management * [Complete Examples](./examples.md) - Comprehensive usage examples * [Unit Testing](./testing.md) - Test cases and coverage ## Properties | Property | Type | Description | | ----------------- | -------- | ----------------------------------------------------- | | Host | String | Get Redis server address | | Port | Long | Get Redis server port | | Connected | Boolean | Get connection status (internal flag) | | IsConnected | Boolean | Get actual Socket connection status | | Username | String | Get ACL authentication username | | DbIndex | Long | Get or set current database index (0-15) | | Timeout | Double | Get or set timeout in seconds | | AutoReconnect | Boolean | Get or set auto-reconnect (default True) | | HeartbeatInterval | Long | Get or set heartbeat interval in seconds (default 30) | | InTransaction | Boolean | Get if in transaction | | InPipeline | Boolean | Get if in pipeline mode | | LastError | String | Get last error message | | Socket | cWinsock | Get underlying Socket object | ## Notes 1. **Connection Management**: Remember to call `DisConnect` method to release connection when done 2. **Error Handling**: Check connection status and `LastError` property before and after operations 3. **Timeout Settings**: Set `Timeout` property appropriately based on network environment 4. **Data Types**: All values in Redis are stored as strings, numeric operations require conversion 5. **Transaction Safety**: Commands in transactions are not executed until `Exec` or `Discard` is called 6. **Batch Operations**: Use `MGet`, `MSet` and other batch operations to improve performance 7. **Resource Release**: Set object to `Nothing` when no longer in use ## Dependencies * `cWinsock` - Socket communication component * `ToolsUtf8` - UTF-8 encoding/decoding tool * `Dictionary` - For `HGetAll` to return dictionary object ## Quick Start ```vb Dim oRedis As New cRedisClient ' Connect to local Redis server If oRedis.Connect() Then Debug.Print "Connected successfully!" ' Set key-value oRedis.Set_ "name", "Zhang San" ' Get value Debug.Print "Name: " & oRedis.Get_("name") ' Disconnect oRedis.DisConnect Else Debug.Print "Connection failed: " & oRedis.LastError End If ``` ## License Please refer to the main project documentation for license information. --- --- url: /zh/vbman/redis/testing.md --- # cRedisClient 单元测试 ## 简介 `Demo_RedisTest.bas` 提供了 cRedisClient 的全功能单元测试，覆盖连接管理、5 种数据类型、事务、数据库切换、属性访问和错误处理。 **源文件位置**: `src\Demos\Redis\Demo_RedisTest.bas` **运行方式**: 在 VB6 IDE 的立即窗口中执行 `Demo_RedisTest.TestRedisClient` *** ## 测试环境 | 项目 | 说明 | |------|------| | Redis 服务器 | dbserver.cc:9736 | | Redis 版本 | 8.2.3 | | 协议 | RESP（非 TLS） | | 客户端类 | cRedisClient | *** ## 测试模块与预期结果 ### \[1] 连接测试 | 测试项 | 方法 | 预期结果 | |--------|------|----------| | 建立连接 | `Connect("dbserver.cc", 9736)` | 返回 True | | 连接状态 | `Connected` | True | | 主机名 | `Host` | dbserver.cc | | 端口 | `Port` | 9736 | | 心跳检测 | `Ping()` | "PONG" | ### \[2] 基础命令测试 | 测试项 | 方法 | 预期结果 | |--------|------|----------| | 设置键值 | `Set_("test_key", "test_value")` | True | | 获取键值 | `Get_("test_key")` | "test\_value" | | 设带过期键 | `Set_("expire_key", "will_expire", 10, 0)` | True | | 查看过期时间 | `TTL("expire_key")` | 10 | | 键存在 | `Exists("test_key")` | 1 | | 键不存在 | `Exists("nonexistent")` | 0 | | 删除键 | `Del("test_key")` | 1 | | 删除后再查 | `Exists("test_key")` | 0 | | 模式匹配 | `Keys("pattern_test*")` | 返回 2 个键的数组 | ### \[3] String 操作测试 | 测试项 | 方法 | 预期结果 | |--------|------|----------| | 自增 | `Incr("counter")` (初始 "10") | 11 | | 再次自增 | `Incr("counter")` | 12 | | 自减 | `Decr("counter")` | 11 | | 批量获取 | `MGet("mkey1", "mkey2", "mkey3", "nonexistent")` | 4 个元素的数组，不存在的键返回空字符串 | ### \[4] Hash 操作测试 | 测试项 | 方法 | 预期结果 | |--------|------|----------| | 设置字段 | `HSet("user:1", "name", "张三")` | True | | 获取字段 | `HGet("user:1", "name")` | "张三" | | 字段存在 | `HExists("user:1", "name")` | True | | 字段不存在 | `HExists("user:1", "email")` | False | | 批量获取 | `HMGet("user:1", "name", "age", "city")` | 3 个元素的数组 | | 获取全部 | `HGetAll("user:1")` | Dictionary 包含 name/age/city | | 删除字段 | `HDel("user:1", "age")` | 1 | ### \[5] List 操作测试 | 测试项 | 方法 | 预期结果 | |--------|------|----------| | 左侧插入3次 | `LPush("mylist", ...)` | 长度 = 3 | | 右侧插入2次 | `RPush("mylist", ...)` | 长度 = 5 | | 列表长度 | `LLen("mylist")` | 5 | | 范围查询 | `LRange("mylist", 0, -1)` | 5 个元素，顺序: item3, item2, item1, item4, item5 | | 左侧弹出 | `LPop("mylist")` | "item3" | | 右侧弹出 | `RPop("mylist")` | "item5" | ### \[6] Set 操作测试 | 测试项 | 方法 | 预期结果 | |--------|------|----------| | 添加成员 | `SAdd("myset", "apple")` 等 | 新增 3 个成员 | | 获取全部 | `SMembers("myset")` | 3 个元素（无序） | | 成员数量 | `SCard("myset")` | 3 | | 成员存在 | `SIsMember("myset", "apple")` | True | | 成员不存在 | `SIsMember("myset", "grape")` | False | | 删除成员 | `SRem("myset", "banana")` | 1 | ### \[7] Sorted Set 操作测试 | 测试项 | 方法 | 预期结果 | |--------|------|----------| | 添加带分数成员 | `ZAdd("leaderboard", 100, "player1")` 等 | 累计添加成员 | | 按分数范围查询 | `ZRange("leaderboard", 0, -1)` | player1, player3, player2（按分数升序） | | 带分数查询 | `ZRange("leaderboard", 0, -1, True)` | 交替返回 member/score | | 成员数量 | `ZCard("leaderboard")` | 3 | | 删除成员 | `ZRem("leaderboard", "player3")` | 1 | ### \[8] 事务操作测试 | 测试项 | 方法 | 预期结果 | |--------|------|----------| | 事务前状态 | `InTransaction` | False | | 开启事务 | `Multi()` | True | | 事务中状态 | `InTransaction` | True | | 事务中执行命令 | `Set_` × 3 | 命令被缓存 | | 提交事务 | `Exec()` | 返回 3 个结果的数组，均为 "OK" | | 提交后状态 | `InTransaction` | False | | 事务回滚 | `Multi()` + `Set_` + `Discard()` | 命令未执行，键不存在 | ### \[9] 服务器信息测试 | 测试项 | 方法 | 预期结果 | |--------|------|----------| | 心跳检测 | `Ping()` | "PONG" | | 服务器信息 | `Info("server")` | 包含 redis\_version 等字段 | | 全部信息 | `Info()` | 返回完整 INFO 文本 | ### \[10] 数据库切换测试 | 测试项 | 方法 | 预期结果 | |--------|------|----------| | 默认数据库 | `DbIndex` | 0 | | 切换数据库 | `SelectDb(1)` | True | | 切换后索引 | `DbIndex` | 1 | | 写入隔离 | db1 SET + db0 GET | db0 中不存在该键 | | 切回数据库 | `SelectDb(0)` | True | ### \[11] 属性测试 | 属性 | 预期值 | |------|--------| | `Host` | dbserver.cc | | `Port` | 9736 | | `Connected` | True | | `DbIndex` | 0 | | `Timeout` | 5 | | `InTransaction` | False | | `InPipeline` | False | ### \[12] 错误处理测试 | 测试项 | 方法 | 预期结果 | |--------|------|----------| | 获取不存在的键 | `Get_("nonexistent_key_12345")` | 空字符串 "" | | 删除不存在的键 | `Del("nonexistent_key_12345")` | 0 | ### \[13] 清理测试数据 自动清理所有测试过程中创建的临时键（expire\_key, counter 等）。 ### \[14] 断开连接 | 测试项 | 方法 | 预期结果 | |--------|------|----------| | 断开连接 | `Disconnect()` | — | | 连接状态 | `Connected` | False | *** ## 测试输出样例 ``` ========================================== cRedisClient 全功能单元测试 ========================================== [1] 连接测试 ---------------------------------------- 连接: 成功 Connected: True Host: dbserver.cc Port: 9736 PING: PONG [2] 基础命令测试 ---------------------------------------- SET test_key: 成功 GET test_key: test_value SET with EX(10s): 成功 TTL expire_key: 10 EXISTS test_key: 1 EXISTS expire_key: 1 EXISTS nonexistent: 0 DEL test_key: 1 个键被删除 EXISTS test_key after DEL: 0 KEYS pattern_test*: 找到 2 个键 - pattern_test1 - pattern_test2 [3] String 操作测试 ---------------------------------------- INCR counter: 11 INCR counter again: 12 DECR counter: 11 MGET mkey1, mkey2, mkey3, nonexistent: [0]: value1 [1]: value2 [2]: value3 [3]: [4] Hash 操作测试 ---------------------------------------- HSET user:1 name: 成功 HGET user:1 name: 张三 HGET user:1 age: 25 HGET user:1 city: 北京 HEXISTS user:1 name: True HEXISTS user:1 email: False HMGET user:1 name, age, city: [0]: 张三 [1]: 25 [2]: 北京 HGETALL user:1: name: 张三 age: 25 city: 北京 HDEL user:1 age: 删除 1 个字段 [5] List 操作测试 ---------------------------------------- LPUSH mylist 3次: 长度=3 RPUSH mylist 2次: 长度=5 LLEN mylist: 5 LRANGE mylist 0 -1: [0]: item3 [1]: item2 [2]: item1 [3]: item4 [4]: item5 LPOP mylist: item3 RPOP mylist: item5 [6] Set 操作测试 ---------------------------------------- SADD myset apple, banana, orange: 新增 3 个成员 SMEMBERS myset: - apple - banana - orange SCARD myset: 3 SISMEMBER myset apple: True SISMEMBER myset grape: False SREM myset banana: 删除 1 个成员 [7] Sorted Set 操作测试 ---------------------------------------- ZADD leaderboard 3 members: 最新新增 1 个成员 ZRANGE leaderboard 0 -1: - player1 - player3 - player2 ZRANGE leaderboard 0 -1 WITHSCORES: - player1: 100 - player3: 150 - player2: 200 ZCARD leaderboard: 3 ZREM leaderboard player3: 删除 1 个成员 [8] 事务操作测试 ---------------------------------------- InTransaction: False MULTI: 成功 InTransaction: True 在事务中执行了3个 SET 命令 EXEC: 返回 3 个结果 [0]: OK [1]: OK [2]: OK GET trans_key1: value1 InTransaction: False DISCARD: 成功 EXISTS discard_key after DISCARD: 0 (应为0) [9] 服务器操作测试 ---------------------------------------- PING: PONG INFO server: (前100字符) # Server redis_version:8.2.3 redis_git_sha1:00000000 redis_git_dirty:1 redis_build_id:c978de5219... INFO: 6373 字节 [10] 数据库切换测试 ---------------------------------------- 当前 DbIndex: 0 SELECT 1: 成功 DbIndex: 1 GET db1_key: in_database_1 SELECT 0: 成功 DbIndex: 0 EXISTS db1_key in db0: 0 (应为0) [11] 属性测试 ---------------------------------------- Host: dbserver.cc Port: 9736 Connected: True DbIndex: 0 Timeout: 5 InTransaction: False InPipeline: False [12] 错误处理测试 ---------------------------------------- GET nonexistent_key_12345: '' (应为空) DEL nonexistent_key_12345: 0 (应为0) [13] 清理测试数据 ---------------------------------------- [14] 断开连接 ---------------------------------------- Connected after Disconnect: False ========================================== 测试完成！ ========================================== ``` *** ## 覆盖率统计 | 类别 | 测试方法数 | 说明 | |------|:--------:|------| | 连接管理 | 2 | Connect, Disconnect | | 基础命令 | 5 | Set\_, Get\_, Del, Exists, Keys, TTL | | String | 4 | Incr, Decr, MGet, Set\_ (带 EX) | | Hash | 5 | HSet, HGet, HMGet, HGetAll, HExists, HDel | | List | 6 | LPush, RPush, LPop, RPop, LLen, LRange | | Set | 5 | SAdd, SMembers, SCard, SIsMember, SRem | | Sorted Set | 4 | ZAdd, ZRange, ZCard, ZRem | | 事务 | 4 | Multi, Exec, Discard, InTransaction | | 服务器 | 2 | Ping, Info | | 数据库 | 2 | SelectDb, DbIndex | | 属性 | 7 | Host, Port, Connected, DbIndex, Timeout, InTransaction, InPipeline | | 错误处理 | 2 | 不存在键的 Get/Del | | **合计** | **48** | | *** **最后更新**: 2026-06-16 --- --- url: /en/vbman/redis/testing.md --- # cRedisClient Unit Testing ## Overview `Demo_RedisTest.bas` provides full-featured unit testing for cRedisClient, covering connection management, 5 data types, transactions, database switching, property access, and error handling. **Source File**: `src\Demos\Redis\Demo_RedisTest.bas` **How to Run**: Execute `Demo_RedisTest.TestRedisClient` in the VB6 IDE Immediate Window *** ## Test Environment | Item | Description | |------|-------------| | Redis Server | dbserver.cc:9736 | | Redis Version | 8.2.3 | | Protocol | RESP (non-TLS) | | Client Class | cRedisClient | *** ## Test Modules and Expected Results ### \[1] Connection Test | Test Case | Method | Expected Result | |-----------|--------|-----------------| | Establish connection | `Connect("dbserver.cc", 9736)` | Returns True | | Connection status | `Connected` | True | | Host name | `Host` | dbserver.cc | | Port | `Port` | 9736 | | Heartbeat | `Ping()` | "PONG" | ### \[2] Basic Commands Test | Test Case | Method | Expected Result | |-----------|--------|-----------------| | Set key-value | `Set_("test_key", "test_value")` | True | | Get key-value | `Get_("test_key")` | "test\_value" | | Set with expiry | `Set_("expire_key", "will_expire", 10, 0)` | True | | Check TTL | `TTL("expire_key")` | 10 | | Key exists | `Exists("test_key")` | 1 | | Key not exists | `Exists("nonexistent")` | 0 | | Delete key | `Del("test_key")` | 1 | | After deletion | `Exists("test_key")` | 0 | | Pattern match | `Keys("pattern_test*")` | Returns array of 2 keys | ### \[3] String Operations Test | Test Case | Method | Expected Result | |-----------|--------|-----------------| | Increment | `Incr("counter")` (initial "10") | 11 | | Increment again | `Incr("counter")` | 12 | | Decrement | `Decr("counter")` | 11 | | Batch get | `MGet("mkey1", "mkey2", "mkey3", "nonexistent")` | 4-element array, non-existent key returns empty string | ### \[4] Hash Operations Test | Test Case | Method | Expected Result | |-----------|--------|-----------------| | Set field | `HSet("user:1", "name", "Zhang San")` | True | | Get field | `HGet("user:1", "name")` | "Zhang San" | | Field exists | `HExists("user:1", "name")` | True | | Field not exists | `HExists("user:1", "email")` | False | | Batch get | `HMGet("user:1", "name", "age", "city")` | 3-element array | | Get all | `HGetAll("user:1")` | Dictionary containing name/age/city | | Delete field | `HDel("user:1", "age")` | 1 | ### \[5] List Operations Test | Test Case | Method | Expected Result | |-----------|--------|-----------------| | Left push 3 times | `LPush("mylist", ...)` | Length = 3 | | Right push 2 times | `RPush("mylist", ...)` | Length = 5 | | List length | `LLen("mylist")` | 5 | | Range query | `LRange("mylist", 0, -1)` | 5 elements, order: item3, item2, item1, item4, item5 | | Left pop | `LPop("mylist")` | "item3" | | Right pop | `RPop("mylist")` | "item5" | ### \[6] Set Operations Test | Test Case | Method | Expected Result | |-----------|--------|-----------------| | Add members | `SAdd("myset", "apple")` etc. | Added 3 members | | Get all | `SMembers("myset")` | 3 elements (unordered) | | Member count | `SCard("myset")` | 3 | | Member exists | `SIsMember("myset", "apple")` | True | | Member not exists | `SIsMember("myset", "grape")` | False | | Remove member | `SRem("myset", "banana")` | 1 | ### \[7] Sorted Set Operations Test | Test Case | Method | Expected Result | |-----------|--------|-----------------| | Add with score | `ZAdd("leaderboard", 100, "player1")` etc. | Cumulative members added | | Query by score range | `ZRange("leaderboard", 0, -1)` | player1, player3, player2 (ascending by score) | | With scores query | `ZRange("leaderboard", 0, -1, True)` | Alternating member/score | | Member count | `ZCard("leaderboard")` | 3 | | Remove member | `ZRem("leaderboard", "player3")` | 1 | ### \[8] Transaction Operations Test | Test Case | Method | Expected Result | |-----------|--------|-----------------| | Before transaction | `InTransaction` | False | | Start transaction | `Multi()` | True | | In transaction | `InTransaction` | True | | Execute commands in transaction | `Set_` x 3 | Commands cached | | Commit transaction | `Exec()` | Returns 3-element array, all "OK" | | After commit | `InTransaction` | False | | Rollback transaction | `Multi()` + `Set_` + `Discard()` | Commands not executed, key doesn't exist | ### \[9] Server Information Test | Test Case | Method | Expected Result | |-----------|--------|-----------------| | Heartbeat | `Ping()` | "PONG" | | Server info | `Info("server")` | Contains redis\_version etc. | | Full info | `Info()` | Returns complete INFO text | ### \[10] Database Switching Test | Test Case | Method | Expected Result | |-----------|--------|-----------------| | Default database | `DbIndex` | 0 | | Switch database | `SelectDb(1)` | True | | After switch index | `DbIndex` | 1 | | Write isolation | db1 SET + db0 GET | Key doesn't exist in db0 | | Switch back | `SelectDb(0)` | True | ### \[11] Properties Test | Property | Expected Value | |----------|---------------| | `Host` | dbserver.cc | | `Port` | 9736 | | `Connected` | True | | `DbIndex` | 0 | | `Timeout` | 5 | | `InTransaction` | False | | `InPipeline` | False | ### \[12] Error Handling Test | Test Case | Method | Expected Result | |-----------|--------|-----------------| | Get non-existent key | `Get_("nonexistent_key_12345")` | Empty string "" | | Delete non-existent key | `Del("nonexistent_key_12345")` | 0 | ### \[13] Cleanup Test Data Automatically cleans up all temporary keys created during testing (expire\_key, counter, etc.). ### \[14] Disconnect | Test Case | Method | Expected Result | |-----------|--------|-----------------| | Disconnect | `Disconnect()` | - | | Connection status | `Connected` | False | *** ## Test Output Sample ``` ========================================== cRedisClient Full Unit Test ========================================== [1] Connection Test ---------------------------------------- Connect: Success Connected: True Host: dbserver.cc Port: 9736 PING: PONG [2] Basic Commands Test ---------------------------------------- SET test_key: Success GET test_key: test_value SET with EX(10s): Success TTL expire_key: 10 EXISTS test_key: 1 EXISTS expire_key: 1 EXISTS nonexistent: 0 DEL test_key: 1 key deleted EXISTS test_key after DEL: 0 KEYS pattern_test*: Found 2 keys - pattern_test1 - pattern_test2 [3] String Operations Test ---------------------------------------- INCR counter: 11 INCR counter again: 12 DECR counter: 11 MGET mkey1, mkey2, mkey3, nonexistent: [0]: value1 [1]: value2 [2]: value3 [3]: [4] Hash Operations Test ---------------------------------------- HSET user:1 name: Success HGET user:1 name: Zhang San HGET user:1 age: 25 HGET user:1 city: Beijing HEXISTS user:1 name: True HEXISTS user:1 email: False HMGET user:1 name, age, city: [0]: Zhang San [1]: 25 [2]: Beijing HGETALL user:1: name: Zhang San age: 25 city: Beijing HDEL user:1 age: 1 field deleted [5] List Operations Test ---------------------------------------- LPUSH mylist 3 times: length=3 RPUSH mylist 2 times: length=5 LLEN mylist: 5 LRANGE mylist 0 -1: [0]: item3 [1]: item2 [2]: item1 [3]: item4 [4]: item5 LPOP mylist: item3 RPOP mylist: item5 [6] Set Operations Test ---------------------------------------- SADD myset apple, banana, orange: Added 3 members SMEMBERS myset: - apple - banana - orange SCARD myset: 3 SISMEMBER myset apple: True SISMEMBER myset grape: False SREM myset banana: 1 member removed [7] Sorted Set Operations Test ---------------------------------------- ZADD leaderboard 3 members: Latest 1 member added ZRANGE leaderboard 0 -1: - player1 - player3 - player2 ZRANGE leaderboard 0 -1 WITHSCORES: - player1: 100 - player3: 150 - player2: 200 ZCARD leaderboard: 3 ZREM leaderboard player3: 1 member removed [8] Transaction Operations Test ---------------------------------------- InTransaction: False MULTI: Success InTransaction: True Executed 3 SET commands in transaction EXEC: Returned 3 results [0]: OK [1]: OK [2]: OK GET trans_key1: value1 InTransaction: False DISCARD: Success EXISTS discard_key after DISCARD: 0 (should be 0) [9] Server Operations Test ---------------------------------------- PING: PONG INFO server: (first 100 chars) # Server redis_version:8.2.3 redis_git_sha1:00000000 redis_git_dirty:1 redis_build_id:c978de5219... INFO: 6373 bytes [10] Database Switching Test ---------------------------------------- Current DbIndex: 0 SELECT 1: Success DbIndex: 1 GET db1_key: in_database_1 SELECT 0: Success DbIndex: 0 EXISTS db1_key in db0: 0 (should be 0) [11] Properties Test ---------------------------------------- Host: dbserver.cc Port: 9736 Connected: True DbIndex: 0 Timeout: 5 InTransaction: False InPipeline: False [12] Error Handling Test ---------------------------------------- GET nonexistent_key_12345: '' (should be empty) DEL nonexistent_key_12345: 0 (should be 0) [13] Cleanup Test Data ---------------------------------------- [14] Disconnect ---------------------------------------- Connected after Disconnect: False ========================================== Test Complete! ========================================== ``` *** ## Coverage Statistics | Category | Test Methods | Description | |----------|:------------:|-------------| | Connection | 2 | Connect, Disconnect | | Basic Commands | 5 | Set\_, Get\_, Del, Exists, Keys, TTL | | String | 4 | Incr, Decr, MGet, Set\_ (with EX) | | Hash | 5 | HSet, HGet, HMGet, HGetAll, HExists, HDel | | List | 6 | LPush, RPush, LPop, RPop, LLen, LRange | | Set | 5 | SAdd, SMembers, SCard, SIsMember, SRem | | Sorted Set | 4 | ZAdd, ZRange, ZCard, ZRem | | Transaction | 4 | Multi, Exec, Discard, InTransaction | | Server | 2 | Ping, Info | | Database | 2 | SelectDb, DbIndex | | Properties | 7 | Host, Port, Connected, DbIndex, Timeout, InTransaction, InPipeline | | Error Handling | 2 | Get/Del non-existent keys | | **Total** | **48** | | *** **Last Updated**: 2026-06-16 --- --- url: /en/CREDITS.md --- # Credits > Great projects are built on the inspiration and contributions of previous excellent projects, as well as the support and feedback from the community. This page summarizes the acknowledgments for the VB6 PRO series of projects. ## Project Credits | Project | Description | | ------------------------------------ | -------------------------------------------- | | [VBMAN Credits](/en/vbman/CREDITS) | VBMAN embedded WEB server and client library | | [VBMAN2 Credits](/en/vbman2/CREDITS) | VBMAN2 WebView2 control library | ## Article Credits Thanks to the following article sites for promoting and recommending VBMAN: * **Writing a Web Backend with VB6? Yes, Someone Actually Did It!** — [WeChat Official Account](https://mp.weixin.qq.com/s/gv7NCNE4F8WLqQr3T5wCXw) *** If you have any contribution suggestions or find someone or projects that need to be thanked, please [contact us](/en/CONTACT). --- --- url: /en/vbman/CREDITS.md --- # VBMAN Credits We would like to thank all the developers and users who have contributed to the VBMAN project. ## Core Contributors * [@woeoio](https://a-vi.com) - Project creator, core code developer ## Contributors ## Special Thanks ## Open Source Projects Thanks to the following open source projects for providing inspiration and foundation for VBMAN: | Project Name | License | Usage | | --------------------------------------------------------------- | ------- | ------------------------------------ | | [wqweto/VbAsyncSocket](https://github.com/wqweto/VbAsyncSocket) | MIT | All `socket` objects are based on it | | [wqweto/ZipArchive](https://github.com/wqweto/ZipArchive) | MIT | `cZipArchive` is based on it | | [Tim Hall/VBA-JSON](https://github.com/VBA-tools/VBA-JSON) | MIT | Used by the `cJson` object backend | | [Jason Peter Brown/HttpMimeType](mailto://jason@bitspaces.com) | MIT | Used `HttpMimeType` | | [David Zimmer/cTimer](http://sandsprite.com) | / | `cTimer` object is derived from it | ## Feedback & Suggestions Thanks to the following users for their bug reports, feature requests, and improvement suggestions: * \[Username/Contact] - Feedback content *** Thank you again to everyone who supports the VBMAN project! If you have any contribution suggestions or find someone or projects that need to be thanked, please [contact us](/en/CONTACT). [Back to Credits](/en/CREDITS) --- --- url: /en/vbman2/CREDITS.md --- # VBMAN2 Credits We would like to thank all the developers and users who have contributed to the VBMAN2 project. ## Core Contributors * [@woeoio](https://a-vi.com) - Project creator, core code developer ## Contributors ## Special Thanks ## Open Source Projects Thanks to the following open source projects for providing inspiration and foundation for VBMAN2: | Project Name | License | Usage | | ---------------------------------------------------------------- | ------- | ------------------------------------- | | [twinBASIC WebView2Package](https://docs.twinbasic.com/WebView2) | MIT | Provides core `webview2` capabilities | ## Feedback & Suggestions Thanks to the following users for their bug reports, feature requests, and improvement suggestions: * \[`周杰`/Group Member] - Suggested binding WEB page elements to VB6/VBA functions *** Thank you again to everyone who supports the VBMAN2 project! If you have any contribution suggestions or find someone or projects that need to be thanked, please [contact us](/en/CONTACT). [Back to Credits](/en/CREDITS) --- --- url: /zh/vbman/crypt/overview.md --- # Crypt 加密组件概述 ## 📖 简介 Crypt 组件提供了一套完整的加密和哈希功能，包括 AES 对称加密、哈希计算（MD5/SHA 系列）和 HMAC 消息认证码。 ## 📁 模块结构 | 模块 | 文件 | 说明 | |------|------|------| | **AES** | `cAes.cls`, `cAesCBC.cls` | AES CBC 模式对称加密 | | **Hash** | `cCryptoHash.cls` | 哈希计算（MD5/SHA1/SHA256/SHA384/SHA512） | | **HMAC** | `cCryptoHMAC.cls` | HMAC 消息认证码（HMAC-SHA1/HMAC-SHA256） | ## ✨ 主要特性 | 特性 | 说明 | |------|------| | **AES 加密** | 基于 MSHTML 的 AES-CBC 加密，支持字符串加密 | | **多算法哈希** | 支持 MD5、SHA1、SHA256、SHA384、SHA512 | | **HMAC 支持** | 支持 HMAC-SHA1、HMAC-SHA256 | | **链式调用** | Hash 和 HMAC 支持流畅的链式 API | | **多种输出格式** | 支持 Hex、Base64、字节数组输出 | | **文件哈希** | 支持直接计算文件哈希值 | ## 🚀 快速开始 ### AES 加密 ```vb Dim Aes As New cAes ' 加密 cipherText = Aes.CBC.Encode("Hello World", "my-password-key-") ' 解密 (Encode 是双向的，需要配合 JS 的 decryptFn) ' 注意：当前实现依赖 JS 资源文件 ``` ### 哈希计算 ```vb Dim Hash As New cCryptoHash ' 简单方式 hashValue = Hash.ComputeHash("Hello World") ' 链式调用 hashValue = Hash.Mode(HASH_ALG_SHA256) _ .DataString("Hello World") _ .ReturnHex() ' 计算文件哈希 fileHash = Hash.ComputeFileHash("C:\data.txt") ``` ### HMAC 计算 ```vb Dim Hmac As New cCryptoHMAC ' 简单方式 result = Hmac.Compute("data", "secret-key") ' 链式调用 result = Hmac.Mode(HMAC_ALG_SHA256) _ .Secret("secret-key") _ .DataString("data") _ .ReturnHex() ``` ## 📁 文档导航 | 文档 | 说明 | |------|------| | [aes/overview.md](./aes/overview.md) | AES 加密概述 | | [aes/methods.md](./aes/methods.md) | AES 方法参考 | | [hash/overview.md](./hash/overview.md) | 哈希组件概述 | | [hash/methods.md](./hash/methods.md) | 哈希方法参考 | | [hmac/overview.md](./hmac/overview.md) | HMAC 组件概述 | | [hmac/methods.md](./hmac/methods.md) | HMAC 方法参考 | *** **最后更新**: 2026-05-17 --- --- url: /en/vbman/crypt/overview.md --- # Crypt Encryption Components Overview ## 📖 Introduction The Crypt component provides a complete set of encryption and hashing functionality, including AES symmetric encryption, hash computation (MD5/SHA series), and HMAC message authentication codes. ## 📁 Module Structure | Module | Files | Description | |--------|-------|-------------| | **AES** | `cAes.cls`, `cAesCBC.cls` | AES CBC mode symmetric encryption | | **Hash** | `cCryptoHash.cls` | Hash computation (MD5/SHA1/SHA256/SHA384/SHA512) | | **HMAC** | `cCryptoHMAC.cls` | HMAC message authentication codes (HMAC-SHA1/HMAC-SHA256) | ## ✨ Key Features | Feature | Description | |---------|-------------| | **AES Encryption** | MSHTML-based AES-CBC encryption with string support | | **Multiple Hash Algorithms** | Supports MD5, SHA1, SHA256, SHA384, SHA512 | | **HMAC Support** | Supports HMAC-SHA1, HMAC-SHA256 | | **Chainable API** | Hash and HMAC support fluent chainable API | | **Multiple Output Formats** | Supports Hex, Base64, byte array output | | **File Hashing** | Supports direct file hash computation | ## 🚀 Quick Start ### AES Encryption ```vb Dim Aes As New cAes ' Encrypt cipherText = Aes.CBC.Encode("Hello World", "my-password-key-") ' Decrypt (Encode is bidirectional, requires JS decryptFn) ' Note: Current implementation depends on JS resource files ``` ### Hash Computation ```vb Dim Hash As New cCryptoHash ' Simple way hashValue = Hash.ComputeHash("Hello World") ' Chainable call hashValue = Hash.Mode(HASH_ALG_SHA256) _ .DataString("Hello World") _ .ReturnHex() ' Compute file hash fileHash = Hash.ComputeFileHash("C:\data.txt") ``` ### HMAC Computation ```vb Dim Hmac As New cCryptoHMAC ' Simple way result = Hmac.Compute("data", "secret-key") ' Chainable call result = Hmac.Mode(HMAC_ALG_SHA256) _ .Secret("secret-key") _ .DataString("data") _ .ReturnHex() ``` ## 📁 Documentation Navigation | Document | Description | |----------|-------------| | [aes/overview.md](./aes/overview.md) | AES encryption overview | | [aes/methods.md](./aes/methods.md) | AES methods reference | | [hash/overview.md](./hash/overview.md) | Hash component overview | | [hash/methods.md](./hash/methods.md) | Hash methods reference | | [hmac/overview.md](./hmac/overview.md) | HMAC component overview | | [hmac/methods.md](./hmac/methods.md) | HMAC methods reference | *** **Last Updated**: 2026-05-17 --- --- url: /zh/biz/cs-auther.md --- # cs-auther — VBMAN 网络授权框架示例 ## 收费项目 > 费用：￥399元 含一套（源码），购买[请联系](/CONTACT) ## 项目简介 `cs-auther` 是一个基于 **VB6** 与 **VBMAN 框架** 构建的 **C/S（客户端/服务端）网络授权系统**演示项目。它展示了一套完整的 TCP 网络通信、JSON 数据交换、用户认证、中间件拦截、公告广播及参数传输的解决方案。 该项目采用经典的路由分发模式，客户端与服务端通过自定义的 JSON 协议进行通信，具备良好的扩展性，适合作为中小型企业内部工具、授权验证系统或网络应用的基础模板。 ## 视频介绍 *** ## 核心特性 | 特性 | 说明 | | ------------------ | -------------------------------------------------------------- | | **TCP 网络通信** | 基于 VBMAN 的 `cWinsock` 组件实现稳定的 TCP 长连接 | | **JSON 数据协议** | 统一的数据封包格式，支持复杂对象传输 | | **路由分发机制** | 通过 `类名/方法名` 动态调用业务逻辑，类似 Web 框架的路由 | | **Token 身份认证** | 登录成功后下发凭证，后续请求需携带 Token 验证 | | **中间件拦截** | 支持中间件链式处理，可用于权限校验、日志记录等 | | **用户在线管理** | 服务端实时追踪在线用户，支持踢人下线 | | **公告推送系统** | 服务端可向所有在线客户端实时推送公告，离线客户端登录后自动同步 | | **参数传输演示** | 内置 50 个多类型参数（数值、布尔、日期、字符串）的完整传输示例 | | **Access 数据库** | 服务端使用 Access 数据库存储用户数据 | | **开机启动设置** | 客户端与服务端均支持设置 Windows 开机启动 | | **密码修改** | 登录后可通过菜单修改密码，服务端记录完整操作日志 | *** ## 项目结构 ``` cs-auther/ ├── dist/ # 编译输出目录 │ ├── 客户端/ # Client.exe │ └── 服务端/ # Server.exe + data.mdb ├── docs/ # 项目文档（本目录） ├── share/ # 客户端与服务端共享代码 │ ├── Common.bas # 公共模块（路由、发送、接收处理） │ └── cMessage.cls # 消息处理类（MsgBox/Toast） ├── src-client/ # 客户端源码 │ ├── Client.vbp # 客户端工程文件 │ ├── Insts.bas # 全局实例（TcpClient, CurrentUser） │ ├── fLogin.frm # 登录窗体 │ ├── Form1.frm # 主窗体 │ ├── fSetting.frm # 服务器配置窗体 │ ├── fChangePwd.frm # 修改密码窗体 │ ├── bUser.cls # 用户业务类 │ ├── bNotify.cls # 公告业务类 │ └── bCalc.cls # 计算参数演示类 └── src-server/ # 服务端源码 ├── Server.vbp # 服务端工程文件 ├── Insts.bas # 全局实例（TcpServer, Db） ├── Form1.frm # 服务端主窗体 ├── fNotify.frm # 公告编辑窗体 ├── bUser.cls # 用户登录验证类 ├── bNotify.cls # 公告查询类 ├── bCalc.cls # 计算参数处理类 ├── mAuth.cls # 授权中间件 └── data.mdb # Access 用户数据库 ``` *** ## 技术栈 * **开发语言**: Visual Basic 6.0 (VB6) * **基础框架**: [VBMAN.dll](https://github.com/vbmanlib/vbman) — 提供网络、JSON、数据库、UI 等通用能力 * **数据库**: Microsoft Access (`.mdb`) * **通信协议**: TCP + 自定义 JSON 协议 * **目标平台**: Windows (32位) *** ## 文档导航 | 文档 | 内容 | | ------------------------------------ | ----------------------------------------------- | | [architecture.md](./architecture.md) | 系统架构、模块关系、运行流程 | | [protocol.md](./protocol.md) | 通信协议格式、路由规则、消息类型 | | [filetransfer.md](./filetransfer.md) | **文件传输系统** — 分片传输、自动归档、进度监控 | | [client.md](./client.md) | 客户端模块详解、窗体说明、业务类 | | [server.md](./server.md) | 服务端模块详解、数据库结构、中间件机制 | | [logging.md](./logging.md) | 日志系统详解（全局日志、业务专用日志） | | [shared.md](./shared.md) | 共享模块说明（Common、cMessage） | | [quickstart.md](./quickstart.md) | 环境准备、编译运行、快速体验 | --- --- url: /zh/vbman/serialport/faq.md --- # cSerialPort 常见问题 ## 📖 目录 * [端口问题](#端口问题) * [数据收发问题](#数据收发问题) * [配置问题](#配置问题) * [事件与监控问题](#事件与监控问题) * [错误处理](#错误处理) *** ## 端口问题 ### Q: 打开 COM10 以上端口失败？ **A:** `cSerialPort` 内部已自动处理 `\\.\COMx` 前缀，直接传 `"COM10"` 即可。如果仍失败，请检查： 1. 端口是否已被其他程序占用 2. 端口是否真实存在（用 `EnumSerialPorts` 检查） 3. 驱动是否正常安装 ```vb ' 检查可用端口 Dim ports As Collection Set ports = EnumSerialPorts() Dim p As Variant For Each p In ports Debug.Print p Next ``` ### Q: OpenPort 返回 False，如何排查？ **A:** 检查 `LastError` 和 `LastErrorMsg`： ```vb If Not sp.OpenPort("COM3") Then Debug.Print "错误码: " & sp.LastError Debug.Print "错误描述: " & sp.LastErrorMsg End If ``` 常见错误： * **错误码 5（拒绝访问）**：端口被其他程序占用 * **错误码 2（找不到文件）**：端口不存在 * **错误码 87（参数错误）**：配置参数不合法 ### Q: 端口打开后能改端口名吗？ **A:** 不能。`PortName` 在 `IsOpen=True` 时不可修改，需先 `ClosePort` 再修改。 *** ## 数据收发问题 ### Q: 发送了数据但收不到？ **A:** 排查步骤： 1. **确认物理连接**：TX/RX 是否交叉连接（一端的 TX 接另一端的 RX） 2. **确认配置一致**：双方波特率、数据位、校验位、停止位必须一致 3. **确认信号线**：如果使用硬件流控制，CTS 必须为高电平才能发送 4. **检查流控制**：尝试设为 `fcNone` 排除流控制干扰 ```vb ' 排查配置 Debug.Print sp.GetStatusString() ' 尝试无流控制 sp.Config.FlowControl = fcNone sp.ApplyConfig ``` ### Q: ReadExisting 返回空字符串？ **A:** 可能原因： 1. 缓冲区确实没有数据（`InBufferCount = 0`） 2. 读取超时设置过短 3. 数据还未到达（异步传输有延迟） ```vb ' 先检查缓冲区 If sp.InBufferCount > 0 Then Debug.Print sp.ReadExisting() Else Debug.Print "缓冲区为空" End If ``` ### Q: ReadLine 一直阻塞不返回？ **A:** `ReadLine` 会阻塞直到收到结束符（默认 `vbCrLf`）或超时。如果对端发送的数据没有换行符，会一直等待。 解决方案： 1. 设置读取超时：`sp.Config.SetReadTimeout 5000` 2. 确认对端是否发送 `vbCrLf`（回车换行） 3. 改用 `ReadExisting` 非阻塞读取 ### Q: 接收到的中文乱码？ **A:** `ReadText`/`WriteText` 使用 `StrConv` 按 ANSI/系统代码页转换。如果对端使用 UTF-8 编码，需要用字节数组方式收发并自行转换： ```vb ' 接收 UTF-8 字节数组 Dim buf() As Byte sp.ReadData buf ' 手动转为 Unicode 字符串（需借助 cJson 或其他 UTF-8 解码工具） Dim s As String s = DecodeUtf8(buf) ``` *** ## 配置问题 ### Q: 修改配置后不生效？ **A:** 端口已打开时，修改 `Config` 属性后需要调用 `ApplyConfig` 才能生效： ```vb sp.OpenPort sp.Config.BaudRate = br115200 sp.ApplyConfig ' ← 必须调用 ``` 但如果通过 `Set sp.Config = newCfg` 替换整个配置对象，会自动应用。 ### Q: DataBits 设置报错？ **A:** `DataBits` 范围必须是 4~8，超出范围会抛出错误： ```vb cfg.DataBits = 3 ' 报错！ cfg.DataBits = 8 ' 正确 ``` ### Q: InBufferSize 设置报错？ **A:** `InBufferSize` 和 `OutBufferSize` 必须大于 0： ```vb cfg.InBufferSize = 0 ' 报错！ cfg.InBufferSize = 4096 ' 正确 ``` ### Q: 设置 FlowControl 后 RTS/DTR 行为异常？ **A:** 设置 `FlowControl` 会自动同步 DTR/RTS 控制模式： | FlowControl | 自动设置的 DTR/RTS | |-------------|-------------------| | `fcRtsCts` | RtsControl = Handshake | | `fcDtrDsr` | DtrControl = Handshake | | `fcRtsCtsAndXonXoff` | RtsControl = Handshake | 使用硬件流控制后，手动 `SetRTS`/`SetDTR` 可能被流控制机制覆盖。 *** ## 事件与监控问题 ### Q: DataReceived 事件不触发？ **A:** 必须先调用 `StartMonitoring` 启动监控： ```vb sp.OpenPort sp.StartMonitoring 50 ' ← 必须调用 ``` 另外检查： 1. 对端是否确实发送了数据 2. `PollInterval` 是否合理（默认 50ms） 3. 对象是否用 `WithEvents` 声明 ### Q: WaitForEvent 冻结了界面？ **A:** `WaitForEvent` 是阻塞方法，会冻结 UI 线程。**不要在 UI 线程使用**。改用 `StartMonitoring` 异步监控： ```vb ' ❌ 错误：会冻结界面 sp.WaitForEvent EV_RXCHAR ' ✅ 正确：异步监控 sp.StartMonitoring 50 ``` ### Q: 如何同时监控信号线变化？ **A:** 异步监控模式（`StartMonitoring`）目前不监控信号线变化。如需监控信号线，只能使用 `WaitForEvent`（但会阻塞线程），或自行用 Timer 定期查询： ```vb Private Sub tmrPin_Timer() Static lastCts As Boolean Dim cts As Boolean cts = sp.CtsHolding If cts <> lastCts Then Debug.Print "CTS 变化: " & cts lastCts = cts End If End Sub ``` *** ## 错误处理 ### Q: 收到 CE\_RXOVER（接收缓冲区溢出）错误？ **A:** 接收速度超过处理速度，缓冲区满了。解决方案： 1. **增大缓冲区**：`cfg.InBufferSize = 8192` 2. **加快读取频率**：减小 `PollInterval` 3. **事件中快速读取**：`DataReceived` 事件中立即调用 `ReadExisting` 4. **使用流控制**：`cfg.FlowControl = fcXonXoff` ### Q: 收到 CE\_RXPARITY（校验错误）？ **A:** 通信线路干扰或配置不一致。检查： 1. 双方校验位设置是否一致 2. 线路是否有干扰（长距离、无屏蔽） 3. 波特率是否过高（降低波特率试试） ### Q: 收到 CE\_FRAME（帧错误）？ **A:** 通常是波特率不匹配。确认双方波特率完全一致： ```vb Debug.Print "当前波特率: " & sp.Config.BaudRate ``` ### Q: 如何获取详细的错误信息？ **A:** 使用以下方法： ```vb ' 获取通信错误码 Dim errs As Long errs = sp.ReadCommErrors() ' 获取中文错误描述 Debug.Print GetCommErrorString(errs) ' 获取完整状态 Debug.Print sp.GetStatusString() ``` *** **最后更新**: 2026-07-05 --- --- url: /zh/vbman/serialport/overview.md --- # cSerialPort 串口通信开发文档 > 🚀 **cSerialPort** - 纯 Win32 API 实现的 VB6 串口通信类，完整封装 Windows 串口通信能力 ## 📖 目录 * [概述](#概述) * [核心特性](#核心特性) * [与 MSComm 控件的对比](#与-mscomm-控件的对比) * [架构设计](#架构设计) * [快速开始](#快速开始) * [文档索引](#文档索引) *** ## 概述 `cSerialPort` 是 VBManLib 提供的串口通信类，直接调用 Win32 API 实现完整的串口通信功能。相比传统 MSComm 控件，它无需 OCX 依赖、支持 COM10 以上端口、可精确控制底层参数，适合工业控制、设备通信、Modbus 等场景。 ### ✨ 主要特性 * 🔌 **纯 API 实现** - 无需 MSComm OCX 控件，零外部依赖 * 🎯 **完整封装** - 覆盖打开/关闭、读写、配置、信号线、错误处理、缓冲区管理 * 📡 **事件驱动** - 异步轮询监控，不阻塞 UI 线程 * 🔧 **精确配置** - 完整 DCB/COMMTIMEOUTS 参数，支持流控制、超时预设 * 📊 **信号线控制** - DTR/RTS/Break/XON/XOFF 全套信号线操作 * 🔍 **端口枚举** - 自动扫描系统可用串口 * 📦 **二进制与文本** - 同时支持字节数组和文本读写 * 🛡️ **错误诊断** - 中文错误描述，完整状态查询 *** ## 核心特性 ### 1️⃣ 无 OCX 依赖 🔌 传统 MSComm 控件需要注册 `MSCOMM32.OCX`，部署麻烦且在 COM10 以上端口无法使用。`cSerialPort` 直接调用 `kernel32` API，零依赖。 ### 2️⃣ 异步事件监控 📡 使用 Win32 Timer 定时轮询缓冲区，检测到新数据自动触发 `DataReceived` 事件，不阻塞 UI 线程： ```vb Dim WithEvents sp As cSerialPort Private Sub Start() Set sp = New cSerialPort sp.PortName = "COM3" sp.OpenPort sp.StartMonitoring 50 ' 50ms 轮询 End Sub Private Sub sp_DataReceived(ByVal BytesCount As Long) Debug.Print "收到: " & sp.ReadExisting() End Sub ``` ### 3️⃣ 完整信号线控制 📊 支持 DTR/RTS/Break 手动控制，以及 CTS/DSR/RING/CD 状态查询： ```vb sp.SetDTR True ' 设置 DTR sp.SetRTS True ' 设置 RTS sp.SetBreak True ' 发送 Break 信号 Debug.Print sp.CtsHolding ' 查询 CTS 状态 ``` ### 4️⃣ 灵活超时配置 ⏱️ 提供三种预设模式，也可手动精确控制每个超时参数： ```vb sp.Config.SetNonBlockingRead ' 非阻塞：立即返回 sp.Config.SetBlockingRead ' 阻塞：等待指定字节数 sp.Config.SetReadTimeout 2000 ' 带超时：2秒 ``` ### 5️⃣ 模式字符串兼容 🔤 支持与 `BuildCommDCB` API 兼容的模式字符串： ```vb sp.Config.FromModeString "baud=9600 parity=N data=8 stop=1" ``` ### 6️⃣ 数据分帧 🧩 解决设备连发导致的"粘包"问题，识别每一帧的边界： * **方案 B（帧间隔超时）**：设置 `FrameInterval` 属性，利用设备发完一帧后的停顿自动分帧 * **方案 C（协议分帧解析器）**：`cSerialFrameParser` 类按分隔符/起止标记/长度字段/固定长度精确切分 ```vb ' 方案 B：30ms 无新数据 = 一帧结束 sp.FrameInterval = 30 sp.StartMonitoring 20 Private Sub sp_FrameReceived(FrameData() As Byte) Debug.Print "收到帧: " & StrConv(FrameData, vbUnicode) End Sub ``` 详见 [分帧协议专题](./framing.md) *** ## 与 MSComm 控件的对比 | 特性 | MSComm 控件 | cSerialPort 类 | |------|------------|----------------| | **依赖** | 需注册 MSCOMM32.OCX | 纯 API，零依赖 | | **端口限制** | 仅 COM1~COM9 | 支持 COM10 以上 | | **事件模型** | OnComm 事件 + CommEvent | 独立的事件（DataReceived 等） | | **信号线控制** | DTREnable/RTSEnable 属性 | SetDTR/SetRTS/SetBreak 方法 | | **超时控制** | 无（仅 InputLen/Threshold） | 完整 COMMTIMEOUTS 五参数 | | **流控制** | Handshaking 属性（有限） | 完整 RTS/CTS、DTR/DSR、XON/XOFF | | **缓冲区管理** | InBufferCount/OutBufferCount | 同上 + PurgeRx/PurgeTx/PurgeAll | | **错误诊断** | 无详细错误 | 中文错误描述 + 状态字符串 | | **二进制支持** | Input 属性 | ReadData/WriteData 字节数组 | | **波特率** | 最高 115200 | 最高 256000（eBaudRate 枚举） | | **数据分帧** | 无（仅 RThreshold 触发） | FrameInterval + cSerialFrameParser，解决粘包 | | **端口枚举** | 无 | EnumSerialPorts 自动扫描 | *** ## 架构设计 ### 类层次结构 ``` cSerialPort (公开类) ├── m_Config: cSerialConfig (配置对象) ├── m_Handle: Long (串口句柄) ├── m_TimerID: Long (监控定时器) └── 事件：DataReceived, ErrorOccurred, PinChanged, TxEmpty, BreakDetected, RingDetected ``` ### 子模块类 | 类名/模块 | 文件 | 职责 | |-----------|------|------| | `cSerialConfig` | `cSerialConfig.cls` | 串口配置：封装 DCB 和 COMMTIMEOUTS，提供类型安全访问；定义配置枚举（`eBaudRate`/`eParity`/`eStopBits`/`eDtrControl`/`eRtsControl`/`eFlowControl`） | | `cSerialPort` | `cSerialPort.cls` | 串口主类；定义通信枚举（`eCommEvent`/`eCommError`/`eModemStatus`） | | `modSerialPortAPI` | `modSerialPortAPI.bas` | API 声明、常量、类型、辅助函数 | > **说明**：所有 `Public Enum` 均定义在类模块中（而非标准模块），因为 VB6 标准模块的 `Public Enum` 不会随 DLL 类型库导出。移至类模块后，外部工程引用 DLL 时即可使用 `br115200`、`EV_RXCHAR`、`CE_RXOVER` 等枚举常量。`modSerialPortAPI` 内部辅助函数（如 `GetCommErrorString`）使用底层数值，避免与类模块形成循环引用。 ### 对象关系图 ``` cSerialPort ├── Config (cSerialConfig) │ ├── BuildDCB() → DCB 结构 │ ├── BuildTimeouts() → COMMTIMEOUTS 结构 │ └── 预设方法 → 非阻塞/阻塞/超时模式 ├── Handle (串口句柄) │ ├── ReadFile / WriteFile │ ├── GetCommModemStatus (信号线) │ ├── ClearCommError (错误/状态) │ └── PurgeComm (缓冲区) └── Timer (监控定时器) └── Poll() → 触发 DataReceived 事件 ``` ### 工作流程 ``` 1. 创建 cSerialConfig 配置参数 2. cSerialPort.OpenPort() 打开串口 3. (可选) StartMonitoring() 启动事件监控 4. WriteText/WriteData 发送数据 5. DataReceived 事件 / ReadExisting 读取数据 6. ClosePort() 关闭串口 ``` *** ## 快速开始 ### 最简收发示例 ```vb Dim sp As New cSerialPort sp.PortName = "COM3" sp.Config.BaudRate = br115200 If sp.OpenPort() Then sp.WriteText "Hello" Debug.Print sp.ReadExisting() sp.ClosePort End If ``` ### 事件驱动收发示例 ```vb Private WithEvents m_Port As cSerialPort Private Sub Form_Load() Set m_Port = New cSerialPort m_Port.PortName = "COM3" m_Port.Config.BaudRate = br9600 If m_Port.OpenPort() Then m_Port.StartMonitoring 50 End If End Sub Private Sub m_Port_DataReceived(ByVal BytesCount As Long) Debug.Print "收到: " & m_Port.ReadExisting() End Sub Private Sub Form_Unload(Cancel As Integer) m_Port.ClosePort End Sub ``` > 更完整的示例参见 [快速入门](./quickstart.md) *** ## 文档索引 | 文档 | 描述 | |------|------| | [快速入门](./quickstart.md) | 最简引用方式、常见场景代码示例 | | [属性详解](./properties.md) | 所有属性的说明、类型和用途 | | [方法详解](./methods.md) | 所有方法的参数、返回值和使用示例 | | [事件详解](./events.md) | 所有事件的详细说明和使用示例 | | [分帧协议](./framing.md) | 解决粘包问题：帧间隔分帧 + 协议分帧解析器 | | [高级进阶](./advanced.md) | 流控制、超时策略、二进制协议、虚拟串口等 | | [常见问题](./faq.md) | 常见问题与解决方案 | *** **最后更新**: 2026-07-05 --- --- url: /zh/vbman/serialport/methods.md --- # cSerialPort 方法详解 ## 📋 方法列表 ### 打开/关闭 | 方法名 | 返回类型 | 说明 | |--------|----------|------| | `OpenPort` | Boolean | 打开串口 | | `ClosePort` | - | 关闭串口 | | `ApplyConfig` | - | 重新应用配置到已打开端口 | | `RefreshConfig` | - | 从端口读取当前配置 | ### 读取 | 方法名 | 返回类型 | 说明 | |--------|----------|------| | `ReadData` | Long | 读取字节数组 | | `ReadText` | String | 读取文本 | | `ReadExisting` | String | 非阻塞读取所有现有数据 | | `ReadByte` | Integer | 读取单字节(0~255)，超时返回 -1 | | `ReadLine` | String | 读取一行 | ### 写入 | 方法名 | 返回类型 | 说明 | |--------|----------|------| | `WriteData` | Long | 写入字节数组 | | `WriteText` | Long | 写入文本 | | `WriteByte` | - | 写入单字节 | | `WriteLine` | Long | 写入一行（自动追加换行符） | | `TransmitImmediate` | Boolean | 优先传输字符，绕过缓冲区 | ### 信号线 | 方法名 | 说明 | |--------|------| | `SetDTR` | 设置 DTR 信号 | | `SetRTS` | 设置 RTS 信号 | | `SetBreak` | 设置/清除 Break 信号 | | `SendXOff` | 发送 XOFF | | `SendXOn` | 发送 XON | ### 缓冲区 | 方法名 | 说明 | |--------|------| | `PurgeRx` | 清空接收缓冲区 | | `PurgeTx` | 清空发送缓冲区 | | `PurgeAll` | 清空所有缓冲区 | ### 监控 | 方法名 | 返回类型 | 说明 | |--------|----------|------| | `StartMonitoring` | Boolean | 开始异步监控 | | `StopMonitoring` | - | 停止监控 | | `WaitForEvent` | Long | 阻塞等待事件（慎用） | | `GetEventMask` | Long | 获取当前事件掩码 | ### 诊断 | 方法名 | 返回类型 | 说明 | |--------|----------|------| | `GetStatusString` | String | 获取完整状态字符串 | | `ReadCommErrors` | Long | 获取通信错误码 | | `ReadModemStatus` | Long | 获取 Modem 状态字 | | `ResetCounters` | - | 重置收发计数 | *** ## 🔓 OpenPort ### 说明 打开串口。内部自动处理 `\\.\COMx` 前缀，支持 COM10 以上端口。 ### 语法 ```vb Public Function OpenPort(Optional ByVal Port As String, _ Optional ByVal Config As cSerialConfig) As Boolean ``` ### 参数 | 参数 | 类型 | 说明 | |------|------|------| | `Port` | String（可选） | 端口名，如 "COM3" | | `Config` | cSerialConfig（可选） | 配置对象 | ### 返回值 成功返回 `True`，失败返回 `False` 并设置 `LastError`。 ### 使用示例 ```vb ' 方式一：先设属性再打开 sp.PortName = "COM3" sp.Config.BaudRate = br115200 If sp.OpenPort() Then Debug.Print "打开成功" ' 方式二：参数方式 Dim cfg As New cSerialConfig cfg.BaudRate = br9600 sp.OpenPort "COM3", cfg ``` ### 打开流程 ``` 1. CreateFile 打开 \\.\COMx 2. SetupComm 设置缓冲区大小 3. SetCommState 应用 DCB 配置 4. SetCommTimeouts 应用超时配置 5. PurgeComm 清空缓冲区 ``` *** ## 🔒 ClosePort ### 说明 关闭串口并释放句柄。若正在监控会先停止。 ```vb sp.ClosePort ``` > `Class_Terminate` 会自动调用此方法。 *** ## 📤 WriteText ### 说明 写入文本，使用 `StrConv` 转 ANSI 字节后发送。 ### 语法 ```vb Public Function WriteText(ByVal Text As String) As Long ``` ### 返回值 实际写入的字节数。 ```vb Dim n As Long n = sp.WriteText("Hello") Debug.Print "发送 " & n & " 字节" ``` *** ## 📤 WriteData ### 说明 写入字节数组，适用于二进制协议。 ### 语法 ```vb Public Function WriteData(Buffer() As Byte) As Long ``` ```vb Dim buf(2) As Byte buf(0) = &H41: buf(1) = &H42: buf(2) = &H43 sp.WriteData buf ' 发送 ABC ``` *** ## 📤 WriteLine ### 说明 写入一行文本，自动追加换行符（默认 `vbCrLf`）。 ### 语法 ```vb Public Function WriteLine(ByVal Text As String, _ Optional ByVal Terminator As String = vbCrLf) As Long ``` ```vb sp.WriteLine "Hello" ' 发送 "Hello" & vbCrLf sp.WriteLine "Data", vbLf ' 自定义结束符 ``` *** ## 📤 TransmitImmediate ### 说明 优先传输字符，绕过发送缓冲区直接发送。 ```vb sp.TransmitImmediate &H55 ' 立即发送 0x55 ``` *** ## 📥 ReadExisting ### 说明 非阻塞读取输入缓冲区中所有现有数据。 ```vb Dim s As String s = sp.ReadExisting() If Len(s) > 0 Then Debug.Print "收到: " & s ``` *** ## 📥 ReadData ### 说明 读取字节数组。 ### 语法 ```vb Public Function ReadData(Buffer() As Byte, _ Optional ByVal BytesToRead As Long = -1) As Long ``` ### 参数 | 参数 | 类型 | 说明 | |------|------|------| | `Buffer` | Byte() | 输出缓冲区，自动 ReDim | | `BytesToRead` | Long（可选） | 要读取的字节数，-1 表示读取全部 | ### 返回值 实际读取的字节数。 ```vb Dim buf() As Byte Dim n As Long n = sp.ReadData(buf) ' 读取全部 n = sp.ReadData(buf, 10) ' 读取最多10字节 ``` *** ## 📥 ReadLine ### 说明 读取一行，默认以 `vbCrLf` 结尾。可能阻塞直到收到完整行或超时。 ### 语法 ```vb Public Function ReadLine(Optional ByVal Terminator As String = vbCrLf) As String ``` ```vb sp.Config.SetReadTimeout 5000 ' 设置超时 Dim line As String line = sp.ReadLine() ' 读取一行 ``` *** ## 📡 StartMonitoring ### 说明 开始异步监控，使用 Win32 Timer 定时轮询缓冲区。检测到新数据触发 `DataReceived` 事件。 ### 语法 ```vb Public Function StartMonitoring(Optional ByVal IntervalMs As Long = 50) As Boolean ``` ```vb sp.StartMonitoring 50 ' 50ms 轮询 sp.StartMonitoring ' 默认50ms ``` *** ## 📡 StopMonitoring 停止异步监控。 ```vb sp.StopMonitoring ``` *** ## ⚠️ WaitForEvent ### 说明 阻塞式等待通信事件。 ### 语法 ```vb Public Function WaitForEvent(ByVal EventMask As Long) As Long ``` ### 参数 | 参数 | 类型 | 说明 | |------|------|------| | `EventMask` | Long | 事件组合，如 `EV_RXCHAR Or EV_CTS` | ### 返回值 实际发生的事件掩码，0 表示失败。 > **⚠️ 警告**：此方法会阻塞调用线程！在 UI 线程中使用将冻结界面。建议仅在后台线程或控制台应用中使用，常规场景请用 `StartMonitoring`。 *** ## 🔧 SetDTR / SetRTS ### 说明 手动设置 DTR/RTS 信号线。注意：如果配置了硬件流控制（`fcRtsCts`/`fcDtrDsr`），手动设置可能被流控制覆盖。 ```vb sp.SetDTR True sp.SetRTS True sp.SetDTR False sp.SetRTS False ``` *** ## 🔧 SetBreak ### 说明 设置或清除 Break 信号。Break 信号会使数据线保持为0状态。 ```vb sp.SetBreak True ' 开始发送 Break ' 延时... sp.SetBreak False ' 停止 Break ``` *** ## 🧹 PurgeRx / PurgeTx / PurgeAll ### 说明 清空缓冲区。 | 方法 | 说明 | |------|------| | `PurgeRx` | 清空接收缓冲区 | | `PurgeTx` | 清空发送缓冲区 | | `PurgeAll` | 清空所有缓冲区，终止所有挂起的 I/O | ```vb sp.PurgeAll ' 清空所有 ``` *** ## 📊 GetStatusString ### 说明 获取当前串口完整状态字符串，用于调试。 ```vb Debug.Print sp.GetStatusString() ``` 输出示例： ``` Port: COM3 Open: True BaudRate: 115200 DataBits: 8 InBuffer: 0 CTS: True Received: 128 Sent: 64 Monitoring: True ``` *** ## 🔄 ApplyConfig / RefreshConfig | 方法 | 说明 | |------|------| | `ApplyConfig` | 将当前 `Config` 重新应用到已打开的端口 | | `RefreshConfig` | 从端口读取当前 DCB/超时并更新 `Config` | ```vb sp.OpenPort sp.Config.BaudRate = br9600 sp.ApplyConfig ' 应用新配置 sp.RefreshConfig ' 从端口读取实际配置 Debug.Print sp.Config.BaudRate ``` *** ## 📊 EnumSerialPorts ### 说明 枚举系统中可用的串口号（定义在 `modSerialPortAPI` 模块中）。 ### 语法 ```vb Public Function EnumSerialPorts() As Collection ``` ```vb Dim ports As Collection Set ports = EnumSerialPorts() Dim p As Variant For Each p In ports Debug.Print p Next ``` *** **最后更新**: 2026-07-05 --- --- url: /zh/vbman/serialport/advanced.md --- # cSerialPort 高级进阶 ## 📖 目录 * [流控制详解](#流控制详解) * [超时策略详解](#超时策略详解) * [二进制协议处理](#二进制协议处理) * [虚拟串口与回环测试](#虚拟串口与回环测试) * [动态配置管理](#动态配置管理) * [Modbus RTU 实践](#modbus-rtu-实践) *** ## 流控制详解 流控制用于协调发送方和接收方的速率，防止数据丢失。`cSerialConfig` 支持五种流控制模式。 ### 流控制类型 | 模式 | 常量 | 说明 | |------|------|------| | 无流控制 | `fcNone` | 不使用流控制 | | 软件流控制 | `fcXonXoff` | 通过 XON/XOFF 字符控制 | | 硬件流控制 RTS/CTS | `fcRtsCts` | 通过 RTS/CTS 信号线控制 | | 硬件流控制 DTR/DSR | `fcDtrDsr` | 通过 DTR/DSR 信号线控制 | | 混合流控制 | `fcRtsCtsAndXonXoff` | 同时使用硬件和软件流控制 | ### 软件流控制（XON/XOFF） 发送方在数据过多时收到 XOFF(\&H13) 暂停发送，收到 XON(\&H11) 恢复发送。 ```vb cfg.FlowControl = fcXonXoff ' 可自定义 XON/XOFF 字符 cfg.XonChar = &H11 cfg.XoffChar = &H13 ``` 也可手动发送 XON/XOFF： ```vb sp.SendXOff ' 请求对方暂停发送 sp.SendXOn ' 请求对方恢复发送 ``` ### 硬件流控制（RTS/CTS） 使用 RTS/CTS 信号线进行硬件握手。发送方检测到 CTS 为高电平时才发送数据。 ```vb cfg.FlowControl = fcRtsCts ' 设置 FlowControl 会自动将 RtsControl 设为 rcHandshake ``` > **注意**：使用硬件流控制后，手动 `SetRTS`/`SetDTR` 可能被流控制机制覆盖。 ### DTR/RTS 控制模式 | 模式 | 常量 | DTR/RTS 行为 | |------|------|--------------| | 禁用 | `dcDisable`/`rcDisable` | 信号线保持低电平 | | 启用 | `dcEnable`/`rcEnable` | 信号线保持高电平 | | 握手 | `dcHandshake`/`rcHandshake` | 由流控制自动管理 | | 切换 | `rcToggle` | 仅 RTS，有数据时拉高 | *** ## 超时策略详解 Win32 串口超时由五个参数控制，理解它们的工作机制至关重要。 ### 超时参数 | 参数 | 说明 | |------|------| | `ReadIntervalTimeout` | 两次读取字符间的最大间隔(ms) | | `ReadTotalTimeoutMultiplier` | 每字节超时系数(ms/字节) | | `ReadTotalTimeoutConstant` | 读取固定超时(ms) | | `WriteTotalTimeoutMultiplier` | 写入每字节超时系数 | | `WriteTotalTimeoutConstant` | 写入固定超时(ms) | ### 读取超时计算 ``` 总超时 = ReadTotalTimeoutMultiplier × 请求数据量 + ReadTotalTimeoutConstant ``` ### 三种预设模式 #### 1. 非阻塞读取 `Read` 立即返回，有数据就读，没数据返回空。 ```vb cfg.SetNonBlockingRead ' 等价于： ' ReadIntervalTimeout = MAXDWORD (&HFFFFFFFF) ' ReadTotalTimeoutMultiplier = 0 ' ReadTotalTimeoutConstant = 0 ``` #### 2. 阻塞读取 等待直到读取到指定字节数，可能永久阻塞。 ```vb cfg.SetBlockingRead ' 等价于： ' ReadIntervalTimeout = 0 ' ReadTotalTimeoutMultiplier = 0 ' ReadTotalTimeoutConstant = 0 ``` > **⚠️ 警告**：阻塞模式下如果没有数据会永久挂起，建议配合 `ReadTotalTimeoutConstant` 使用。 #### 3. 带超时读取 指定总超时时间。 ```vb cfg.SetReadTimeout 2000 ' 2秒超时 ' 等价于： ' ReadIntervalTimeout = 50 ' ReadTotalTimeoutMultiplier = 0 ' ReadTotalTimeoutConstant = 2000 ``` ### 自定义超时示例 按字节数计算超时，适合已知数据长量的场景： ```vb ' 每字节 10ms + 固定 100ms cfg.ReadIntervalTimeout = 50 cfg.ReadTotalTimeoutMultiplier = 10 cfg.ReadTotalTimeoutConstant = 100 ' 读取100字节总超时 = 10×100 + 100 = 1100ms ``` *** ## 二进制协议处理 ### 发送二进制帧 ```vb ' 构建 Modbus RTU 请求帧 Dim frame(7) As Byte frame(0) = &H01 ' 从站地址 frame(1) = &H03 ' 功能码：读保持寄存器 frame(2) = &H00 ' 起始地址高字节 frame(3) = &H00 ' 起始地址低字节 frame(4) = &H00 ' 寄存器数量高字节 frame(5) = &H0A ' 寄存器数量低字节 frame(6) = &HC5 ' CRC 低字节 frame(7) = &HCD ' CRC 高字节 sp.WriteData frame ``` ### 接收并解析二进制帧 ```vb Private Sub m_Port_DataReceived(ByVal BytesCount As Long) Dim buf() As Byte Dim n As Long n = m_Port.ReadData(buf) If n < 5 Then Exit Sub ' Modbus 响应至少5字节 ' 解析 Modbus 响应 Dim slaveAddr As Byte Dim funcCode As Byte slaveAddr = buf(0) funcCode = buf(1) If funcCode And &H80 Then ' 异常响应 Dim errCode As Byte errCode = buf(2) Debug.Print "Modbus 异常: " & errCode Else ' 正常响应 Dim byteCount As Byte byteCount = buf(2) Debug.Print "收到 " & byteCount & " 字节数据" End If End Sub ``` ### 十六进制显示调试 ```vb Private Sub m_Port_DataReceived(ByVal BytesCount As Long) Dim buf() As Byte m_Port.ReadData buf Dim hexStr As String Dim i As Long For i = 0 To UBound(buf) hexStr = hexStr & Right$("0" & Hex$(buf(i)), 2) & " " Next Debug.Print "RX: " & Trim$(hexStr) End Sub ``` *** ## 虚拟串口与回环测试 ### 虚拟串口软件 在没有物理串口的开发环境中，可使用虚拟串口软件创建串口对： * **com0com**（免费开源） * **Virtual Serial Port Driver**（商业软件） * **VSPD**（商业软件） 安装后创建虚拟串口对（如 COM3 ↔ COM4），向 COM3 发送的数据会出现在 COM4 的接收缓冲区。 ### 回环测试代码 ```vb Public Sub TestLoopback() Dim spTx As New cSerialPort Dim spRx As New cSerialPort ' 打开虚拟串口对的两个端口 spTx.PortName = "COM3" spRx.PortName = "COM4" Dim cfg As New cSerialConfig cfg.BaudRate = br9600 Set spTx.Config = cfg Set spRx.Config = cfg.Clone() If Not spTx.OpenPort() Then Debug.Print "打开 COM3 失败" Exit Sub End If If Not spRx.OpenPort() Then Debug.Print "打开 COM4 失败" spTx.ClosePort Exit Sub End If ' 清空缓冲区 spTx.PurgeAll spRx.PurgeAll ' 发送 Dim testStr As String testStr = "LOOPBACK_TEST_12345" spTx.WriteText testStr Debug.Print "发送: " & testStr ' 等待数据到达 Dim t As Single t = Timer Do While spRx.InBufferCount < Len(testStr) And (Timer - t) < 2 DoEvents Loop ' 接收 Dim received As String received = spRx.ReadExisting() Debug.Print "接收: " & received If received = testStr Then Debug.Print "[PASS] 回环测试成功" Else Debug.Print "[FAIL] 回环测试失败" End If spTx.ClosePort spRx.ClosePort End Sub ``` *** ## 动态配置管理 ### 运行时修改配置 ```vb sp.OpenPort "COM3" ' 修改波特率 sp.Config.BaudRate = br115200 sp.ApplyConfig ' 手动应用到已打开端口 ' 从端口读取实际配置 sp.RefreshConfig Debug.Print "实际波特率: " & sp.Config.BaudRate ``` ### 配置克隆 ```vb Dim cfg1 As New cSerialConfig cfg1.BaudRate = br115200 cfg1.Parity = ptEven ' 克隆配置（互不影响） Dim cfg2 As cSerialConfig Set cfg2 = cfg1.Clone() cfg2.BaudRate = br9600 Debug.Print cfg1.BaudRate ' 仍为 115200 ``` ### 模式字符串 ```vb Dim cfg As New cSerialConfig cfg.FromModeString "baud=115200 parity=N data=8 stop=1" Debug.Print cfg.ToModeString() ' baud=115200 parity=N data=8 stop=1 ``` *** ## Modbus RTU 实践 ### 完整的 Modbus RTU 主站请求 ```vb Public Function ModbusReadHoldingRegisters( _ ByVal sp As cSerialPort, _ ByVal SlaveAddr As Byte, _ ByVal StartAddr As Integer, _ ByVal Quantity As Integer) As Byte() ' 构建请求帧 Dim frame(7) As Byte frame(0) = SlaveAddr frame(1) = &H03 ' 功能码：读保持寄存器 frame(2) = (StartAddr And &HFF00) \ &H100 frame(3) = StartAddr And &HFF frame(4) = (Quantity And &HFF00) \ &H100 frame(5) = Quantity And &HFF ' 计算 CRC16 Dim crc As Long crc = CalcCRC16(frame, 6) frame(6) = crc And &HFF frame(7) = (crc And &HFF00) \ &H100 ' 清空缓冲区并发送 sp.PurgeAll sp.WriteData frame ' 等待响应（超时1秒） Dim t As Single t = Timer Do While sp.InBufferCount < 5 And (Timer - t) < 1 DoEvents Loop ' 读取响应 Dim buf() As Byte Dim n As Long n = sp.ReadData(buf) If n >= 5 Then ModbusReadHoldingRegisters = buf End If End Function ``` ### 使用示例 ```vb Dim sp As New cSerialPort sp.PortName = "COM3" sp.Config.BaudRate = br9600 sp.Config.DataBits = 8 sp.Config.Parity = ptEven ' Modbus RTU 通常使用偶校验 sp.Config.StopBits = sb1 sp.OpenPort ' 读取从站1的保持寄存器，起始地址0，数量10 Dim response() As Byte response = ModbusReadHoldingRegisters(sp, 1, 0, 10) If UBound(response) >= 0 Then ' 解析响应数据 Dim byteCount As Byte byteCount = response(2) Debug.Print "收到 " & byteCount & " 字节数据" End If sp.ClosePort ``` *** **最后更新**: 2026-07-05 --- --- url: /zh/vbman/serialport/quickstart.md --- # cSerialPort 快速入门 ## 📖 目录 * [引用方式](#引用方式) * [最简示例](#最简示例) * [常见场景](#常见场景) *** ## 引用方式 ### 方式一：源码引用 将 `src/SerialPort` 下三个文件加入 VB6 工程： ``` modSerialPortAPI.bas # API 声明、常量、类型、辅助函数 cSerialConfig.cls # 配置类（含 eBaudRate/eParity/eStopBits 等枚举） cSerialPort.cls # 串口主类（含 eCommEvent/eCommError/eModemStatus 枚举） ``` ### 方式二：DLL 引用 引用 `dist\DLL\VBMAN.dll`，使用时带命名空间前缀： ```vb Dim sp As New VBMANLIB.cSerialPort ``` *** ## 最简示例 打开 COM3，发送文本并读取响应： ```vb Dim sp As New cSerialPort sp.PortName = "COM3" sp.Config.BaudRate = br9600 If sp.OpenPort() Then sp.WriteText "Hello" Debug.Print sp.ReadExisting() sp.ClosePort End If ``` *** ## 常见场景 ### 1. 事件驱动持续收发 使用 `WithEvents` 声明对象，通过事件自动接收数据： ```vb Private WithEvents m_Port As cSerialPort Private Sub Form_Load() Set m_Port = New cSerialPort m_Port.PortName = "COM4" m_Port.Config.BaudRate = 9600 m_Port.Config.DataBits = 8 m_Port.Config.Parity = 0 ' ptNone m_Port.Config.StopBits = 0 ' sb1 If Not m_Port.OpenPort() Then Debug.Print "打开失败: " & m_Port.LastErrorMsg Exit Sub End If m_Port.StartMonitoring 50 ' 50ms 轮询 Debug.Print "已启动，等待数据..." End Sub Private Sub m_Port_DataReceived(ByVal BytesCount As Long) Debug.Print "收到: " & m_Port.ReadExisting() End Sub Private Sub m_Port_ErrorOccurred(ByVal ErrorCode As Long, ByVal ErrorMsg As String) Debug.Print "错误: " & ErrorMsg End Sub Private Sub Form_Unload(Cancel As Integer) If Not m_Port Is Nothing Then If m_Port.IsOpen Then m_Port.ClosePort Set m_Port = Nothing End If End Sub ``` ### 2. 请求-响应模式（带超时） 发送命令后等待响应，超时自动退出： ```vb Dim sp As New cSerialPort sp.PortName = "COM3" sp.Config.BaudRate = br9600 sp.Config.SetReadTimeout 2000 ' 读取超时2秒 sp.OpenPort sp.WriteText "hello" Dim received As String Dim startTime As Single startTime = Timer Do DoEvents If sp.InBufferCount > 0 Then received = received & sp.ReadExisting() If InStr(received, "world") > 0 Then Exit Do End If Loop While Timer - startTime < 10 ' 最多等10秒 If InStr(received, "world") > 0 Then Debug.Print "收到响应: " & received Else Debug.Print "超时未收到响应" End If sp.ClosePort ``` ### 3. 二进制协议收发 发送和接收字节数组，适用于 Modbus 等二进制协议： ```vb Dim sp As New cSerialPort sp.PortName = "COM3" sp.Config.BaudRate = br115200 sp.OpenPort ' 发送 Modbus 请求帧 Dim frame(7) As Byte frame(0) = &H01 ' 设备地址 frame(1) = &H03 ' 功能码 frame(2) = &H00: frame(3) = &H00 ' 起始地址 frame(4) = &H00: frame(5) = &H0A ' 寄存器数量 frame(6) = &HC5: frame(7) = &HCD ' CRC sp.WriteData frame ' 等待并读取响应 Dim startTime As Single startTime = Timer Do While sp.InBufferCount < 5 And Timer - startTime < 2 DoEvents Loop Dim buf() As Byte Dim n As Long n = sp.ReadData(buf) ' 读取所有可用数据 Debug.Print "收到 " & n & " 字节" sp.ClosePort ``` ### 4. 读取一行文本 按换行符分割，读取完整的一行： ```vb Dim sp As New cSerialPort sp.PortName = "COM3" sp.Config.BaudRate = br9600 sp.Config.SetReadTimeout 5000 ' 5秒超时 sp.OpenPort Dim line As String line = sp.ReadLine() ' 读取到 vbCrLf 为止 Debug.Print "收到一行: " & line sp.ClosePort ``` ### 5. 枚举可用串口 扫描系统中所有可用的串口： ```vb Dim ports As Collection Set ports = EnumSerialPorts() Dim p As Variant For Each p In ports Debug.Print p ' COM1, COM3, ... Next Debug.Print "共 " & ports.Count & " 个可用串口" ``` *** **最后更新**: 2026-07-05 --- --- url: /zh/vbman/serialport/events.md --- # cSerialPort 事件详解 ## 📋 事件列表 | 事件名 | 说明 | 触发条件 | |--------|------|----------| | `DataReceived` | 数据接收 | 输入缓冲区有新数据（需 `StartMonitoring`） | | `FrameReceived` | 帧接收 | 启用分帧（`FrameInterval>0`）后，每收到一个完整帧触发 | | `ErrorOccurred` | 通信错误 | 检测到线路错误 | | `PinChanged` | 信号线变化 | CTS/DSR/RING/RLSD 任一变化 | | `TxEmpty` | 发送缓冲区已空 | 发送完成 | | `BreakDetected` | 检测到 Break | 收到 Break 信号 | | `RingDetected` | 检测到振铃 | 收到振铃信号 | *** ## 📥 DataReceived 事件 ### 说明 当输入缓冲区有新数据时触发。需要先调用 `StartMonitoring` 启动监控。 ### 语法 ```vb Private Sub object_DataReceived(ByVal BytesCount As Long) ``` ### 参数 | 参数 | 类型 | 说明 | |------|------|------| | `BytesCount` | Long | 输入缓冲区中的字节数 | ### 使用示例 ```vb Private WithEvents m_Port As cSerialPort Private Sub m_Port_DataReceived(ByVal BytesCount As Long) Dim s As String s = m_Port.ReadExisting() Debug.Print "收到 " & BytesCount & " 字节: " & s End Sub ``` ### 注意事项 * 必须先调用 `StartMonitoring` 才能触发此事件 * 事件中应尽快读取数据，避免缓冲区溢出 * 事件中不要执行耗时操作，否则会影响后续数据接收 *** ## 🧩 FrameReceived 事件 ### 说明 当启用分帧模式（`FrameInterval > 0`）后，每收到一个完整帧触发。这是解决"设备连发导致粘包"问题的核心事件。 > 详细的分帧原理与方案选型，请参阅 [分帧协议专题](./framing.md)。 ### 语法 ```vb Private Sub object_FrameReceived(FrameData() As Byte) ``` ### 参数 | 参数 | 类型 | 说明 | |------|------|------| | `FrameData` | Byte 数组 | 这一帧的原始字节数据 | ### 启用方式 ```vb ' 启用分帧：30ms 无新数据 = 一帧结束 m_Port.FrameInterval = 30 m_Port.StartMonitoring 20 ' 轮询间隔建议 <= FrameInterval/2 ``` ### 使用示例 ```vb Private WithEvents m_Port As cSerialPort Private Sub Form_Load() Set m_Port = New cSerialPort m_Port.PortName = "COM3" m_Port.Config.BaudRate = br9600 If m_Port.OpenPort() Then m_Port.FrameInterval = 30 m_Port.StartMonitoring 20 End If End Sub Private Sub m_Port_FrameReceived(FrameData() As Byte) Dim s As String s = StrConv(FrameData, vbUnicode) Debug.Print "收到帧 (" & UBound(FrameData) + 1 & "字节): " & s End Sub ``` ### 注意事项 * 必须设置 `FrameInterval > 0` 才会触发；为 0 时仍走 `DataReceived` 路径 * `FrameInterval=0` 时 `DataReceived` 正常触发，两者互斥 * `StopMonitoring` / `ClosePort` 时会自动 flush 缓冲区中剩余的帧，不会丢失最后一帧 * 搭配 `cSerialFrameParser` 可实现"协议分帧"（按分隔符/起止标记/长度字段精确切分） *** ## ⚠️ ErrorOccurred 事件 ### 说明 检测到通信错误时触发。 ### 语法 ```vb Private Sub object_ErrorOccurred(ByVal ErrorCode As Long, ByVal ErrorMsg As String) ``` ### 参数 | 参数 | 类型 | 说明 | |------|------|------| | `ErrorCode` | Long | 通信错误码（CE\_ 常量组合） | | `ErrorMsg` | String | 中文错误描述 | ### 错误码 | 常量 | 值 | 说明 | |------|-----|------| | `CE_RXOVER` | \&H1 | 接收缓冲区溢出 | | `CE_OVERRUN` | \&H2 | 字符覆盖 | | `CE_RXPARITY` | \&H4 | 校验错误 | | `CE_FRAME` | \&H8 | 帧错误 | | `CE_BREAK` | \&H10 | 中断检测 | | `CE_TXFULL` | \&H100 | 发送缓冲区满 | ### 使用示例 ```vb Private Sub m_Port_ErrorOccurred(ByVal ErrorCode As Long, ByVal ErrorMsg As String) Debug.Print "通信错误 [" & ErrorCode & "]: " & ErrorMsg Select Case ErrorCode Case CE_RXOVER ' 接收缓冲区溢出，清空缓冲区 m_Port.PurgeRx Case CE_RXPARITY ' 校验错误，记录日志 LogError "校验错误" Case CE_FRAME ' 帧错误，检查波特率配置 LogError "帧错误，请检查波特率" End Select End Sub ``` *** ## 📊 PinChanged 事件 ### 说明 CTS/DSR/RING/RLSD 任一信号线变化时触发。 ### 语法 ```vb Private Sub object_PinChanged(ByVal Events As Long) ``` ### 参数 | 参数 | 类型 | 说明 | |------|------|------| | `Events` | Long | 事件掩码（EV\_CTS/EV\_DSR/EV\_RLSD/EV\_RING 组合） | ### 使用示例 ```vb Private Sub m_Port_PinChanged(ByVal Events As Long) If (Events And EV_CTS) Then Debug.Print "CTS 变化: " & m_Port.CtsHolding End If If (Events And EV_DSR) Then Debug.Print "DSR 变化: " & m_Port.DsrHolding End If If (Events And EV_RLSD) Then Debug.Print "CD 变化: " & m_Port.CdHolding End If End Sub ``` > **注意**：`PinChanged` 事件仅在 `WaitForEvent` 同步模式中触发。异步监控模式（`StartMonitoring`）目前不监控信号线变化。 *** ## 📤 TxEmpty 事件 ### 说明 发送缓冲区已空时触发。 ```vb Private Sub m_Port_TxEmpty() Debug.Print "发送完成" End Sub ``` > 仅在 `WaitForEvent` 同步模式中触发。 *** ## ⚡ BreakDetected 事件 ### 说明 检测到 Break 信号时触发。 ```vb Private Sub m_Port_BreakDetected() Debug.Print "收到 Break 信号" End Sub ``` > 仅在 `WaitForEvent` 同步模式中触发。 *** ## 🔔 RingDetected 事件 ### 说明 检测到振铃信号时触发。 ```vb Private Sub m_Port_RingDetected() Debug.Print "检测到振铃" End Sub ``` > 仅在 `WaitForEvent` 同步模式中触发。 *** ## 事件触发模式对比 ### 异步监控模式（StartMonitoring） | 事件 | 是否触发 | 说明 | |------|----------|------| | `DataReceived` | ✅ | 轮询检测到缓冲区有数据 | | `ErrorOccurred` | ✅ | 轮询检测到通信错误 | | `PinChanged` | ❌ | 不监控信号线变化 | | `TxEmpty` | ❌ | 不监控发送完成 | | `BreakDetected` | ❌ | 不监控 Break | | `RingDetected` | ❌ | 不监控振铃 | ### 同步等待模式（WaitForEvent） | 事件 | 是否触发 | 说明 | |------|----------|------| | `DataReceived` | ✅ | 收到 EV\_RXCHAR 事件 | | `ErrorOccurred` | ✅ | 收到 EV\_ERR 事件 | | `PinChanged` | ✅ | 收到 EV\_CTS/EV\_DSR/EV\_RLSD 事件 | | `TxEmpty` | ✅ | 收到 EV\_TXEMPTY 事件 | | `BreakDetected` | ✅ | 收到 EV\_BREAK 事件 | | `RingDetected` | ✅ | 收到 EV\_RING 事件 | > **⚠️**：`WaitForEvent` 会阻塞调用线程，不建议在 UI 线程使用。 *** **最后更新**: 2026-07-05 --- --- url: /zh/vbman/serialport/properties.md --- # cSerialPort 属性详解 ## 📋 属性列表 ### cSerialPort 属性 | 属性名 | 类型 | 读写 | 说明 | |--------|------|------|------| | `IsOpen` | Boolean | 只读 | 串口是否已打开 | | `PortName` | String | 读写 | 端口名，打开后不可修改 | | `Handle` | Long | 只读 | 串口句柄 | | `Config` | cSerialConfig | 读写 | 配置对象 | | `LastError` | Long | 只读 | 最后的错误码 | | `LastErrorMsg` | String | 只读 | 最后的错误描述 | | `ReceivedCount` | Long | 只读 | 累计接收字节数 | | `SentCount` | Long | 只读 | 累计发送字节数 | | `InBufferCount` | Long | 只读 | 输入缓冲区当前字节数 | | `OutBufferCount` | Long | 只读 | 输出缓冲区当前字节数 | | `CtsHolding` | Boolean | 只读 | CTS 信号状态 | | `DsrHolding` | Boolean | 只读 | DSR 信号状态 | | `RingHolding` | Boolean | 只读 | RING 信号状态 | | `CdHolding` | Boolean | 只读 | CD/RLSD 信号状态 | | `IsWaitingOnCts` | Boolean | 只读 | 是否等待 CTS | | `IsWaitingOnDsr` | Boolean | 只读 | 是否等待 DSR | | `IsWaitingOnRlsd` | Boolean | 只读 | 是否等待 RLSD | | `IsXoffHold` | Boolean | 只读 | 是否被 XOFF 暂停 | | `IsXoffSent` | Boolean | 只读 | 是否已发送 XOFF | | `Monitoring` | Boolean | 只读 | 是否正在监控 | | `PollInterval` | Long | 读写 | 轮询间隔(ms)，10~60000 | ### cSerialConfig 属性 | 属性名 | 类型 | 默认值 | 说明 | |--------|------|--------|------| | `BaudRate` | Long | 9600 | 波特率 | | `DataBits` | Long | 8 | 数据位，4~8 | | `StopBits` | Long | 0 | 停止位 | | `Parity` | Long | 0 | 校验位 | | `FlowControl` | Long | 0 | 流控制 | | `DtrControl` | Long | 1 | DTR 控制模式 | | `RtsControl` | Long | 1 | RTS 控制模式 | | `ReadIntervalTimeout` | Long | 50 | 读取间隔超时(ms) | | `ReadTotalTimeoutMultiplier` | Long | 0 | 读取每字节超时系数 | | `ReadTotalTimeoutConstant` | Long | 100 | 读取固定超时(ms) | | `WriteTotalTimeoutMultiplier` | Long | 0 | 写入每字节超时系数 | | `WriteTotalTimeoutConstant` | Long | 100 | 写入固定超时(ms) | | `InBufferSize` | Long | 4096 | 输入缓冲区大小(字节) | | `OutBufferSize` | Long | 4096 | 输出缓冲区大小(字节) | | `XonChar` | Byte | \&H11 | XON 字符 | | `XoffChar` | Byte | \&H13 | XOFF 字符 | | `ErrorChar` | Byte | 0 | 校验错误替换字符 | | `EofChar` | Byte | 0 | EOF 字符 | | `EvtChar` | Byte | 0 | 事件触发字符 | | `NullDiscard` | Boolean | False | 是否丢弃 NULL 字节 | | `AbortOnError` | Boolean | False | 错误时是否终止读写 | | `TXContinueOnXoff` | Boolean | False | XOFF 后是否继续发送 | | `ParityReplace` | Boolean | True | 校验错误时是否替换字符 | *** ## 🔧 cSerialPort 属性详解 ### IsOpen 串口是否已打开。 ```vb If sp.IsOpen Then Debug.Print "串口已打开" End If ``` ### PortName 端口名。打开后不可修改，需先关闭再修改。 ```vb sp.PortName = "COM3" sp.OpenPort ' sp.PortName = "COM4" ' 错误！打开后不能改 sp.ClosePort sp.PortName = "COM4" ' 关闭后可以改 ``` ### Config 配置对象，类型为 `cSerialConfig`。打开状态下修改会需要调用 `ApplyConfig` 生效。 ```vb ' 读取配置 Debug.Print sp.Config.BaudRate ' 修改配置 sp.Config.BaudRate = br115200 If sp.IsOpen Then sp.ApplyConfig ' 已打开需手动应用 ' 替换整个配置对象 Dim cfg As New cSerialConfig cfg.BaudRate = br9600 Set sp.Config = cfg ' 会自动应用 ``` ### LastError / LastErrorMsg 最后的 Win32 错误码和描述。`OpenPort` 失败时返回 `False` 并设置 `LastError`。 ```vb If Not sp.OpenPort("COM99") Then Debug.Print "错误码: " & sp.LastError Debug.Print "错误描述: " & sp.LastErrorMsg End If ``` ### ReceivedCount / SentCount 累计收发字节数。可通过 `ResetCounters` 重置。 ```vb Debug.Print "已接收: " & sp.ReceivedCount & " 字节" Debug.Print "已发送: " & sp.SentCount & " 字节" sp.ResetCounters ``` ### InBufferCount / OutBufferCount 输入/输出缓冲区当前字节数。 ```vb If sp.InBufferCount > 0 Then Debug.Print "缓冲区有 " & sp.InBufferCount & " 字节可读" End If ``` ### 信号线状态属性 | 属性 | 信号 | 说明 | |------|------|------| | `CtsHolding` | CTS | 清除发送（Clear To Send） | | `DsrHolding` | DSR | 数据设备就绪（Data Set Ready） | | `RingHolding` | RING | 振铃指示 | | `CdHolding` | CD/RLSD | 载波检测（Carrier Detect） | ```vb Debug.Print "CTS=" & sp.CtsHolding & " DSR=" & sp.DsrHolding Debug.Print "RING=" & sp.RingHolding & " CD=" & sp.CdHolding ``` ### PollInterval 监控轮询间隔，单位毫秒，范围 10~60000。可在 `StartMonitoring` 时指定，也可通过属性修改。 ```vb sp.PollInterval = 100 ' 100ms 轮询 ``` *** ## ⚙️ cSerialConfig 属性详解 ### BaudRate 波特率，使用 `eBaudRate` 枚举常量。最高支持 **256000**，远超 MSComm 控件的 115200 限制。 | 常量 | 值 | 说明 | |------|----|------| | `br110` | 110 | | | `br300` | 300 | | | `br600` | 600 | | | `br1200` | 1200 | | | `br2400` | 2400 | | | `br4800` | 4800 | | | `br9600` | 9600 | 默认值 | | `br14400` | 14400 | | | `br19200` | 19200 | | | `br38400` | 38400 | | | `br56000` | 56000 | | | `br57600` | 57600 | | | `br115200` | 115200 | 常用高速 | | `br128000` | 128000 | | | `br256000` | 256000 | **最高支持** | ```vb cfg.BaudRate = br9600 ' 或 br115200, br57600, br256000 等 ``` ### DataBits 数据位，范围 4~8，超出范围会抛出错误。 ```vb cfg.DataBits = 8 ``` ### StopBits 停止位，使用 `eStopBits` 枚举：`sb1`(0)、`sb1_5`(1)、`sb2`(2)。 ### Parity 校验位，使用 `eParity` 枚举：`ptNone`(0)、`ptOdd`(1)、`ptEven`(2)、`ptMark`(3)、`ptSpace`(4)。 ### FlowControl 流控制，使用 `eFlowControl` 枚举。设置后会自动同步 DTR/RTS 控制模式。 ```vb cfg.FlowControl = fcRtsCts ' 硬件流控制 RTS/CTS ``` ### DtrControl / RtsControl DTR/RTS 控制模式。使用 `eDtrControl`/`eRtsControl` 枚举：`dcDisable`(0)、`dcEnable`(1)、`dcHandshake`(2)、`rcToggle`(3,仅RTS)。 ### 超时参数 | 参数 | 说明 | |------|------| | `ReadIntervalTimeout` | 两次读取间的最大间隔，超时返回 | | `ReadTotalTimeoutMultiplier` | 每字节超时系数 | | `ReadTotalTimeoutConstant` | 读取固定超时 | | `WriteTotalTimeoutMultiplier` | 写入每字节超时系数 | | `WriteTotalTimeoutConstant` | 写入固定超时 | > 总超时 = Multiplier × 字节数 + Constant。详见 [高级进阶 - 超时策略](./advanced.md) ### InBufferSize / OutBufferSize 缓冲区大小，必须大于 0。 ### XonChar / XoffChar XON/XOFF 流控制字符，默认 \&H11(DC1) 和 \&H13(DC3)。 *** ## 📚 枚举参考 所有枚举定义在类模块中（而非标准模块），因此编译为 DLL 后会随类型库导出，外部工程可直接使用。详见 [概述 - 架构设计](./overview.md)。 ### eBaudRate（cSerialConfig） 波特率常量。最高值：**256000**。完整列表见 [BaudRate](#baudrate)。 ### eParity（cSerialConfig） | 常量 | 值 | Win32 常量 | 说明 | |------|----|-----------|------| | `ptNone` | 0 | NOPARITY | 无校验 | | `ptOdd` | 1 | ODDPARITY | 奇校验 | | `ptEven` | 2 | EVENPARITY | 偶校验 | | `ptMark` | 3 | MARKPARITY | 标记校验 | | `ptSpace` | 4 | SPACEPARITY | 空格校验 | ### eStopBits（cSerialConfig） | 常量 | 值 | Win32 常量 | 说明 | |------|----|-----------|------| | `sb1` | 0 | ONESTOPBIT | 1 个停止位 | | `sb1_5` | 1 | ONE5STOPBITS | 1.5 个停止位 | | `sb2` | 2 | TWOSTOPBITS | 2 个停止位 | ### eDtrControl（cSerialConfig） | 常量 | 值 | Win32 常量 | 说明 | |------|----|-----------|------| | `dcDisable` | 0 | DTR\_CONTROL\_DISABLE | DTR 禁用 | | `dcEnable` | 1 | DTR\_CONTROL\_ENABLE | DTR 启用 | | `dcHandshake` | 2 | DTR\_CONTROL\_HANDSHAKE | DTR 流控制握手 | ### eRtsControl（cSerialConfig） | 常量 | 值 | Win32 常量 | 说明 | |------|----|-----------|------| | `rcDisable` | 0 | RTS\_CONTROL\_DISABLE | RTS 禁用 | | `rcEnable` | 1 | RTS\_CONTROL\_ENABLE | RTS 启用 | | `rcHandshake` | 2 | RTS\_CONTROL\_HANDSHAKE | RTS 流控制握手 | | `rcToggle` | 3 | RTS\_CONTROL\_TOGGLE | RTS 切换模式 | ### eFlowControl（cSerialConfig） | 常量 | 值 | 说明 | |------|----|------| | `fcNone` | 0 | 无流控制 | | `fcXonXoff` | 1 | 软件流控制（XON/XOFF） | | `fcRtsCts` | 2 | 硬件流控制（RTS/CTS） | | `fcDtrDsr` | 3 | 硬件流控制（DTR/DSR） | | `fcRtsCtsAndXonXoff` | 4 | 混合流控制（RTS/CTS + XON/XOFF） | ### eCommEvent（cSerialPort） 通信事件，用于 `SetCommMask` / `WaitForEvent` / `PinChanged`。 | 常量 | 值 | 说明 | |------|----|------| | `EV_RXCHAR` | \&H1 | 字符已接收 | | `EV_RXFLAG` | \&H2 | 事件字符已接收 | | `EV_TXEMPTY` | \&H4 | 发送缓冲区已空 | | `EV_CTS` | \&H8 | CTS 信号变化 | | `EV_DSR` | \&H10 | DSR 信号变化 | | `EV_RLSD` | \&H20 | RLSD(CD) 信号变化 | | `EV_BREAK` | \&H40 | 检测到中断 | | `EV_ERR` | \&H80 | 线路状态错误 | | `EV_RING` | \&H100 | 振铃检测 | | `EV_PERR` | \&H200 | 打印机错误 | | `EV_RX80FULL` | \&H400 | 接收缓冲区 80% 满 | | `EV_EVENT1` | \&H800 | 设备事件 1 | | `EV_EVENT2` | \&H1000 | 设备事件 2 | ### eCommError（cSerialPort） 通信错误，来自 `ClearCommError` / `ErrorOccurred` / `ReadCommErrors`。 | 常量 | 值 | 说明 | |------|----|------| | `CE_RXOVER` | \&H1 | 接收缓冲区溢出 | | `CE_OVERRUN` | \&H2 | 字符覆盖（缓冲区满） | | `CE_RXPARITY` | \&H4 | 校验错误 | | `CE_FRAME` | \&H8 | 帧错误 | | `CE_BREAK` | \&H10 | 中断检测 | | `CE_TXFULL` | \&H100 | 发送缓冲区满 | | `CE_PTO` | \&H200 | 并口超时 | | `CE_IOE` | \&H400 | I/O 错误 | | `CE_DNS` | \&H800 | 设备未选择 | | `CE_OOP` | \&H1000 | 缺纸 | | `CE_MODE` | \&H8000 | 模式错误 | ### eModemStatus（cSerialPort） Modem 状态，来自 `GetCommModemStatus` / `ReadModemStatus`。 | 常量 | 值 | 说明 | |------|----|------| | `MS_CTS_ON` | \&H10 | CTS（清除发送） | | `MS_DSR_ON` | \&H20 | DSR（数据设备就绪） | | `MS_RING_ON` | \&H40 | RING（振铃指示） | | `MS_RLSD_ON` | \&H80 | RLSD/CD（载波检测） | *** **最后更新**: 2026-07-05 --- --- url: /en/vbman/serialport/advanced.md --- # cSerialPort Advanced ## 📖 Table of Contents * [Flow Control Details](#flow-control-details) * [Timeout Strategy Details](#timeout-strategy-details) * [Binary Protocol Handling](#binary-protocol-handling) * [Virtual Serial Ports & Loopback Testing](#virtual-serial-ports--loopback-testing) * [Dynamic Configuration Management](#dynamic-configuration-management) * [Modbus RTU Practice](#modbus-rtu-practice) *** ## Flow Control Details Flow control coordinates the sender and receiver rates to prevent data loss. `cSerialConfig` supports five flow control modes. ### Flow Control Types | Mode | Constant | Description | |------|----------|-------------| | No flow control | `fcNone` | No flow control | | Software flow control | `fcXonXoff` | Controlled via XON/XOFF characters | | Hardware flow control RTS/CTS | `fcRtsCts` | Controlled via RTS/CTS signal lines | | Hardware flow control DTR/DSR | `fcDtrDsr` | Controlled via DTR/DSR signal lines | | Mixed flow control | `fcRtsCtsAndXonXoff` | Both hardware and software flow control | ### Software Flow Control (XON/XOFF) The sender receives XOFF(\&H13) to pause sending when data volume is excessive, and XON(\&H11) to resume sending. ```vb cfg.FlowControl = fcXonXoff ' Can customize XON/XOFF characters cfg.XonChar = &H11 cfg.XoffChar = &H13 ``` You can also manually send XON/XOFF: ```vb sp.SendXOff ' Request peer to pause sending sp.SendXOn ' Request peer to resume sending ``` ### Hardware Flow Control (RTS/CTS) Uses RTS/CTS signal lines for hardware handshake. Sender transmits data only when CTS is high. ```vb cfg.FlowControl = fcRtsCts ' Setting FlowControl automatically sets RtsControl to rcHandshake ``` > **Note**: After enabling hardware flow control, manual `SetRTS`/`SetDTR` may be overridden by flow control mechanisms. ### DTR/RTS Control Modes | Mode | Constant | DTR/RTS Behavior | |------|----------|-------------------| | Disable | `dcDisable`/`rcDisable` | Signal line stays low | | Enable | `dcEnable`/`rcEnable` | Signal line stays high | | Handshake | `dcHandshake`/`rcHandshake` | Automatically managed by flow control | | Toggle | `rcToggle` | RTS only, pulls high when data present | *** ## Timeout Strategy Details Win32 serial port timeout is controlled by five parameters. Understanding their working mechanism is crucial. ### Timeout Parameters | Parameter | Description | |-----------|-------------| | `ReadIntervalTimeout` | Maximum interval between two read characters(ms) | | `ReadTotalTimeoutMultiplier` | Per-byte timeout multiplier(ms/byte) | | `ReadTotalTimeoutConstant` | Read fixed timeout(ms) | | `WriteTotalTimeoutMultiplier` | Write per-byte timeout multiplier | | `WriteTotalTimeoutConstant` | Write fixed timeout(ms) | ### Read Timeout Calculation ``` Total timeout = ReadTotalTimeoutMultiplier × requested data amount + ReadTotalTimeoutConstant ``` ### Three Preset Modes #### 1. Non-Blocking Read `Read` returns immediately, reads data if available, returns empty if not. ```vb cfg.SetNonBlockingRead ' Equivalent to: ' ReadIntervalTimeout = MAXDWORD (&HFFFFFFFF) ' ReadTotalTimeoutMultiplier = 0 ' ReadTotalTimeoutConstant = 0 ``` #### 2. Blocking Read Wait until specified byte count is read, may block permanently. ```vb cfg.SetBlockingRead ' Equivalent to: ' ReadIntervalTimeout = 0 ' ReadTotalTimeoutMultiplier = 0 ' ReadTotalTimeoutConstant = 0 ``` > **⚠️ Warning**: Blocking mode will hang permanently if no data arrives. Recommend using with `ReadTotalTimeoutConstant`. #### 3. Read With Timeout Specify total timeout duration. ```vb cfg.SetReadTimeout 2000 ' 2 second timeout ' Equivalent to: ' ReadIntervalTimeout = 50 ' ReadTotalTimeoutMultiplier = 0 ' ReadTotalTimeoutConstant = 2000 ``` ### Custom Timeout Example Calculate timeout by byte count, suitable for scenarios with known data length: ```vb ' Per byte 10ms + fixed 100ms cfg.ReadIntervalTimeout = 50 cfg.ReadTotalTimeoutMultiplier = 10 cfg.ReadTotalTimeoutConstant = 100 ' Reading 100 bytes total timeout = 10×100 + 100 = 1100ms ``` *** ## Binary Protocol Handling ### Send Binary Frame ```vb ' Build Modbus RTU request frame Dim frame(7) As Byte frame(0) = &H01 ' Slave address frame(1) = &H03 ' Function code: read holding registers frame(2) = &H00 ' Start address high byte frame(3) = &H00 ' Start address low byte frame(4) = &H00 ' Register count high byte frame(5) = &H0A ' Register count low byte frame(6) = &HC5 ' CRC low byte frame(7) = &HCD ' CRC high byte sp.WriteData frame ``` ### Receive and Parse Binary Frame ```vb Private Sub m_Port_DataReceived(ByVal BytesCount As Long) Dim buf() As Byte Dim n As Long n = m_Port.ReadData(buf) If n < 5 Then Exit Sub ' Modbus response at least 5 bytes ' Parse Modbus response Dim slaveAddr As Byte Dim funcCode As Byte slaveAddr = buf(0) funcCode = buf(1) If funcCode And &H80 Then ' Exception response Dim errCode As Byte errCode = buf(2) Debug.Print "Modbus exception: " & errCode Else ' Normal response Dim byteCount As Byte byteCount = buf(2) Debug.Print "Received " & byteCount & " bytes of data" End If End Sub ``` ### Hex Display Debugging ```vb Private Sub m_Port_DataReceived(ByVal BytesCount As Long) Dim buf() As Byte m_Port.ReadData buf Dim hexStr As String Dim i As Long For i = 0 To UBound(buf) hexStr = hexStr & Right$("0" & Hex$(buf(i)), 2) & " " Next Debug.Print "RX: " & Trim$(hexStr) End Sub ``` *** ## Virtual Serial Ports & Loopback Testing ### Virtual Serial Port Software In development environments without physical serial ports, virtual serial port software can create port pairs: * **com0com** (Free, open source) * **Virtual Serial Port Driver** (Commercial software) * **VSPD** (Commercial software) After installation, create virtual serial port pairs (e.g., COM3 ↔ COM4). Data sent to COM3 will appear in COM4's receive buffer. ### Loopback Test Code ```vb Public Sub TestLoopback() Dim spTx As New cSerialPort Dim spRx As New cSerialPort ' Open both ports of the virtual pair spTx.PortName = "COM3" spRx.PortName = "COM4" Dim cfg As New cSerialConfig cfg.BaudRate = br9600 Set spTx.Config = cfg Set spRx.Config = cfg.Clone() If Not spTx.OpenPort() Then Debug.Print "Failed to open COM3" Exit Sub End If If Not spRx.OpenPort() Then Debug.Print "Failed to open COM4" spTx.ClosePort Exit Sub End If ' Clear buffers spTx.PurgeAll spRx.PurgeAll ' Send Dim testStr As String testStr = "LOOPBACK_TEST_12345" spTx.WriteText testStr Debug.Print "Sent: " & testStr ' Wait for data arrival Dim t As Single t = Timer Do While spRx.InBufferCount < Len(testStr) And (Timer - t) < 2 DoEvents Loop ' Receive Dim received As String received = spRx.ReadExisting() Debug.Print "Received: " & received If received = testStr Then Debug.Print "[PASS] Loopback test passed" Else Debug.Print "[FAIL] Loopback test failed" End If spTx.ClosePort spRx.ClosePort End Sub ``` *** ## Dynamic Configuration Management ### Runtime Configuration Changes ```vb sp.OpenPort "COM3" ' Change baud rate sp.Config.BaudRate = br115200 sp.ApplyConfig ' Manually apply to opened port ' Read actual configuration from port sp.RefreshConfig Debug.Print "Actual baud rate: " & sp.Config.BaudRate ``` ### Configuration Cloning ```vb Dim cfg1 As New cSerialConfig cfg1.BaudRate = br115200 cfg1.Parity = ptEven ' Clone configuration (independent) Dim cfg2 As cSerialConfig Set cfg2 = cfg1.Clone() cfg2.BaudRate = br9600 Debug.Print cfg1.BaudRate ' Still 115200 ``` ### Mode String ```vb Dim cfg As New cSerialConfig cfg.FromModeString "baud=115200 parity=N data=8 stop=1" Debug.Print cfg.ToModeString() ' baud=115200 parity=N data=8 stop=1 ``` *** ## Modbus RTU Practice ### Complete Modbus RTU Master Request ```vb Public Function ModbusReadHoldingRegisters( _ ByVal sp As cSerialPort, _ ByVal SlaveAddr As Byte, _ ByVal StartAddr As Integer, _ ByVal Quantity As Integer) As Byte() ' Build request frame Dim frame(7) As Byte frame(0) = SlaveAddr frame(1) = &H03 ' Function code: read holding registers frame(2) = (StartAddr And &HFF00) \ &H100 frame(3) = StartAddr And &HFF frame(4) = (Quantity And &HFF00) \ &H100 frame(5) = Quantity And &HFF ' Calculate CRC16 Dim crc As Long crc = CalcCRC16(frame, 6) frame(6) = crc And &HFF frame(7) = (crc And &HFF00) \ &H100 ' Clear buffers and send sp.PurgeAll sp.WriteData frame ' Wait for response (1 second timeout) Dim t As Single t = Timer Do While sp.InBufferCount < 5 And (Timer - t) < 1 DoEvents Loop ' Read response Dim buf() As Byte Dim n As Long n = sp.ReadData(buf) If n >= 5 Then ModbusReadHoldingRegisters = buf End If End Function ``` ### Usage Example ```vb Dim sp As New cSerialPort sp.PortName = "COM3" sp.Config.BaudRate = br9600 sp.Config.DataBits = 8 sp.Config.Parity = ptEven ' Modbus RTU typically uses even parity sp.Config.StopBits = sb1 sp.OpenPort ' Read holding registers from slave 1, start address 0, count 10 Dim response() As Byte response = ModbusReadHoldingRegisters(sp, 1, 0, 10) If UBound(response) >= 0 Then ' Parse response data Dim byteCount As Byte byteCount = response(2) Debug.Print "Received " & byteCount & " bytes of data" End If sp.ClosePort ``` *** **Last Updated**: 2026-07-05 --- --- url: /en/vbman/serialport/events.md --- # cSerialPort Events Reference ## 📋 Events List | Event | Description | Trigger Condition | |-------|-------------|-------------------| | `DataReceived` | Data received | New data in input buffer (requires `StartMonitoring`) | | `FrameReceived` | Frame received | Triggered for each complete frame when framing is enabled (`FrameInterval>0`) | | `ErrorOccurred` | Communication error | Line error detected | | `PinChanged` | Signal line change | Any CTS/DSR/RING/RLSD change | | `TxEmpty` | Transmit buffer empty | Transmission completed | | `BreakDetected` | Break detected | Break signal received | | `RingDetected` | Ring detected | Ring signal received | *** ## 📥 DataReceived Event ### Description Triggered when new data is in the input buffer. Requires `StartMonitoring` to be called first. ### Syntax ```vb Private Sub object_DataReceived(ByVal BytesCount As Long) ``` ### Parameters | Parameter | Type | Description | |-----------|------|-------------| | `BytesCount` | Long | Number of bytes in the input buffer | ### Usage Example ```vb Private WithEvents m_Port As cSerialPort Private Sub m_Port_DataReceived(ByVal BytesCount As Long) Dim s As String s = m_Port.ReadExisting() Debug.Print "Received " & BytesCount & " bytes: " & s End Sub ``` ### Notes * Must call `StartMonitoring` before this event can be triggered * Read data as quickly as possible in the event handler to avoid buffer overflow * Do not perform time-consuming operations in the event handler, as this may affect subsequent data reception *** ## 🧩 FrameReceived Event ### Description Triggered when framing mode is enabled (`FrameInterval > 0`) for each complete frame received. This is the core event for solving the "device continuous transmission causing packet concatenation" problem. > For detailed framing principles and solution selection, see [Framing Protocol Guide](./framing.md). ### Syntax ```vb Private Sub object_FrameReceived(FrameData() As Byte) ``` ### Parameters | Parameter | Type | Description | |-----------|------|-------------| | `FrameData` | Byte array | Raw byte data of this frame | ### Enabling ```vb ' Enable framing: 30ms no new data = one frame ends m_Port.FrameInterval = 30 m_Port.StartMonitoring 20 ' Polling interval recommended <= FrameInterval/2 ``` ### Usage Example ```vb Private WithEvents m_Port As cSerialPort Private Sub Form_Load() Set m_Port = New cSerialPort m_Port.PortName = "COM3" m_Port.Config.BaudRate = br9600 If m_Port.OpenPort() Then m_Port.FrameInterval = 30 m_Port.StartMonitoring 20 End If End Sub Private Sub m_Port_FrameReceived(FrameData() As Byte) Dim s As String s = StrConv(FrameData, vbUnicode) Debug.Print "Received frame (" & UBound(FrameData) + 1 & " bytes): " & s End Sub ``` ### Notes * Must set `FrameInterval > 0` to trigger; when set to 0, the `DataReceived` path is still used * When `FrameInterval=0`, `DataReceived` triggers normally; the two are mutually exclusive * `StopMonitoring` / `ClosePort` automatically flushes remaining frames in the buffer, so the last frame is not lost * Combined with `cSerialFrameParser`, "protocol framing" can be achieved (precise splitting by delimiter/start-end markers/length field) *** ## ⚠️ ErrorOccurred Event ### Description Triggered when a communication error is detected. ### Syntax ```vb Private Sub object_ErrorOccurred(ByVal ErrorCode As Long, ByVal ErrorMsg As String) ``` ### Parameters | Parameter | Type | Description | |-----------|------|-------------| | `ErrorCode` | Long | Communication error code (CE\_ constant combination) | | `ErrorMsg` | String | Error description | ### Error Codes | Constant | Value | Description | |----------|-------|-------------| | `CE_RXOVER` | \&H1 | Receive buffer overflow | | `CE_OVERRUN` | \&H2 | Character overrun | | `CE_RXPARITY` | \&H4 | Parity error | | `CE_FRAME` | \&H8 | Frame error | | `CE_BREAK` | \&H10 | Break detected | | `CE_TXFULL` | \&H100 | Transmit buffer full | ### Usage Example ```vb Private Sub m_Port_ErrorOccurred(ByVal ErrorCode As Long, ByVal ErrorMsg As String) Debug.Print "Communication error [" & ErrorCode & "]: " & ErrorMsg Select Case ErrorCode Case CE_RXOVER ' Receive buffer overflow, clear buffer m_Port.PurgeRx Case CE_RXPARITY ' Parity error, log LogError "Parity error" Case CE_FRAME ' Frame error, check baud rate configuration LogError "Frame error, check baud rate" End Select End Sub ``` *** ## 📊 PinChanged Event ### Description Triggered when any CTS/DSR/RING/RLSD signal line changes. ### Syntax ```vb Private Sub object_PinChanged(ByVal Events As Long) ``` ### Parameters | Parameter | Type | Description | |-----------|------|-------------| | `Events` | Long | Event mask (EV\_CTS/EV\_DSR/EV\_RLSD/EV\_RING combination) | ### Usage Example ```vb Private Sub m_Port_PinChanged(ByVal Events As Long) If (Events And EV_CTS) Then Debug.Print "CTS changed: " & m_Port.CtsHolding End If If (Events And EV_DSR) Then Debug.Print "DSR changed: " & m_Port.DsrHolding End If If (Events And EV_RLSD) Then Debug.Print "CD changed: " & m_Port.CdHolding End If End Sub ``` > **Note**: The `PinChanged` event only triggers in `WaitForEvent` synchronous mode. Asynchronous monitoring mode (`StartMonitoring`) does not currently monitor signal line changes. *** ## 📤 TxEmpty Event ### Description Triggered when the transmit buffer is empty. ```vb Private Sub m_Port_TxEmpty() Debug.Print "Transmission completed" End Sub ``` > Only triggers in `WaitForEvent` synchronous mode. *** ## ⚡ BreakDetected Event ### Description Triggered when a Break signal is detected. ```vb Private Sub m_Port_BreakDetected() Debug.Print "Break signal received" End Sub ``` > Only triggers in `WaitForEvent` synchronous mode. *** ## 🔔 RingDetected Event ### Description Triggered when a ring signal is detected. ```vb Private Sub m_Port_RingDetected() Debug.Print "Ring detected" End Sub ``` > Only triggers in `WaitForEvent` synchronous mode. *** ## Event Trigger Mode Comparison ### Asynchronous Monitoring Mode (StartMonitoring) | Event | Triggers | Description | |-------|----------|-------------| | `DataReceived` | ✅ | Polling detected data in buffer | | `ErrorOccurred` | ✅ | Polling detected communication error | | `PinChanged` | ❌ | Does not monitor signal line changes | | `TxEmpty` | ❌ | Does not monitor transmission completion | | `BreakDetected` | ❌ | Does not monitor Break | | `RingDetected` | ❌ | Does not monitor ring | ### Synchronous Wait Mode (WaitForEvent) | Event | Triggers | Description | |-------|----------|-------------| | `DataReceived` | ✅ | Received EV\_RXCHAR event | | `ErrorOccurred` | ✅ | Received EV\_ERR event | | `PinChanged` | ✅ | Received EV\_CTS/EV\_DSR/EV\_RLSD event | | `TxEmpty` | ✅ | Received EV\_TXEMPTY event | | `BreakDetected` | ✅ | Received EV\_BREAK event | | `RingDetected` | ✅ | Received EV\_RING event | > **⚠️**: `WaitForEvent` blocks the calling thread, not recommended for UI thread use. *** **Last Updated**: 2026-07-05 --- --- url: /en/vbman/serialport/faq.md --- # cSerialPort FAQ ## 📖 Table of Contents * [Port Issues](#port-issues) * [Data Send/Receive Issues](#data-sendreceive-issues) * [Configuration Issues](#configuration-issues) * [Event & Monitoring Issues](#event--monitoring-issues) * [Error Handling](#error-handling) *** ## Port Issues ### Q: Failed to open COM10 or higher port? **A:** `cSerialPort` internally handles the `\\.\COMx` prefix automatically. Just pass `"COM10"` directly. If it still fails, check: 1. Whether the port is occupied by another program 2. Whether the port actually exists (check with `EnumSerialPorts`) 3. Whether the driver is properly installed ```vb ' Check available ports Dim ports As Collection Set ports = EnumSerialPorts() Dim p As Variant For Each p In ports Debug.Print p Next ``` ### Q: OpenPort returns False, how to troubleshoot? **A:** Check `LastError` and `LastErrorMsg`: ```vb If Not sp.OpenPort("COM3") Then Debug.Print "Error code: " & sp.LastError Debug.Print "Error description: " & sp.LastErrorMsg End If ``` Common errors: * **Error code 5 (Access denied)**: Port occupied by another program * **Error code 2 (File not found)**: Port does not exist * **Error code 87 (Invalid parameter)**: Configuration parameters invalid ### Q: Can I change the port name after opening? **A:** No. `PortName` cannot be modified when `IsOpen=True`. Must `ClosePort` first then modify. *** ## Data Send/Receive Issues ### Q: Sent data but can't receive anything? **A:** Troubleshooting steps: 1. **Verify physical connection**: TX/RX must be cross-connected (one side's TX connects to the other side's RX) 2. **Verify configuration consistency**: Both sides must have matching baud rate, data bits, parity, stop bits 3. **Verify signal lines**: If using hardware flow control, CTS must be high to send 4. **Check flow control**: Try setting `fcNone` to exclude flow control interference ```vb ' Troubleshoot configuration Debug.Print sp.GetStatusString() ' Try no flow control sp.Config.FlowControl = fcNone sp.ApplyConfig ``` ### Q: ReadExisting returns empty string? **A:** Possible reasons: 1. Buffer truly has no data (`InBufferCount = 0`) 2. Read timeout setting too short 3. Data has not arrived yet (asynchronous transmission has delay) ```vb ' Check buffer first If sp.InBufferCount > 0 Then Debug.Print sp.ReadExisting() Else Debug.Print "Buffer is empty" End If ``` ### Q: ReadLine keeps blocking and doesn't return? **A:** `ReadLine` blocks until a terminator (default `vbCrLf`) is received or timeout. If the peer sends data without a newline, it will keep waiting. Solutions: 1. Set read timeout: `sp.Config.SetReadTimeout 5000` 2. Confirm whether peer sends `vbCrLf` (carriage return + line feed) 3. Use `ReadExisting` for non-blocking read instead ### Q: Received Chinese text is garbled? **A:** `ReadText`/`WriteText` uses `StrConv` to convert by ANSI/system codepage. If the peer uses UTF-8 encoding, use byte array mode and convert yourself: ```vb ' Receive UTF-8 byte array Dim buf() As Byte sp.ReadData buf ' Manually convert to Unicode string (requires cJson or other UTF-8 decoding tools) Dim s As String s = DecodeUtf8(buf) ``` *** ## Configuration Issues ### Q: Configuration changes don't take effect? **A:** When port is open, modifying `Config` properties requires calling `ApplyConfig` to take effect: ```vb sp.OpenPort sp.Config.BaudRate = br115200 sp.ApplyConfig ' ← Must call ``` However, replacing the entire configuration object with `Set sp.Config = newCfg` automatically applies. ### Q: DataBits setting throws error? **A:** `DataBits` range must be 4~8, throws error if out of range: ```vb cfg.DataBits = 3 ' Error! cfg.DataBits = 8 ' Correct ``` ### Q: InBufferSize setting throws error? **A:** `InBufferSize` and `OutBufferSize` must be greater than 0: ```vb cfg.InBufferSize = 0 ' Error! cfg.InBufferSize = 4096 ' Correct ``` ### Q: RTS/DTR behavior is abnormal after setting FlowControl? **A:** Setting `FlowControl` automatically synchronizes DTR/RTS control modes: | FlowControl | Auto-set DTR/RTS | |-------------|------------------| | `fcRtsCts` | RtsControl = Handshake | | `fcDtrDsr` | DtrControl = Handshake | | `fcRtsCtsAndXonXoff` | RtsControl = Handshake | After enabling hardware flow control, manual `SetRTS`/`SetDTR` may be overridden by flow control mechanisms. *** ## Event & Monitoring Issues ### Q: DataReceived event doesn't trigger? **A:** Must call `StartMonitoring` to start monitoring first: ```vb sp.OpenPort sp.StartMonitoring 50 ' ← Must call ``` Also check: 1. Whether the peer actually sent data 2. Whether `PollInterval` is reasonable (default 50ms) 3. Whether the object is declared with `WithEvents` ### Q: WaitForEvent freezes the interface? **A:** `WaitForEvent` is a blocking method that freezes the UI thread. **Do not use on UI thread.** Use `StartMonitoring` for asynchronous monitoring instead: ```vb ' ❌ Wrong: freezes interface sp.WaitForEvent EV_RXCHAR ' ✅ Correct: asynchronous monitoring sp.StartMonitoring 50 ``` ### Q: How to monitor signal line changes simultaneously? **A:** Asynchronous monitoring mode (`StartMonitoring`) currently does not monitor signal line changes. To monitor signal lines, you can only use `WaitForEvent` (which blocks the thread), or use a Timer to periodically query: ```vb Private Sub tmrPin_Timer() Static lastCts As Boolean Dim cts As Boolean cts = sp.CtsHolding If cts <> lastCts Then Debug.Print "CTS changed: " & cts lastCts = cts End If End Sub ``` *** ## Error Handling ### Q: Received CE\_RXOVER (receive buffer overflow) error? **A:** Receive speed exceeds processing speed, buffer is full. Solutions: 1. **Increase buffer**: `cfg.InBufferSize = 8192` 2. **Read faster**: Reduce `PollInterval` 3. **Read immediately in event**: Call `ReadExisting` in `DataReceived` event handler 4. **Use flow control**: `cfg.FlowControl = fcXonXoff` ### Q: Received CE\_RXPARITY (parity error)? **A:** Communication line interference or configuration mismatch. Check: 1. Whether both sides have matching parity settings 2. Whether the line has interference (long distance, unshielded) 3. Whether baud rate is too high (try lowering baud rate) ### Q: Received CE\_FRAME (frame error)? **A:** Usually baud rate mismatch. Confirm both sides have exactly the same baud rate: ```vb Debug.Print "Current baud rate: " & sp.Config.BaudRate ``` ### Q: How to get detailed error information? **A:** Use these methods: ```vb ' Get communication error codes Dim errs As Long errs = sp.ReadCommErrors() ' Get error description Debug.Print GetCommErrorString(errs) ' Get complete status Debug.Print sp.GetStatusString() ``` *** **Last Updated**: 2026-07-05 --- --- url: /en/vbman/serialport/methods.md --- # cSerialPort Methods Reference ## 📋 Methods List ### Open/Close | Method | Return Type | Description | |--------|-------------|-------------| | `OpenPort` | Boolean | Open serial port | | `ClosePort` | - | Close serial port | | `ApplyConfig` | - | Re-apply configuration to opened port | | `RefreshConfig` | - | Read current configuration from port | ### Read | Method | Return Type | Description | |--------|-------------|-------------| | `ReadData` | Long | Read byte array | | `ReadText` | String | Read text | | `ReadExisting` | String | Non-blocking read of all existing data | | `ReadByte` | Integer | Read single byte (0~255), returns -1 on timeout | | `ReadLine` | String | Read one line | ### Write | Method | Return Type | Description | |--------|-------------|-------------| | `WriteData` | Long | Write byte array | | `WriteText` | Long | Write text | | `WriteByte` | - | Write single byte | | `WriteLine` | Long | Write one line (auto-append newline) | | `TransmitImmediate` | Boolean | Priority transmit character, bypass buffer | ### Signal Lines | Method | Description | |--------|-------------| | `SetDTR` | Set DTR signal | | `SetRTS` | Set RTS signal | | `SetBreak` | Set/clear Break signal | | `SendXOff` | Send XOFF | | `SendXOn` | Send XON | ### Buffers | Method | Description | |--------|-------------| | `PurgeRx` | Clear receive buffer | | `PurgeTx` | Clear transmit buffer | | `PurgeAll` | Clear all buffers | ### Monitoring | Method | Return Type | Description | |--------|-------------|-------------| | `StartMonitoring` | Boolean | Start asynchronous monitoring | | `StopMonitoring` | - | Stop monitoring | | `WaitForEvent` | Long | Blocking wait for event (use cautiously) | | `GetEventMask` | Long | Get current event mask | ### Diagnostics | Method | Return Type | Description | |--------|-------------|-------------| | `GetStatusString` | String | Get complete status string | | `ReadCommErrors` | Long | Get communication error codes | | `ReadModemStatus` | Long | Get Modem status word | | `ResetCounters` | - | Reset send/receive counters | *** ## 🔓 OpenPort ### Description Open serial port. Internally handles `\\.\COMx` prefix, supports COM10 and above ports. ### Syntax ```vb Public Function OpenPort(Optional ByVal Port As String, _ Optional ByVal Config As cSerialConfig) As Boolean ``` ### Parameters | Parameter | Type | Description | |-----------|------|-------------| | `Port` | String (optional) | Port name, e.g. "COM3" | | `Config` | cSerialConfig (optional) | Configuration object | ### Return Value Returns `True` on success, `False` on failure and sets `LastError`. ### Usage Example ```vb ' Method 1: Set properties then open sp.PortName = "COM3" sp.Config.BaudRate = br115200 If sp.OpenPort() Then Debug.Print "Opened successfully" ' Method 2: Parameter method Dim cfg As New cSerialConfig cfg.BaudRate = br9600 sp.OpenPort "COM3", cfg ``` ### Opening Process ``` 1. CreateFile opens \\.\COMx 2. SetupComm sets buffer sizes 3. SetCommState applies DCB configuration 4. SetCommTimeouts applies timeout configuration 5. PurgeComm clears buffers ``` *** ## 🔒 ClosePort ### Description Close serial port and release handle. Stops monitoring first if active. ```vb sp.ClosePort ``` > `Class_Terminate` automatically calls this method. *** ## 📤 WriteText ### Description Write text, converts to ANSI bytes using `StrConv` before sending. ### Syntax ```vb Public Function WriteText(ByVal Text As String) As Long ``` ### Return Value Actual number of bytes written. ```vb Dim n As Long n = sp.WriteText("Hello") Debug.Print "Sent " & n & " bytes" ``` *** ## 📤 WriteData ### Description Write byte array, suitable for binary protocols. ### Syntax ```vb Public Function WriteData(Buffer() As Byte) As Long ``` ```vb Dim buf(2) As Byte buf(0) = &H41: buf(1) = &H42: buf(2) = &H43 sp.WriteData buf ' Send ABC ``` *** ## 📤 WriteLine ### Description Write one line of text, automatically appends newline (default `vbCrLf`). ### Syntax ```vb Public Function WriteLine(ByVal Text As String, _ Optional ByVal Terminator As String = vbCrLf) As Long ``` ```vb sp.WriteLine "Hello" ' Send "Hello" & vbCrLf sp.WriteLine "Data", vbLf ' Custom terminator ``` *** ## 📤 TransmitImmediate ### Description Priority transmit character, bypasses transmit buffer and sends directly. ```vb sp.TransmitImmediate &H55 ' Immediately send 0x55 ``` *** ## 📥 ReadExisting ### Description Non-blocking read of all existing data in the input buffer. ```vb Dim s As String s = sp.ReadExisting() If Len(s) > 0 Then Debug.Print "Received: " & s ``` *** ## 📥 ReadData ### Description Read byte array. ### Syntax ```vb Public Function ReadData(Buffer() As Byte, _ Optional ByVal BytesToRead As Long = -1) As Long ``` ### Parameters | Parameter | Type | Description | |-----------|------|-------------| | `Buffer` | Byte() | Output buffer, auto ReDim | | `BytesToRead` | Long (optional) | Number of bytes to read, -1 means read all | ### Return Value Actual number of bytes read. ```vb Dim buf() As Byte Dim n As Long n = sp.ReadData(buf) ' Read all n = sp.ReadData(buf, 10) ' Read up to 10 bytes ``` *** ## 📥 ReadLine ### Description Read one line, default ends with `vbCrLf`. May block until a complete line is received or timeout. ### Syntax ```vb Public Function ReadLine(Optional ByVal Terminator As String = vbCrLf) As String ``` ```vb sp.Config.SetReadTimeout 5000 ' Set timeout Dim line As String line = sp.ReadLine() ' Read one line ``` *** ## 📡 StartMonitoring ### Description Start asynchronous monitoring, uses Win32 Timer to periodically poll the buffer. Triggers `DataReceived` event when new data is detected. ### Syntax ```vb Public Function StartMonitoring(Optional ByVal IntervalMs As Long = 50) As Boolean ``` ```vb sp.StartMonitoring 50 ' 50ms polling sp.StartMonitoring ' Default 50ms ``` *** ## 📡 StopMonitoring Stop asynchronous monitoring. ```vb sp.StopMonitoring ``` *** ## ⚠️ WaitForEvent ### Description Blocking wait for communication event. ### Syntax ```vb Public Function WaitForEvent(ByVal EventMask As Long) As Long ``` ### Parameters | Parameter | Type | Description | |-----------|------|-------------| | `EventMask` | Long | Event combination, e.g. `EV_RXCHAR Or EV_CTS` | ### Return Value Actually occurred event mask, 0 on failure. > **⚠️ Warning**: This method blocks the calling thread! Using it on the UI thread will freeze the interface. Recommended only for background threads or console applications. Use `StartMonitoring` for regular scenarios. *** ## 🔧 SetDTR / SetRTS ### Description Manually set DTR/RTS signal lines. Note: If hardware flow control (`fcRtsCts`/`fcDtrDsr`) is configured, manual settings may be overridden by flow control. ```vb sp.SetDTR True sp.SetRTS True sp.SetDTR False sp.SetRTS False ``` *** ## 🔧 SetBreak ### Description Set or clear Break signal. Break signal holds the data line at zero state. ```vb sp.SetBreak True ' Start sending Break ' Delay... sp.SetBreak False ' Stop Break ``` *** ## 🧹 PurgeRx / PurgeTx / PurgeAll ### Description Clear buffers. | Method | Description | |--------|-------------| | `PurgeRx` | Clear receive buffer | | `PurgeTx` | Clear transmit buffer | | `PurgeAll` | Clear all buffers, terminate all pending I/O | ```vb sp.PurgeAll ' Clear all ``` *** ## 📊 GetStatusString ### Description Get complete current serial port status string for debugging. ```vb Debug.Print sp.GetStatusString() ``` Output example: ``` Port: COM3 Open: True BaudRate: 115200 DataBits: 8 InBuffer: 0 CTS: True Received: 128 Sent: 64 Monitoring: True ``` *** ## 🔄 ApplyConfig / RefreshConfig | Method | Description | |--------|-------------| | `ApplyConfig` | Re-apply current `Config` to the opened port | | `RefreshConfig` | Read current DCB/timeout from port and update `Config` | ```vb sp.OpenPort sp.Config.BaudRate = br9600 sp.ApplyConfig ' Apply new configuration sp.RefreshConfig ' Read actual configuration from port Debug.Print sp.Config.BaudRate ``` *** ## 📊 EnumSerialPorts ### Description Enumerate available serial port numbers on the system (defined in `modSerialPortAPI` module). ### Syntax ```vb Public Function EnumSerialPorts() As Collection ``` ```vb Dim ports As Collection Set ports = EnumSerialPorts() Dim p As Variant For Each p In ports Debug.Print p Next ``` *** **Last Updated**: 2026-07-05 --- --- url: /en/vbman/serialport/properties.md --- # cSerialPort Properties Reference ## 📋 Properties List ### cSerialPort Properties | Property | Type | Access | Description | |----------|------|--------|-------------| | `IsOpen` | Boolean | Read-only | Whether the serial port is open | | `PortName` | String | Read/Write | Port name, cannot be modified after opening | | `Handle` | Long | Read-only | Serial port handle | | `Config` | cSerialConfig | Read/Write | Configuration object | | `LastError` | Long | Read-only | Last error code | | `LastErrorMsg` | String | Read-only | Last error description | | `ReceivedCount` | Long | Read-only | Cumulative received bytes | | `SentCount` | Long | Read-only | Cumulative sent bytes | | `InBufferCount` | Long | Read-only | Current bytes in input buffer | | `OutBufferCount` | Long | Read-only | Current bytes in output buffer | | `CtsHolding` | Boolean | Read-only | CTS signal status | | `DsrHolding` | Boolean | Read-only | DSR signal status | | `RingHolding` | Boolean | Read-only | RING signal status | | `CdHolding` | Boolean | Read-only | CD/RLSD signal status | | `IsWaitingOnCts` | Boolean | Read-only | Whether waiting on CTS | | `IsWaitingOnDsr` | Boolean | Read-only | Whether waiting on DSR | | `IsWaitingOnRlsd` | Boolean | Read-only | Whether waiting on RLSD | | `IsXoffHold` | Boolean | Read-only | Whether paused by XOFF | | `IsXoffSent` | Boolean | Read-only | Whether XOFF has been sent | | `Monitoring` | Boolean | Read-only | Whether monitoring is active | | `PollInterval` | Long | Read/Write | Polling interval(ms), 10~60000 | ### cSerialConfig Properties | Property | Type | Default | Description | |----------|------|---------|-------------| | `BaudRate` | Long | 9600 | Baud rate | | `DataBits` | Long | 8 | Data bits, 4~8 | | `StopBits` | Long | 0 | Stop bits | | `Parity` | Long | 0 | Parity | | `FlowControl` | Long | 0 | Flow control | | `DtrControl` | Long | 1 | DTR control mode | | `RtsControl` | Long | 1 | RTS control mode | | `ReadIntervalTimeout` | Long | 50 | Read interval timeout(ms) | | `ReadTotalTimeoutMultiplier` | Long | 0 | Read per-byte timeout multiplier | | `ReadTotalTimeoutConstant` | Long | 100 | Read fixed timeout(ms) | | `WriteTotalTimeoutMultiplier` | Long | 0 | Write per-byte timeout multiplier | | `WriteTotalTimeoutConstant` | Long | 100 | Write fixed timeout(ms) | | `InBufferSize` | Long | 4096 | Input buffer size(bytes) | | `OutBufferSize` | Long | 4096 | Output buffer size(bytes) | | `XonChar` | Byte | \&H11 | XON character | | `XoffChar` | Byte | \&H13 | XOFF character | | `ErrorChar` | Byte | 0 | Parity error replacement character | | `EofChar` | Byte | 0 | EOF character | | `EvtChar` | Byte | 0 | Event trigger character | | `NullDiscard` | Boolean | False | Whether to discard NULL bytes | | `AbortOnError` | Boolean | False | Whether to abort read/write on error | | `TXContinueOnXoff` | Boolean | False | Whether to continue sending after XOFF | | `ParityReplace` | Boolean | True | Whether to replace characters on parity error | *** ## 🔧 cSerialPort Properties Details ### IsOpen Whether the serial port is open. ```vb If sp.IsOpen Then Debug.Print "Serial port is open" End If ``` ### PortName Port name. Cannot be modified after opening, must close first. ```vb sp.PortName = "COM3" sp.OpenPort ' sp.PortName = "COM4" ' Error! Cannot change after opening sp.ClosePort sp.PortName = "COM4" ' Can change after closing ``` ### Config Configuration object, type `cSerialConfig`. Changes while port is open require calling `ApplyConfig` to take effect. ```vb ' Read configuration Debug.Print sp.Config.BaudRate ' Modify configuration sp.Config.BaudRate = br115200 If sp.IsOpen Then sp.ApplyConfig ' Must manually apply if already open ' Replace entire configuration object Dim cfg As New cSerialConfig cfg.BaudRate = br9600 Set sp.Config = cfg ' Automatically applies ``` ### LastError / LastErrorMsg Last Win32 error code and description. `OpenPort` returns `False` and sets `LastError` on failure. ```vb If Not sp.OpenPort("COM99") Then Debug.Print "Error code: " & sp.LastError Debug.Print "Error description: " & sp.LastErrorMsg End If ``` ### ReceivedCount / SentCount Cumulative send/receive byte count. Can be reset with `ResetCounters`. ```vb Debug.Print "Received: " & sp.ReceivedCount & " bytes" Debug.Print "Sent: " & sp.SentCount & " bytes" sp.ResetCounters ``` ### InBufferCount / OutBufferCount Current byte count in input/output buffer. ```vb If sp.InBufferCount > 0 Then Debug.Print "Buffer has " & sp.InBufferCount & " bytes available" End If ``` ### Signal Line Status Properties | Property | Signal | Description | |----------|--------|-------------| | `CtsHolding` | CTS | Clear To Send | | `DsrHolding` | DSR | Data Set Ready | | `RingHolding` | RING | Ring Indicator | | `CdHolding` | CD/RLSD | Carrier Detect | ```vb Debug.Print "CTS=" & sp.CtsHolding & " DSR=" & sp.DsrHolding Debug.Print "RING=" & sp.RingHolding & " CD=" & sp.CdHolding ``` ### PollInterval Monitoring polling interval in milliseconds, range 10~60000. Can be specified when calling `StartMonitoring`, or modified via property. ```vb sp.PollInterval = 100 ' 100ms polling ``` *** ## ⚙️ cSerialConfig Properties Details ### BaudRate Baud rate, use `eBaudRate` enum constants. Supports up to **256000**, far exceeding the MSComm control's limit of 115200. | Constant | Value | Description | |----------|-------|-------------| | `br110` | 110 | | | `br300` | 300 | | | `br600` | 600 | | | `br1200` | 1200 | | | `br2400` | 2400 | | | `br4800` | 4800 | | | `br9600` | 9600 | Default | | `br14400` | 14400 | | | `br19200` | 19200 | | | `br38400` | 38400 | | | `br56000` | 56000 | | | `br57600` | 57600 | | | `br115200` | 115200 | Common high-speed | | `br128000` | 128000 | | | `br256000` | 256000 | **Maximum supported** | ```vb cfg.BaudRate = br9600 ' Or br115200, br57600, br256000, etc. ``` ### DataBits Data bits, range 4~8, throws error if out of range. ```vb cfg.DataBits = 8 ``` ### StopBits Stop bits, use `eStopBits` enum: `sb1`(0), `sb1_5`(1), `sb2`(2). ### Parity Parity, use `eParity` enum: `ptNone`(0), `ptOdd`(1), `ptEven`(2), `ptMark`(3), `ptSpace`(4). ### FlowControl Flow control, use `eFlowControl` enum. Setting this automatically synchronizes DTR/RTS control modes. ```vb cfg.FlowControl = fcRtsCts ' Hardware flow control RTS/CTS ``` ### DtrControl / RtsControl DTR/RTS control modes. Use `eDtrControl`/`eRtsControl` enum: `dcDisable`(0), `dcEnable`(1), `dcHandshake`(2), `rcToggle`(3, RTS only). ### Timeout Parameters | Parameter | Description | |-----------|-------------| | `ReadIntervalTimeout` | Maximum interval between two reads, return on timeout | | `ReadTotalTimeoutMultiplier` | Per-byte timeout multiplier | | `ReadTotalTimeoutConstant` | Read fixed timeout | | `WriteTotalTimeoutMultiplier` | Write per-byte timeout multiplier | | `WriteTotalTimeoutConstant` | Write fixed timeout | > Total timeout = Multiplier × byte count + Constant. See [Advanced - Timeout Strategies](./advanced.md) ### InBufferSize / OutBufferSize Buffer sizes, must be greater than 0. ### XonChar / XoffChar XON/XOFF flow control characters, default \&H11(DC1) and \&H13(DC3). *** ## 📚 Enum Reference All enums are defined in class modules (not standard modules), so they are exported with the DLL type library and available to external projects. See [Overview - Architecture](./overview.md) for details. ### eBaudRate (cSerialConfig) Baud rate constants. Maximum: **256000**. See [BaudRate](#baudrate) for full table. ### eParity (cSerialConfig) | Constant | Value | Win32 Constant | Description | |----------|-------|----------------|-------------| | `ptNone` | 0 | NOPARITY | No parity | | `ptOdd` | 1 | ODDPARITY | Odd parity | | `ptEven` | 2 | EVENPARITY | Even parity | | `ptMark` | 3 | MARKPARITY | Mark parity | | `ptSpace` | 4 | SPACEPARITY | Space parity | ### eStopBits (cSerialConfig) | Constant | Value | Win32 Constant | Description | |----------|-------|----------------|-------------| | `sb1` | 0 | ONESTOPBIT | 1 stop bit | | `sb1_5` | 1 | ONE5STOPBITS | 1.5 stop bits | | `sb2` | 2 | TWOSTOPBITS | 2 stop bits | ### eDtrControl (cSerialConfig) | Constant | Value | Win32 Constant | Description | |----------|-------|----------------|-------------| | `dcDisable` | 0 | DTR\_CONTROL\_DISABLE | DTR line disabled | | `dcEnable` | 1 | DTR\_CONTROL\_ENABLE | DTR line enabled | | `dcHandshake` | 2 | DTR\_CONTROL\_HANDSHAKE | DTR flow control handshake | ### eRtsControl (cSerialConfig) | Constant | Value | Win32 Constant | Description | |----------|-------|----------------|-------------| | `rcDisable` | 0 | RTS\_CONTROL\_DISABLE | RTS line disabled | | `rcEnable` | 1 | RTS\_CONTROL\_ENABLE | RTS line enabled | | `rcHandshake` | 2 | RTS\_CONTROL\_HANDSHAKE | RTS flow control handshake | | `rcToggle` | 3 | RTS\_CONTROL\_TOGGLE | RTS toggle mode | ### eFlowControl (cSerialConfig) | Constant | Value | Description | |----------|-------|-------------| | `fcNone` | 0 | No flow control | | `fcXonXoff` | 1 | Software flow control (XON/XOFF) | | `fcRtsCts` | 2 | Hardware flow control (RTS/CTS) | | `fcDtrDsr` | 3 | Hardware flow control (DTR/DSR) | | `fcRtsCtsAndXonXoff` | 4 | Mixed flow control (RTS/CTS + XON/XOFF) | ### eCommEvent (cSerialPort) Communication events for `SetCommMask` / `WaitForEvent` / `PinChanged`. | Constant | Value | Description | |----------|-------|-------------| | `EV_RXCHAR` | \&H1 | Character received | | `EV_RXFLAG` | \&H2 | Event character received | | `EV_TXEMPTY` | \&H4 | Transmit buffer empty | | `EV_CTS` | \&H8 | CTS signal changed | | `EV_DSR` | \&H10 | DSR signal changed | | `EV_RLSD` | \&H20 | RLSD(CD) signal changed | | `EV_BREAK` | \&H40 | Break detected | | `EV_ERR` | \&H80 | Line status error | | `EV_RING` | \&H100 | Ring detected | | `EV_PERR` | \&H200 | Printer error | | `EV_RX80FULL` | \&H400 | Receive buffer 80% full | | `EV_EVENT1` | \&H800 | Device event 1 | | `EV_EVENT2` | \&H1000 | Device event 2 | ### eCommError (cSerialPort) Communication errors from `ClearCommError` / `ErrorOccurred` / `ReadCommErrors`. | Constant | Value | Description | |----------|-------|-------------| | `CE_RXOVER` | \&H1 | Receive buffer overflow | | `CE_OVERRUN` | \&H2 | Character overrun | | `CE_RXPARITY` | \&H4 | Parity error | | `CE_FRAME` | \&H8 | Frame error | | `CE_BREAK` | \&H10 | Break detected | | `CE_TXFULL` | \&H100 | Transmit buffer full | | `CE_PTO` | \&H200 | Parallel port timeout | | `CE_IOE` | \&H400 | I/O error | | `CE_DNS` | \&H800 | Device not selected | | `CE_OOP` | \&H1000 | Out of paper | | `CE_MODE` | \&H8000 | Mode error | ### eModemStatus (cSerialPort) Modem status from `GetCommModemStatus` / `ReadModemStatus`. | Constant | Value | Description | |----------|-------|-------------| | `MS_CTS_ON` | \&H10 | CTS (Clear To Send) | | `MS_DSR_ON` | \&H20 | DSR (Data Set Ready) | | `MS_RING_ON` | \&H40 | RING (Ring Indicator) | | `MS_RLSD_ON` | \&H80 | RLSD/CD (Carrier Detect) | *** **Last Updated**: 2026-07-05 --- --- url: /en/vbman/serialport/quickstart.md --- # cSerialPort Quick Start ## 📖 Table of Contents * [Reference Methods](#reference-methods) * [Minimal Example](#minimal-example) * [Common Scenarios](#common-scenarios) *** ## Reference Methods ### Method 1: Source Code Reference Add the three files under `src/SerialPort` to the VB6 project: ``` modSerialPortAPI.bas # API declarations, constants, types, helper functions cSerialConfig.cls # Configuration class (includes eBaudRate/eParity/eStopBits enums) cSerialPort.cls # Serial port main class (includes eCommEvent/eCommError/eModemStatus enums) ``` ### Method 2: DLL Reference Reference `dist\DLL\VBMAN.dll`, use with namespace prefix: ```vb Dim sp As New VBMANLIB.cSerialPort ``` *** ## Minimal Example Open COM3, send text and read response: ```vb Dim sp As New cSerialPort sp.PortName = "COM3" sp.Config.BaudRate = br9600 If sp.OpenPort() Then sp.WriteText "Hello" Debug.Print sp.ReadExisting() sp.ClosePort End If ``` *** ## Common Scenarios ### 1. Event-Driven Continuous Send/Receive Declare object with `WithEvents`, receive data automatically through events: ```vb Private WithEvents m_Port As cSerialPort Private Sub Form_Load() Set m_Port = New cSerialPort m_Port.PortName = "COM4" m_Port.Config.BaudRate = 9600 m_Port.Config.DataBits = 8 m_Port.Config.Parity = 0 ' ptNone m_Port.Config.StopBits = 0 ' sb1 If Not m_Port.OpenPort() Then Debug.Print "Open failed: " & m_Port.LastErrorMsg Exit Sub End If m_Port.StartMonitoring 50 ' 50ms polling Debug.Print "Started, waiting for data..." End Sub Private Sub m_Port_DataReceived(ByVal BytesCount As Long) Debug.Print "Received: " & m_Port.ReadExisting() End Sub Private Sub m_Port_ErrorOccurred(ByVal ErrorCode As Long, ByVal ErrorMsg As String) Debug.Print "Error: " & ErrorMsg End Sub Private Sub Form_Unload(Cancel As Integer) If Not m_Port Is Nothing Then If m_Port.IsOpen Then m_Port.ClosePort Set m_Port = Nothing End If End Sub ``` ### 2. Request-Response Mode (With Timeout) Send command and wait for response, auto-exit on timeout: ```vb Dim sp As New cSerialPort sp.PortName = "COM3" sp.Config.BaudRate = br9600 sp.Config.SetReadTimeout 2000 ' Read timeout 2 seconds sp.OpenPort sp.WriteText "hello" Dim received As String Dim startTime As Single startTime = Timer Do DoEvents If sp.InBufferCount > 0 Then received = received & sp.ReadExisting() If InStr(received, "world") > 0 Then Exit Do End If Loop While Timer - startTime < 10 ' Wait up to 10 seconds If InStr(received, "world") > 0 Then Debug.Print "Received response: " & received Else Debug.Print "Timeout, no response received" End If sp.ClosePort ``` ### 3. Binary Protocol Send/Receive Send and receive byte arrays, suitable for Modbus and other binary protocols: ```vb Dim sp As New cSerialPort sp.PortName = "COM3" sp.Config.BaudRate = br115200 sp.OpenPort ' Send Modbus request frame Dim frame(7) As Byte frame(0) = &H01 ' Device address frame(1) = &H03 ' Function code frame(2) = &H00: frame(3) = &H00 ' Start address frame(4) = &H00: frame(5) = &H0A ' Register count frame(6) = &HC5: frame(7) = &HCD ' CRC sp.WriteData frame ' Wait and read response Dim startTime As Single startTime = Timer Do While sp.InBufferCount < 5 And Timer - startTime < 2 DoEvents Loop Dim buf() As Byte Dim n As Long n = sp.ReadData(buf) ' Read all available data Debug.Print "Received " & n & " bytes" sp.ClosePort ``` ### 4. Read One Line of Text Split by newline, read a complete line: ```vb Dim sp As New cSerialPort sp.PortName = "COM3" sp.Config.BaudRate = br9600 sp.Config.SetReadTimeout 5000 ' 5 second timeout sp.OpenPort Dim line As String line = sp.ReadLine() ' Read until vbCrLf Debug.Print "Received line: " & line sp.ClosePort ``` ### 5. Enumerate Available Serial Ports Scan all available serial ports on the system: ```vb Dim ports As Collection Set ports = EnumSerialPorts() Dim p As Variant For Each p In ports Debug.Print p ' COM1, COM3, ... Next Debug.Print "Total " & ports.Count & " available serial ports" ``` *** **Last Updated**: 2026-07-05 --- --- url: /en/vbman/serialport/overview.md --- # cSerialPort Serial Communication Development Documentation > 🚀 **cSerialPort** - Pure Win32 API VB6 serial communication class, fully encapsulating Windows serial communication capabilities ## 📖 Table of Contents * [Overview](#overview) * [Core Features](#core-features) * [Comparison with MSComm Control](#comparison-with-mscomm-control) * [Architecture Design](#architecture-design) * [Quick Start](#quick-start) * [Documentation Index](#documentation-index) *** ## Overview `cSerialPort` is a serial communication class provided by VBManLib, directly calling Win32 API to implement complete serial communication functionality. Compared to the traditional MSComm control, it has no OCX dependency, supports ports above COM10, and allows precise control of low-level parameters, making it suitable for industrial control, device communication, Modbus, and other scenarios. ### ✨ Main Features * 🔌 **Pure API Implementation** - No MSComm OCX control required, zero external dependencies * 🎯 **Complete Encapsulation** - Covers open/close, read/write, configuration, signal lines, error handling, buffer management * 📡 **Event-Driven** - Asynchronous polling monitoring, does not block UI thread * 🔧 **Precise Configuration** - Complete DCB/COMMTIMEOUTS parameters, supports flow control, timeout presets * 📊 **Signal Line Control** - Full set of DTR/RTS/Break/XON/XOFF signal line operations * 🔍 **Port Enumeration** - Automatically scans available serial ports on the system * 📦 **Binary and Text** - Supports both byte array and text read/write * 🛡️ **Error Diagnosis** - Chinese error descriptions, complete status queries *** ## Core Features ### 1️⃣ No OCX Dependency 🔌 The traditional MSComm control requires registration of `MSCOMM32.OCX`, which is cumbersome to deploy and cannot be used for ports above COM10. `cSerialPort` directly calls `kernel32` API with zero dependencies. ### 2️⃣ Asynchronous Event Monitoring 📡 Uses Win32 Timer to periodically poll the buffer, automatically triggering the `DataReceived` event when new data is detected, without blocking the UI thread: ```vb Dim WithEvents sp As cSerialPort Private Sub Start() Set sp = New cSerialPort sp.PortName = "COM3" sp.OpenPort sp.StartMonitoring 50 ' 50ms polling End Sub Private Sub sp_DataReceived(ByVal BytesCount As Long) Debug.Print "Received: " & sp.ReadExisting() End Sub ``` ### 3️⃣ Complete Signal Line Control 📊 Supports manual DTR/RTS/Break control, as well as CTS/DSR/RING/CD status queries: ```vb sp.SetDTR True ' Set DTR sp.SetRTS True ' Set RTS sp.SetBreak True ' Send Break signal Debug.Print sp.CtsHolding ' Query CTS status ``` ### 4️⃣ Flexible Timeout Configuration ⏱️ Provides three preset modes, or manual precise control of each timeout parameter: ```vb sp.Config.SetNonBlockingRead ' Non-blocking: return immediately sp.Config.SetBlockingRead ' Blocking: wait for specified byte count sp.Config.SetReadTimeout 2000 ' With timeout: 2 seconds ``` ### 5️⃣ Mode String Compatibility 🔤 Supports mode strings compatible with the `BuildCommDCB` API: ```vb sp.Config.FromModeString "baud=9600 parity=N data=8 stop=1" ``` ### 6️⃣ Data Framing 🧩 Solve the "packet concatenation" problem caused by device continuous transmission, identifying the boundary of each frame: * **Plan B (Frame Interval Timeout)**: Set the `FrameInterval` property to automatically frame data using the pause after the device finishes sending one frame * **Plan C (Protocol Frame Parser)**: The `cSerialFrameParser` class precisely splits by delimiter/start-end markers/length field/fixed length ```vb ' Plan B: 30ms no new data = one frame ends sp.FrameInterval = 30 sp.StartMonitoring 20 Private Sub sp_FrameReceived(FrameData() As Byte) Debug.Print "Received frame: " & StrConv(FrameData, vbUnicode) End Sub ``` See [Framing Protocol Guide](./framing.md) for details *** ## Comparison with MSComm Control | Feature | MSComm Control | cSerialPort Class | |---------|---------------|-------------------| | **Dependency** | Requires MSCOMM32.OCX registration | Pure API, zero dependencies | | **Port Limitation** | Only COM1~COM9 | Supports COM10 and above | | **Event Model** | OnComm event + CommEvent | Independent events (DataReceived, etc.) | | **Signal Line Control** | DTREnable/RTSEnable properties | SetDTR/SetRTS/SetBreak methods | | **Timeout Control** | None (only InputLen/Threshold) | Complete COMMTIMEOUTS five parameters | | **Flow Control** | Handshaking property (limited) | Complete RTS/CTS, DTR/DSR, XON/XOFF | | **Buffer Management** | InBufferCount/OutBufferCount | Same + PurgeRx/PurgeTx/PurgeAll | | **Error Diagnosis** | No detailed errors | Chinese error descriptions + status strings | | **Binary Support** | Input property | ReadData/WriteData byte arrays | | **Baud Rate** | Up to 115200 | Up to 256000 (eBaudRate enum) | | **Data Framing** | None (only RThreshold triggers) | FrameInterval + cSerialFrameParser, solve packet concatenation | | **Port Enumeration** | None | EnumSerialPorts auto scan | *** ## Architecture Design ### Class Hierarchy ``` cSerialPort (Public Class) ├── m_Config: cSerialConfig (Configuration Object) ├── m_Handle: Long (Serial Port Handle) ├── m_TimerID: Long (Monitoring Timer) └── Events: DataReceived, ErrorOccurred, PinChanged, TxEmpty, BreakDetected, RingDetected ``` ### Submodule Classes | Class/Module | File | Responsibility | |-------------|------|----------------| | `cSerialConfig` | `cSerialConfig.cls` | Serial port configuration: encapsulates DCB and COMMTIMEOUTS, provides type-safe access; defines configuration enums (`eBaudRate`/`eParity`/`eStopBits`/`eDtrControl`/`eRtsControl`/`eFlowControl`) | | `cSerialPort` | `cSerialPort.cls` | Serial port main class; defines communication enums (`eCommEvent`/`eCommError`/`eModemStatus`) | | `modSerialPortAPI` | `modSerialPortAPI.bas` | API declarations, constants, types, helper functions | > **Note**: All `Public Enum` are defined in class modules (not standard modules), because VB6 standard module `Public Enum` are not exported with the DLL type library. Moving them to class modules allows external projects referencing the DLL to use enum constants like `br115200`, `EV_RXCHAR`, `CE_RXOVER`. Helper functions inside `modSerialPortAPI` (such as `GetCommErrorString`) use underlying numeric values to avoid circular references with class modules. ### Object Relationship Diagram ``` cSerialPort ├── Config (cSerialConfig) │ ├── BuildDCB() → DCB structure │ ├── BuildTimeouts() → COMMTIMEOUTS structure │ └── Preset methods → Non-blocking/Blocking/Timeout modes ├── Handle (Serial Port Handle) │ ├── ReadFile / WriteFile │ ├── GetCommModemStatus (Signal Lines) │ ├── ClearCommError (Errors/Status) │ └── PurgeComm (Buffers) └── Timer (Monitoring Timer) └── Poll() → Triggers DataReceived event ``` ### Workflow ``` 1. Create cSerialConfig configuration parameters 2. cSerialPort.OpenPort() to open serial port 3. (Optional) StartMonitoring() to start event monitoring 4. WriteText/WriteData to send data 5. DataReceived event / ReadExisting to read data 6. ClosePort() to close serial port ``` *** ## Quick Start ### Minimal Send/Receive Example ```vb Dim sp As New cSerialPort sp.PortName = "COM3" sp.Config.BaudRate = br115200 If sp.OpenPort() Then sp.WriteText "Hello" Debug.Print sp.ReadExisting() sp.ClosePort End If ``` ### Event-Driven Send/Receive Example ```vb Private WithEvents m_Port As cSerialPort Private Sub Form_Load() Set m_Port = New cSerialPort m_Port.PortName = "COM3" m_Port.Config.BaudRate = br9600 If m_Port.OpenPort() Then m_Port.StartMonitoring 50 End If End Sub Private Sub m_Port_DataReceived(ByVal BytesCount As Long) Debug.Print "Received: " & m_Port.ReadExisting() End Sub Private Sub Form_Unload(Cancel As Integer) m_Port.ClosePort End Sub ``` > For a more complete example, see [Quick Start](./quickstart.md) *** ## Documentation Index | Document | Description | |----------|-------------| | [Quick Start](./quickstart.md) | Minimal reference, common scenario code examples | | [Properties Reference](./properties.md) | Description, type, and usage of all properties | | [Methods Reference](./methods.md) | Parameters, return values, and usage examples of all methods | | [Events Reference](./events.md) | Detailed description and usage examples of all events | | [Framing Protocol](./framing.md) | Solve packet concatenation: frame interval framing + protocol frame parser | | [Advanced](./advanced.md) | Flow control, timeout strategies, binary protocols, virtual serial ports, etc. | | [FAQ](./faq.md) | Common questions and solutions | *** **Last Updated**: 2026-07-05 --- --- url: /zh/vbman/httpclient/sse.md --- # cSSEClient SSE 客户端组件 ## 简介 `cSSEClient` 是一个 Server-Sent Events (SSE) 客户端实现，用于接收服务器实时推送的消息。支持自动重连、事件解析、连接状态管理。支持 GET 和 POST 两种连接方式，适用于 AI 流式聊天等需要发送请求体的场景。 ## 特性 * 自动重连机制 * 实时事件接收 * 支持 GET/POST 两种连接方式 * 支持自定义请求头 * 支持自定义重连间隔 * 支持 Last-Event-ID 续传 * 连接状态管理 * 最大重连次数限制 * 可配置请求超时 ## 快速开始 ### 基本使用（GET） ```vb Private WithEvents SSE As cSSEClient Private Sub Form_Load() Set SSE = New cSSEClient ' 配置重连参数 SSE.AutoReconnect = True SSE.ReconnectInterval = 3000 ' 3秒 SSE.MaxReconnectAttempts = 10 ' 连接到 SSE 服务端 Call SSE.Connect("https://api.example.com/events") End Sub Private Sub Form_Unload(Cancel As Integer) Call SSE.Disconnect() Set SSE = Nothing End Sub ``` ### POST 方式连接（AI 流式聊天等） ```vb Private WithEvents SSE As cSSEClient Private Sub StartChat() Set SSE = New cSSEClient ' 设置自定义请求头 SSE.SetHeader("Authorization", "Bearer sk-xxx") _ .SetHeader("Content-Type", "application/json") SSE.RequestTimeOut = 120 ' 120秒超时 ' POST 方式连接（自动禁用重连） Dim Body As String Body = "{""model"":""gpt-4"",""stream"":true,""messages"":[{""role"":""user"",""content"":""hello""}]}" Call SSE.ConnectPost("https://api.openai.com/v1/chat/completions", Body) End Sub ``` ### 事件处理 ```vb ' 连接建立 Private Sub SSE_OnOpen() Debug.Print "SSE 连接已建立" End Sub ' 收到消息 Private Sub SSE_OnMessage(EventName As String, Data As String, Id As String) Debug.Print "事件: " & EventName Debug.Print "数据: " & Data Debug.Print "ID: " & Id End Sub ' 发生错误 Private Sub SSE_OnError(Description As String, ErrorNumber As Long) Debug.Print "SSE 错误 " & ErrorNumber & ": " & Description End Sub ' 连接关闭 Private Sub SSE_OnClose() Debug.Print "SSE 连接已关闭" End Sub ``` ## 方法 ### Connect 以 GET 方式连接到 SSE 服务端。 ```vb Public Function Connect(ByVal ServerUrl As String) As cSSEClient ``` ### ConnectPost 以 POST 方式连接到 SSE 服务端，适用于需要发送请求体的场景（如 AI 流式聊天）。POST 方式自动禁用重连。 ```vb Public Function ConnectPost(ByVal ServerUrl As String, ByVal Body As String) As cSSEClient ``` **参数**: * `ServerUrl` - SSE 服务端地址 * `Body` - POST 请求体内容 **示例**: ```vb Call SSE.ConnectPost("https://api.example.com/chat", "{""prompt"":""hello""}") ``` ### Disconnect 断开 SSE 连接。 ```vb Public Sub Disconnect() ``` ### SetHeader 设置自定义请求头（链式调用）。 ```vb Public Function SetHeader(ByVal Key As String, ByVal Value As String) As cSSEClient ``` **示例**: ```vb SSE.SetHeader("Authorization", "Bearer token123") _ .SetHeader("Content-Type", "application/json") ``` ### ClearHeaders 清空所有自定义请求头。 ```vb Public Sub ClearHeaders() ``` ### EnableAutoReconnect 启用自动重连。 ```vb Public Sub EnableAutoReconnect() ``` ### DisableAutoReconnect 禁用自动重连。 ```vb Public Sub DisableAutoReconnect() ``` ### ResetReconnectAttempts 重置重连计数器。 ```vb Public Sub ResetReconnectAttempts() ``` ## 属性 | 属性 | 类型 | 说明 | |------|------|------| | `Url` | String | 当前连接的 URL | | `Connected` | Boolean | 连接状态 | | `Connecting` | Boolean | 是否正在连接中 | | `AutoReconnect` | Boolean | 是否启用自动重连（默认 True） | | `ReconnectInterval` | Long | 重连间隔（毫秒，默认 3000ms） | | `MaxReconnectAttempts` | Long | 最大重连次数（默认 10 次） | | `CurrentReconnectAttempts` | Long | 当前重连尝试次数 | | `LastReceivedEventId` | String | 最后收到的事件 ID | | `CurrentReconnectDelay` | Long | 当前重连延迟（毫秒） | | `ServerReconnectInterval` | Long | 服务器指定的重连间隔 | | `RequestTimeOut` | Long | 请求超时时间（秒，默认 60） | ## 事件 | 事件 | 说明 | |------|------| | `OnOpen()` | 连接建立时触发 | | `OnMessage(EventName, Data, Id)` | 收到消息时触发 | | `OnError(Description, ErrorNumber)` | 发生错误时触发 | | `OnClose()` | 连接关闭时触发 | *** **最后更新**: 2025-05-25 --- --- url: /en/vbman/httpclient/sse.md --- # cSSEClient SSE Client Component ## Introduction `cSSEClient` is a Server-Sent Events (SSE) client implementation for receiving real-time push messages from server. Supports auto reconnect, event parsing, and connection state management. ## Features * Auto reconnect mechanism * Real-time event receiving * Custom reconnect interval support * Last-Event-ID resumption support * Connection state management * Max reconnect attempts limit ## Quick Start ### Basic Usage ```vb Private WithEvents SSE As cSSEClient Private Sub Form_Load() Set SSE = New cSSEClient ' Configure reconnect parameters SSE.AutoReconnect = True SSE.ReconnectInterval = 3000 ' 3 seconds SSE.MaxReconnectAttempts = 10 ' Connect to SSE server Call SSE.Connect("https://api.example.com/events") End Sub Private Sub Form_Unload(Cancel As Integer) Call SSE.Disconnect() Set SSE = Nothing End Sub ``` ### Event Handling ```vb ' Connection established Private Sub SSE_OnOpen() Debug.Print "SSE connection established" End Sub ' Message received Private Sub SSE_OnMessage(EventName As String, Data As String, Id As String) Debug.Print "Event: " & EventName Debug.Print "Data: " & Data Debug.Print "ID: " & Id End Sub ' Error occurred Private Sub SSE_OnError(Description As String, ErrorNumber As Long) Debug.Print "SSE error " & ErrorNumber & ": " & Description End Sub ' Connection closed Private Sub SSE_OnClose() Debug.Print "SSE connection closed" End Sub ``` ## Methods ### Connect Connects to SSE server. ```vb Public Function Connect(ByVal ServerUrl As String) As cSSEClient ``` ### Disconnect Disconnects SSE connection. ```vb Public Sub Disconnect() ``` ### EnableAutoReconnect Enables auto reconnect. ```vb Public Sub EnableAutoReconnect() ``` ### DisableAutoReconnect Disables auto reconnect. ```vb Public Sub DisableAutoReconnect() ``` ### ResetReconnectAttempts Resets reconnect counter. ```vb Public Sub ResetReconnectAttempts() ``` ## Properties | Property | Type | Description | |----------|------|-------------| | `Url` | String | Current connection URL | | `Connected` | Boolean | Connection status | | `Connecting` | Boolean | Whether connecting | | `AutoReconnect` | Boolean | Enable auto reconnect (default True) | | `ReconnectInterval` | Long | Reconnect interval (ms, default 3000ms) | | `MaxReconnectAttempts` | Long | Max reconnect attempts (default 10) | | `CurrentReconnectAttempts` | Long | Current reconnect attempts | | `LastReceivedEventId` | String | Last received event ID | | `CurrentReconnectDelay` | Long | Current reconnect delay (ms) | | `ServerReconnectInterval` | Long | Server-specified reconnect interval | ## Events | Event | Description | |-------|-------------| | `OnOpen()` | Triggers when connection is established | | `OnMessage(EventName, Data, Id)` | Triggers when message received | | `OnError(Description, ErrorNumber)` | Triggers when error occurs | | `OnClose()` | Triggers when connection closes | *** **Last Updated**: 2026-05-17 --- --- url: /zh/vbman/startup/methods.md --- # cStartUp 方法参考 ## Toggle 切换指定名称的开机启动项。如果不存在则添加，存在则删除。 ```vb Public Function Toggle( _ ByVal Name As String, _ ByRef Path As Variant, _ ParamArray StartArgs() As Variant _ ) As Boolean ``` ### 参数 | 参数名 | 类型 | 说明 | |--------|------|------| | `Name` | String | 启动项名称（注册表中显示的名称） | | `Path` | Variant | 程序路径，支持两种格式：App 对象或字符串路径 | | `StartArgs` | Variant | 可选，启动参数数组（ParamArray） | ### 返回值 * `True` - 切换成功 * `False` - 切换失败，可通过 `LastError` 获取错误信息 ### 示例 #### 传入 App 对象（推荐） ```vb ' 自动提取 App.Path 和 App.EXEName VBMAN.StartUp.Toggle "MyApp", App ``` #### 传入字符串路径 ```vb ' 直接指定完整路径 VBMAN.StartUp.Toggle "MyApp", "C:\Program Files\MyApp\MyApp.exe" ``` #### 带启动参数 ```vb ' 传递多个启动参数 VBMAN.StartUp.Toggle "MyApp", App, "--minimized", "--start-in-tray" ``` #### 完整使用流程 ```vb Private Sub MenuStartUp_Click() Dim Result As Boolean ' 切换开机启动状态 Result = VBMAN.StartUp.Toggle("cs-auther-client", App) If Result Then ' 更新菜单勾选状态 MenuStartUp.Checked = VBMAN.StartUp.Has("cs-auther-client") ' 显示提示 If MenuStartUp.Checked Then VBMAN.Toast.Show "已设置开机启动" Else VBMAN.Toast.Show "已取消开机启动" End If Else ' 显示错误 MsgBox "设置失败：" & VBMAN.StartUp.LastError, vbExclamation End If End Sub ``` *** ## Has 检查指定的启动项是否存在。 ```vb Public Function Has(ByVal Name As String) As Boolean ``` ### 参数 | 参数名 | 类型 | 说明 | |--------|------|------| | `Name` | String | 启动项名称 | ### 返回值 * `True` - 启动项存在 * `False` - 启动项不存在 ### 示例 ```vb ' 检查是否存在 If VBMAN.StartUp.Has("MyApp") Then Debug.Print "已设置开机启动" Else Debug.Print "未设置开机启动" End If ' 用于设置菜单勾选状态 MenuStartUp.Checked = VBMAN.StartUp.Has("MyApp") ``` *** ## 使用模式对比 | 场景 | 代码示例 | |------|----------| | **添加启动项** | `Toggle("App", App)` - 如果不存在则添加 | | **删除启动项** | `Toggle("App", App)` - 如果存在则删除 | | **切换启动项** | `Toggle("App", App)` - 自动切换状态 | | **检查状态** | `Has("App")` - 返回布尔值 | ## 错误处理 ```vb If Not VBMAN.StartUp.Toggle("MyApp", App) Then ' 处理错误 Dim ErrMsg As String ErrMsg = VBMAN.StartUp.LastError MsgBox "开机启动设置失败：" & ErrMsg, vbCritical End If ``` --- --- url: /zh/vbman/startup/overview.md --- # cStartUp 开机启动管理组件 ## 概述 `cStartUp` 是 VBMAN 框架提供的开机启动管理组件，用于管理 Windows 系统注册表中的开机启动项。支持添加、删除、查询启动项，可传递启动参数。 ## 特性 * **切换模式** - 自动判断添加或删除启动项 * **支持参数** - 可为启动程序传递命令行参数 * **双模式路径** - 支持传入 App 对象或字符串路径 * **全局访问** - 通过 `VBMAN.StartUp` 快速访问 ## 快速开始 ### 检查当前开机启动状态 ```vb Private Sub Form_Load() ' 设置菜单勾选状态 MenuStartUp.Checked = VBMAN.StartUp.Has("my-app-name") End Sub ``` ### 切换开机启动 ```vb Private Sub MenuStartUp_Click() ' Toggle 会自动判断：不存在则添加，存在则删除 If VBMAN.StartUp.Toggle("my-app-name", App) = True Then ' 切换成功，更新菜单状态 MenuStartUp.Checked = VBMAN.StartUp.Has("my-app-name") VBMAN.Toast.Show IIf(MenuStartUp.Checked, "设置开机启动成功", "取消开机启动成功") Else ' 切换失败，显示错误 VBMAN.Toast.Show "开机设置失败：" & VBMAN.StartUp.LastError End If End Sub ``` ## 注册表位置 组件操作的是 Windows 注册表以下位置： ``` HKCU\Software\Microsoft\Windows\CurrentVersion\Run ``` > 注：HKCU 表示当前用户，设置的开机启动仅对当前用户生效。 ## 完整示例 ```vb '=============================================== ' 开机启动管理完整示例 '=============================================== Private Sub Form_Load() ' 初始化菜单状态 UpdateStartUpMenu() End Sub ' 点击开机启动菜单 Private Sub MenuStartUp_Click() ToggleStartUp End Sub ' 切换开机启动状态 Private Sub ToggleStartUp() Dim AppName As String AppName = "my-application" ' 方式1：传入 App 对象（推荐） If VBMAN.StartUp.Toggle(AppName, App) Then UpdateStartUpMenu() ShowToggleResult Else MsgBox "设置失败：" & VBMAN.StartUp.LastError, vbCritical End If End Sub ' 更新菜单勾选状态 Private Sub UpdateStartUpMenu() MenuStartUp.Checked = VBMAN.StartUp.Has("my-application") End Sub ' 显示切换结果 Private Sub ShowToggleResult() If MenuStartUp.Checked Then VBMAN.Toast.Show "已添加到开机启动" Else VBMAN.Toast.Show "已取消开机启动" End If End Sub ``` ## 带启动参数 ```vb ' 切换开机启动，并传递启动参数 Private Sub MenuStartUp_Click() ' 参数：启动后最小化到托盘 If VBMAN.StartUp.Toggle("my-app", App, "--minimized", "--autostart") Then Debug.Print "开机启动设置成功" End If End Sub ``` 启动后可通过 `Command$` 读取参数： ```vb Private Sub Form_Load() ' 检查是否是开机自动启动 If InStr(Command$, "--autostart") > 0 Then ' 最小化到托盘 Me.WindowState = vbMinimized Me.Hide End If End Sub ``` --- --- url: /zh/vbman/startup/properties.md --- # cStartUp 属性参考 ## LastError 获取最后一次操作的错误信息。 ```vb Public LastError As String ``` ### 说明 当 `Toggle` 方法返回 `False` 时，可通过此属性获取详细的错误描述。 ### 示例 ```vb Private Sub MenuStartUp_Click() If VBMAN.StartUp.Toggle("my-app", App) Then VBMAN.Toast.Show "设置成功" Else ' 获取并显示错误信息 Dim ErrorMsg As String ErrorMsg = VBMAN.StartUp.LastError MsgBox "设置失败：" & ErrorMsg, vbCritical, "错误" End If End Sub ``` ### 常见错误 | 错误场景 | 可能的错误信息 | |----------|----------------| | 注册表操作失败 | 权限不足或注册表被锁定 | | 路径无效 | 指定的程序路径不存在 | *** ## 内部常量 组件内部使用的常量（无需直接使用）： ```vb Const K As String = "HKCU\Software\Microsoft\Windows\CurrentVersion\Run" ``` 这是 Windows 系统当前用户的启动项注册表位置。 --- --- url: /en/vbman/startup/overview.md --- # cStartUp Auto-start Management Component ## Overview `cStartUp` is an auto-start management component provided by the VBMAN framework, used to manage Windows system registry startup items. Supports adding, removing, and querying startup items with startup parameters. ## Features * **Toggle Mode** - Auto determines whether to add or remove startup item * **Parameter Support** - Can pass command line parameters to startup program * **Dual Path Mode** - Supports passing App object or string path * **Global Access** - Quick access via `VBMAN.StartUp` ## Quick Start ### Check Current Auto-start Status ```vb Private Sub Form_Load() ' Set menu check state MenuStartUp.Checked = VBMAN.StartUp.Has("my-app-name") End Sub ``` ### Toggle Auto-start ```vb Private Sub MenuStartUp_Click() ' Toggle auto-determines: add if not exists, remove if exists If VBMAN.StartUp.Toggle("my-app-name", App) = True Then ' Toggle successful, update menu state MenuStartUp.Checked = VBMAN.StartUp.Has("my-app-name") VBMAN.Toast.Show IIf(MenuStartUp.Checked, "Set auto-start success", "Cancel auto-start success") Else ' Toggle failed, show error VBMAN.Toast.Show "Auto-start setting failed: " & VBMAN.StartUp.LastError End If End Sub ``` ## Registry Location Component operates on the following Windows registry location: ``` HKCU\Software\Microsoft\Windows\CurrentVersion\Run ``` > Note: HKCU means current user, the set startup only applies to current user. ## Complete Example ```vb '=============================================== ' Auto-start Management Complete Example '=============================================== Private Sub Form_Load() ' Initialize menu state UpdateStartUpMenu() End Sub ' Click auto-start menu Private Sub MenuStartUp_Click() ToggleStartUp End Sub ' Toggle auto-start status Private Sub ToggleStartUp() Dim AppName As String AppName = "my-application" ' Method 1: Pass App object (recommended) If VBMAN.StartUp.Toggle(AppName, App) Then UpdateStartUpMenu() ShowToggleResult Else MsgBox "Setting failed: " & VBMAN.StartUp.LastError, vbCritical End If End Sub ' Update menu check state Private Sub UpdateStartUpMenu() MenuStartUp.Checked = VBMAN.StartUp.Has("my-application") End Sub ' Show toggle result Private Sub ShowToggleResult() If MenuStartUp.Checked Then VBMAN.Toast.Show "Added to auto-start" Else VBMAN.Toast.Show "Cancelled auto-start" End If End Sub ``` ## With Startup Parameters ```vb ' Toggle auto-start and pass startup parameters Private Sub MenuStartUp_Click() ' Parameter: minimize to tray after startup If VBMAN.StartUp.Toggle("my-app", App, "--minimized", "--autostart") Then Debug.Print "Auto-start setting successful" End If End Sub ``` After startup, parameters can be read via `Command$`: ```vb Private Sub Form_Load() ' Check if auto-started If InStr(Command$, "--autostart") > 0 Then ' Minimize to tray Me.WindowState = vbMinimized Me.Hide End If End Sub ``` --- --- url: /en/vbman/startup/methods.md --- # cStartUp Methods Reference ## Toggle Toggles auto-start item with specified name. Adds if not exists, removes if exists. ```vb Public Function Toggle( _ ByVal Name As String, _ ByRef Path As Variant, _ ParamArray StartArgs() As Variant _ ) As Boolean ``` ### Parameters | Parameter | Type | Description | |-----------|------|-------------| | `Name` | String | Startup item name (displayed in registry) | | `Path` | Variant | Program path, supports two formats: App object or string path | | `StartArgs` | Variant | Optional, startup parameter array (ParamArray) | ### Return Value * `True` - Toggle successful * `False` - Toggle failed, get error info via `LastError` ### Examples #### Pass App Object (Recommended) ```vb ' Auto extracts App.Path and App.EXEName VBMAN.StartUp.Toggle "MyApp", App ``` #### Pass String Path ```vb ' Specify full path directly VBMAN.StartUp.Toggle "MyApp", "C:\Program Files\MyApp\MyApp.exe" ``` #### With Startup Parameters ```vb ' Pass multiple startup parameters VBMAN.StartUp.Toggle "MyApp", App, "--minimized", "--start-in-tray" ``` #### Complete Usage Flow ```vb Private Sub MenuStartUp_Click() Dim Result As Boolean ' Toggle auto-start status Result = VBMAN.StartUp.Toggle("cs-auther-client", App) If Result Then ' Update menu check state MenuStartUp.Checked = VBMAN.StartUp.Has("cs-auther-client") ' Show hint If MenuStartUp.Checked Then VBMAN.Toast.Show "Set auto-start" Else VBMAN.Toast.Show "Cancelled auto-start" End If Else ' Show error MsgBox "Setting failed: " & VBMAN.StartUp.LastError, vbExclamation End If End Sub ``` *** ## Has Checks if specified startup item exists. ```vb Public Function Has(ByVal Name As String) As Boolean ``` ### Parameters | Parameter | Type | Description | |-----------|------|-------------| | `Name` | String | Startup item name | ### Return Value * `True` - Startup item exists * `False` - Startup item does not exist ### Examples ```vb ' Check if exists If VBMAN.StartUp.Has("MyApp") Then Debug.Print "Auto-start set" Else Debug.Print "Auto-start not set" End If ' Used to set menu check state MenuStartUp.Checked = VBMAN.StartUp.Has("MyApp") ``` *** ## Usage Mode Comparison | Scenario | Code Example | |----------|-------------| | **Add startup item** | `Toggle("App", App)` - Add if not exists | | **Remove startup item** | `Toggle("App", App)` - Remove if exists | | **Toggle startup item** | `Toggle("App", App)` - Auto toggle status | | **Check status** | `Has("App")` - Return boolean | ## Error Handling ```vb If Not VBMAN.StartUp.Toggle("MyApp", App) Then ' Handle error Dim ErrMsg As String ErrMsg = VBMAN.StartUp.LastError MsgBox "Auto-start setting failed: " & ErrMsg, vbCritical End If ``` --- --- url: /en/vbman/startup/properties.md --- # cStartUp Properties Reference ## LastError Gets error message from the last operation. ```vb Public LastError As String ``` ### Description When `Toggle` method returns `False`, detailed error description can be obtained via this property. ### Examples ```vb Private Sub MenuStartUp_Click() If VBMAN.StartUp.Toggle("my-app", App) Then VBMAN.Toast.Show "Setting successful" Else ' Get and show error message Dim ErrorMsg As String ErrorMsg = VBMAN.StartUp.LastError MsgBox "Setting failed: " & ErrorMsg, vbCritical, "Error" End If End Sub ``` ### Common Errors | Error Scenario | Possible Error Message | |---------------|----------------------| | Registry operation failed | Insufficient permissions or registry locked | | Invalid path | Specified program path does not exist | *** ## Internal Constants Constants used internally by component (no need to use directly): ```vb Const K As String = "HKCU\Software\Microsoft\Windows\CurrentVersion\Run" ``` This is the Windows system current user's startup item registry location. --- --- url: /zh/vbman/stdio/overview.md --- # cStdIO 标准输入输出组件 ## 概述 `cStdIO` 是 VBMAN 框架提供的命令行执行组件，用于在 VB6 中执行外部命令行程序并捕获其标准输出。支持超时控制、工作目录设置和进程退出码获取。 ## 特性 * **捕获输出** - 完整捕获命令行的标准输出（STDOUT） * **隐藏窗口** - 后台执行，不显示命令行窗口 * **超时控制** - 可设置执行超时时间，防止进程卡死 * **工作目录** - 支持指定命令执行的工作目录 * **退出码获取** - 获取进程退出代码，判断执行结果 ## 快速开始 ### 简单执行命令 ```vb Dim StdIO As New cStdIO Dim Output As String Dim ExitCode As Long ' 执行命令并获取输出 Output = StdIO.ExecuteCommand("ipconfig /all", 5000, "", ExitCode) Debug.Print "输出：" & Output Debug.Print "退出码：" & ExitCode ``` ### 执行并检查退出码 ```vb Private Sub RunGitStatus() Dim StdIO As New cStdIO Dim Result As String Dim ExitCode As Long Result = StdIO.ExecuteCommand("git status", 10000, "D:\\MyProject", ExitCode) If ExitCode = 0 Then Debug.Print "Git 状态：" & vbCrLf & Result Else Debug.Print "命令执行失败，退出码：" & ExitCode End If End Sub ``` ### 超时处理 ```vb Private Sub RunWithTimeout() Dim StdIO As New cStdIO Dim Result As String Dim ExitCode As Long On Error GoTo ErrorHandler ' 设置 5 秒超时 Result = StdIO.ExecuteCommand("long-running-task.exe", 5000, "", ExitCode) Debug.Print Result Exit Sub ErrorHandler: If InStr(Err.Description, "执行超时") > 0 Then MsgBox "命令执行超时！", vbExclamation End If End Sub ``` ## 典型应用场景 | 场景 | 示例命令 | |------|----------| | **系统信息** | `ipconfig /all`, `systeminfo` | | **Git 操作** | `git status`, `git log --oneline` | | **文件操作** | `dir /s`, `findstr "keyword" *.txt` | | **网络检测** | `ping 8.8.8.8`, `tracert baidu.com` | | **编译构建** | `msbuild MyProject.sln` | ## 注意事项 1. **超时时间** - 单位为毫秒，默认 10 秒 2. **窗口隐藏** - 命令行窗口自动隐藏，后台执行 3. **编码问题** - 输出文本编码取决于系统默认编码 4. **大数据量** - 输出内容过大时可能占用较多内存 --- --- url: /zh/vbman/stdio/methods.md --- # cStdIO 方法参考 ## ExecuteCommand 执行命令行程序并捕获其标准输出。 ```vb Public Function ExecuteCommand( _ ByVal CommandLine As String, _ Optional ByVal TimeoutMs As Long = 10000, _ Optional ByVal CurrentDirectory As String = "", _ Optional ByRef exitCode As Long _ ) As String ``` ### 参数 | 参数名 | 类型 | 默认值 | 说明 | |--------|------|--------|------| | `CommandLine` | String | - | 要执行的命令行（包含程序路径和参数） | | `TimeoutMs` | Long | 10000 | 超时时间（毫秒），默认 10 秒 | | `CurrentDirectory` | String | "" | 工作目录，空字符串表示使用当前目录 | | `exitCode` | Long | - | 传出参数，进程退出代码 | ### 返回值 * **成功** - 返回命令行的标准输出文本 * **失败** - 返回错误描述字符串（以 "STDIO ERROR:" 开头） ### 错误码 通过 `exitCode` 参数返回的错误码： | 错误码 | 常量 | 说明 | |--------|------|------| | 0 | `ERROR_OK` | 执行成功 | | 1 | `ERROR_CREATE_PIPE` | 创建管道失败 | | 2 | `ERROR_DUPLICATE_HANDLE` | 复制句柄失败 | | 3 | `ERROR_CREATE_PROCESS` | 创建进程失败 | | 4 | `ERROR_READ_OUTPUT` | 读取输出失败 | | 5 | `ERROR_PROCESS_TIMEOUT` | 执行超时 | ### 示例 #### 基本用法 ```vb Dim StdIO As New cStdIO Dim Output As String Dim ExitCode As Long Output = StdIO.ExecuteCommand("echo Hello World", 5000, "", ExitCode) Debug.Print Output ' 输出: Hello World ``` #### 带参数的命令 ```vb Dim StdIO As New cStdIO Dim Output As String Dim ExitCode As Long ' 执行带参数的命令 Output = StdIO.ExecuteCommand( _ "findstr /s /i ""keyword"" *.txt", _ 10000, _ "C:\\Documents", _ ExitCode _ ) If ExitCode = 0 Then Debug.Print "找到匹配：" & Output Else Debug.Print "未找到匹配" End If ``` #### 完整错误处理 ```vb Private Sub ExecuteSafe() Dim StdIO As New cStdIO Dim Result As String Dim ExitCode As Long On Error GoTo ErrorHandler Result = StdIO.ExecuteCommand("mycommand.exe", 5000, "", ExitCode) ' 检查是否返回错误字符串 If Left$(Result, 11) = "STDIO ERROR" Then MsgBox "执行错误：" & Result, vbCritical Exit Sub End If ' 检查退出码 Select Case ExitCode Case 0 Debug.Print "执行成功：" & Result Case 1 Debug.Print "命令返回错误：" & Result Case 5 MsgBox "执行超时！", vbExclamation Case Else Debug.Print "未知错误，退出码：" & ExitCode End Select Exit Sub ErrorHandler: MsgBox "发生异常：" & Err.Description, vbCritical End Sub ``` #### 指定工作目录 ```vb Private Sub RunInDirectory() Dim StdIO As New cStdIO Dim Output As String Dim ExitCode As Long ' 在指定目录下执行 git 命令 Output = StdIO.ExecuteCommand( _ "git log --oneline -10", _ 10000, _ "D:\\Projects\\MyRepo", _ ExitCode _ ) If ExitCode = 0 Then txtLog.Text = Output End If End Sub ``` --- --- url: /zh/vbman/stdio/examples.md --- # cStdIO 使用示例 ## 示例 1：获取系统信息 ```vb Private Sub GetSystemInfo() Dim StdIO As New cStdIO Dim Output As String Dim ExitCode As Long ' 获取网络配置 Output = StdIO.ExecuteCommand("ipconfig /all", 10000, "", ExitCode) If ExitCode = 0 Then txtOutput.Text = Output Else MsgBox "获取网络信息失败" End If End Sub ``` ## 示例 2：Git 操作 ```vb Private Sub CheckGitStatus() Dim StdIO As New cStdIO Dim Result As String Dim ExitCode As Long ' 检查 Git 状态 Result = StdIO.ExecuteCommand("git status", 5000, txtProjectPath.Text, ExitCode) If ExitCode = 0 Then ' 解析状态输出 If InStr(Result, "nothing to commit") > 0 Then lblStatus.Caption = "工作区干净" Else lblStatus.Caption = "有未提交的更改" End If txtDetails.Text = Result Else MsgBox "Git 命令执行失败" End If End Sub ``` ## 示例 3：批量处理文件 ```vb Private Sub BatchConvertFiles() Dim StdIO As New cStdIO Dim FileList As String Dim ExitCode As Long Dim Files() As String Dim i As Integer ' 获取文件列表 FileList = StdIO.ExecuteCommand("dir /b *.txt", 5000, txtFolder.Text, ExitCode) If ExitCode = 0 And Len(FileList) > 0 Then Files = Split(FileList, vbCrLf) For i = LBound(Files) To UBound(Files) If Len(Files(i)) > 0 Then ' 处理每个文件 ProcessFile txtFolder.Text & "\" & Files(i) End If Next i End If End Sub ``` ## 示例 4：网络检测 ```vb Private Sub PingHost() Dim StdIO As New cStdIO Dim Host As String Dim Result As String Dim ExitCode As Long Host = txtHost.Text ' 执行 ping 命令 Result = StdIO.ExecuteCommand("ping -n 4 " & Host, 20000, "", ExitCode) txtResult.Text = Result ' 解析结果 If InStr(Result, "Reply from") > 0 Then lblStatus.Caption = "主机可连接" lblStatus.ForeColor = vbGreen Else lblStatus.Caption = "主机不可达" lblStatus.ForeColor = vbRed End If End Sub ``` ## 示例 5：执行带超时的任务 ```vb Private Sub RunWithTimeoutControl() Dim StdIO As New cStdIO Dim Result As String Dim ExitCode As Long Dim StartTime As Long StartTime = Timer On Error GoTo TimeoutHandler ' 执行可能耗时的任务（30秒超时） Result = StdIO.ExecuteCommand("data-processing.exe", 30000, "", ExitCode) If ExitCode = 0 Then MsgBox "处理完成，耗时：" & (Timer - StartTime) & "秒" txtOutput.Text = Result End If Exit Sub TimeoutHandler: If Err.Number = 5 Then ' 假设超时错误号为 5 MsgBox "任务执行超时（超过30秒）！", vbExclamation Else MsgBox "执行出错：" & Err.Description, vbCritical End If End Sub ``` ## 示例 6：命令行工具封装 ```vb ' 封装 FFmpeg 调用 Private Function RunFFmpeg(InputFile As String, OutputFile As String) As Boolean Dim StdIO As New cStdIO Dim Command As String Dim Output As String Dim ExitCode As Long ' 构建命令 Command = "ffmpeg -i """ & InputFile & """ """ & OutputFile & """ ' 执行（60秒超时） Output = StdIO.ExecuteCommand(Command, 60000, "", ExitCode) ' 判断是否成功 RunFFmpeg = (ExitCode = 0) If Not RunFFmpeg Then Debug.Print "FFmpeg 错误：" & Output End If End Function ``` --- --- url: /en/vbman/stdio/methods.md --- # cStdIO Methods Reference ## ExecuteCommand Executes command line program and captures its standard output. ```vb Public Function ExecuteCommand( _ ByVal CommandLine As String, _ Optional ByVal TimeoutMs As Long = 10000, _ Optional ByVal CurrentDirectory As String = "", _ Optional ByRef exitCode As Long _ ) As String ``` ### Parameters | Parameter | Type | Default | Description | |-----------|------|---------|-------------| | `CommandLine` | String | - | Command line to execute (includes program path and arguments) | | `TimeoutMs` | Long | 10000 | Timeout (milliseconds), default 10 seconds | | `CurrentDirectory` | String | "" | Working directory, empty string means use current directory | | `exitCode` | Long | - | Output parameter, process exit code | ### Return Value * **Success** - Returns command line standard output text * **Failure** - Returns error description string (starting with "STDIO ERROR:") ### Error Codes Error codes returned via `exitCode` parameter: | Error Code | Constant | Description | |------------|---------|-------------| | 0 | `ERROR_OK` | Execution successful | | 1 | `ERROR_CREATE_PIPE` | Failed to create pipe | | 2 | `ERROR_DUPLICATE_HANDLE` | Failed to duplicate handle | | 3 | `ERROR_CREATE_PROCESS` | Failed to create process | | 4 | `ERROR_READ_OUTPUT` | Failed to read output | | 5 | `ERROR_PROCESS_TIMEOUT` | Execution timeout | ### Examples #### Basic Usage ```vb Dim StdIO As New cStdIO Dim Output As String Dim ExitCode As Long Output = StdIO.ExecuteCommand("echo Hello World", 5000, "", ExitCode) Debug.Print Output ' Output: Hello World ``` #### Command with Arguments ```vb Dim StdIO As New cStdIO Dim Output As String Dim ExitCode As Long ' Execute command with arguments Output = StdIO.ExecuteCommand( _ "findstr /s /i ""keyword"" *.txt", _ 10000, _ "C:\\Documents", _ ExitCode _ ) If ExitCode = 0 Then Debug.Print "Found match: " & Output Else Debug.Print "No match found" End If ``` #### Complete Error Handling ```vb Private Sub ExecuteSafe() Dim StdIO As New cStdIO Dim Result As String Dim ExitCode As Long On Error GoTo ErrorHandler Result = StdIO.ExecuteCommand("mycommand.exe", 5000, "", ExitCode) ' Check if returns error string If Left$(Result, 11) = "STDIO ERROR" Then MsgBox "Execution error: " & Result, vbCritical Exit Sub End If ' Check exit code Select Case ExitCode Case 0 Debug.Print "Execution successful: " & Result Case 1 Debug.Print "Command returned error: " & Result Case 5 MsgBox "Execution timeout!", vbExclamation Case Else Debug.Print "Unknown error, exit code: " & ExitCode End Select Exit Sub ErrorHandler: MsgBox "Exception occurred: " & Err.Description, vbCritical End Sub ``` #### Specify Working Directory ```vb Private Sub RunInDirectory() Dim StdIO As New cStdIO Dim Output As String Dim ExitCode As Long ' Execute git command in specified directory Output = StdIO.ExecuteCommand( _ "git log --oneline -10", _ 10000, _ "D:\\Projects\\MyRepo", _ ExitCode _ ) If ExitCode = 0 Then txtLog.Text = Output End If End Sub ``` --- --- url: /en/vbman/stdio/overview.md --- # cStdIO Standard Input/Output Component ## Overview `cStdIO` is a command-line execution component provided by the VBMAN framework, used to execute external command-line programs in VB6 and capture their standard output. Supports timeout control, working directory setting, and process exit code retrieval. ## Features * **Capture Output** - Fully capture command line standard output (STDOUT) * **Hide Window** - Execute in background, no command line window shown * **Timeout Control** - Can set execution timeout to prevent process deadlock * **Working Directory** - Supports specifying working directory for command execution * **Exit Code Retrieval** - Get process exit code to determine execution result ## Quick Start ### Simple Command Execution ```vb Dim StdIO As New cStdIO Dim Output As String Dim ExitCode As Long ' Execute command and get output Output = StdIO.ExecuteCommand("ipconfig /all", 5000, "", ExitCode) Debug.Print "Output: " & Output Debug.Print "Exit code: " & ExitCode ``` ### Execute and Check Exit Code ```vb Private Sub RunGitStatus() Dim StdIO As New cStdIO Dim Result As String Dim ExitCode As Long Result = StdIO.ExecuteCommand("git status", 10000, "D:\\MyProject", ExitCode) If ExitCode = 0 Then Debug.Print "Git status: " & vbCrLf & Result Else Debug.Print "Command execution failed, exit code: " & ExitCode End If End Sub ``` ### Timeout Handling ```vb Private Sub RunWithTimeout() Dim StdIO As New cStdIO Dim Result As String Dim ExitCode As Long On Error GoTo ErrorHandler ' Set 5 second timeout Result = StdIO.ExecuteCommand("long-running-task.exe", 5000, "", ExitCode) Debug.Print Result Exit Sub ErrorHandler: If InStr(Err.Description, "timeout") > 0 Then MsgBox "Command execution timeout!", vbExclamation End If End Sub ``` ## Typical Use Cases | Scenario | Example Command | |----------|----------------| | **System Info** | `ipconfig /all`, `systeminfo` | | **Git Operations** | `git status`, `git log --oneline` | | **File Operations** | `dir /s`, `findstr "keyword" *.txt` | | **Network Test** | `ping 8.8.8.8`, `tracert baidu.com` | | **Build** | `msbuild MyProject.sln` | ## Notes 1. **Timeout** - Unit is milliseconds, default 10 seconds 2. **Hide Window** - Command line window auto hidden, background execution 3. **Encoding Issue** - Output text encoding depends on system default encoding 4. **Large Data** - Large output may occupy more memory --- --- url: /en/vbman/stdio/examples.md --- # cStdIO Usage Examples ## Example 1: Get System Info ```vb Private Sub GetSystemInfo() Dim StdIO As New cStdIO Dim Output As String Dim ExitCode As Long ' Get network configuration Output = StdIO.ExecuteCommand("ipconfig /all", 10000, "", ExitCode) If ExitCode = 0 Then txtOutput.Text = Output Else MsgBox "Failed to get network info" End If End Sub ``` ## Example 2: Git Operations ```vb Private Sub CheckGitStatus() Dim StdIO As New cStdIO Dim Result As String Dim ExitCode As Long ' Check Git status Result = StdIO.ExecuteCommand("git status", 5000, txtProjectPath.Text, ExitCode) If ExitCode = 0 Then ' Parse status output If InStr(Result, "nothing to commit") > 0 Then lblStatus.Caption = "Working directory clean" Else lblStatus.Caption = "Uncommitted changes" End If txtDetails.Text = Result Else MsgBox "Git command execution failed" End If End Sub ``` ## Example 3: Batch Process Files ```vb Private Sub BatchConvertFiles() Dim StdIO As New cStdIO Dim FileList As String Dim ExitCode As Long Dim Files() As String Dim i As Integer ' Get file list FileList = StdIO.ExecuteCommand("dir /b *.txt", 5000, txtFolder.Text, ExitCode) If ExitCode = 0 And Len(FileList) > 0 Then Files = Split(FileList, vbCrLf) For i = LBound(Files) To UBound(Files) If Len(Files(i)) > 0 Then ' Process each file ProcessFile txtFolder.Text & "\" & Files(i) End If Next i End If End Sub ``` ## Example 4: Network Test ```vb Private Sub PingHost() Dim StdIO As New cStdIO Dim Host As String Dim Result As String Dim ExitCode As Long Host = txtHost.Text ' Execute ping command Result = StdIO.ExecuteCommand("ping -n 4 " & Host, 20000, "", ExitCode) txtResult.Text = Result ' Parse result If InStr(Result, "Reply from") > 0 Then lblStatus.Caption = "Host reachable" lblStatus.ForeColor = vbGreen Else lblStatus.Caption = "Host unreachable" lblStatus.ForeColor = vbRed End If End Sub ``` ## Example 5: Execute Task with Timeout ```vb Private Sub RunWithTimeoutControl() Dim StdIO As New cStdIO Dim Result As String Dim ExitCode As Long Dim StartTime As Long StartTime = Timer On Error GoTo TimeoutHandler ' Execute potentially time-consuming task (30 second timeout) Result = StdIO.ExecuteCommand("data-processing.exe", 30000, "", ExitCode) If ExitCode = 0 Then MsgBox "Processing complete, time: " & (Timer - StartTime) & " seconds" txtOutput.Text = Result End If Exit Sub TimeoutHandler: If Err.Number = 5 Then ' Assume timeout error number is 5 MsgBox "Task execution timeout (over 30 seconds)!", vbExclamation Else MsgBox "Execution error: " & Err.Description, vbCritical End If End Sub ``` ## Example 6: Command Line Tool Wrapper ```vb ' Wrapper for FFmpeg call Private Function RunFFmpeg(InputFile As String, OutputFile As String) As Boolean Dim StdIO As New cStdIO Dim Command As String Dim Output As String Dim ExitCode As Long ' Build command Command = "ffmpeg -i """ & InputFile & """ """ & OutputFile & """ ' Execute (60 second timeout) Output = StdIO.ExecuteCommand(Command, 60000, "", ExitCode) ' Determine if successful RunFFmpeg = (ExitCode = 0) If Not RunFFmpeg Then Debug.Print "FFmpeg error: " & Output End If End Function ``` --- --- url: /zh/vbman/Toast.md --- # cToast 消息提示组件 cToast 是 VBMan 框架中用于显示消息提示弹窗的核心类，提供简洁优雅的消息提示解决方案。 ## ✨ 核心特性 * 🎯 **9种显示位置**：支持屏幕居中、四角、四中等9个方位 * 🎨 **4种状态主题**：信息、成功、警告、危险 * 🌓 **2种颜色主题**：浅色、深色 * 📦 **智能堆叠**：自动顺序堆叠或倒序堆叠 * 🖱️ **鼠标悬停暂停**：悬停时暂停倒计时，移开后恢复 * 🎭 **无焦点窗口**：不影响用户当前操作 ![VBMAN Toast](/images/vbman/toast/demo2.png) ## 🚀 快速开始 ### 全局单例（最简使用） VBMAN 框架提供了全局单例对象，可以在任何地方免New调用： ```vb ' 全局单例 - 在任何地方直接调用 VBMAN.Toast.Show "你好，来自任何地方的问候" ``` 这是最简单的使用方式，无需创建实例，适合快速提示。 ### 最简使用 ```vb ' 默认居中显示 With New cToast .Show "操作成功！" End With ``` ### 链式调用 ```vb ' 右上角显示成功提示 With New cToast .Pos(RightTop).State(Success).Show "保存成功", 2000, "提示" End With ``` ### 自动堆叠 ```vb ' 右上角自动堆叠多条消息 With New cToast .Pos(RightTop) .State(Success).Show "第一条", 0 .State(Warning).Show "第二条", 0 .State(Info).Show "第三条", 0 End With ``` ## 📚 文档导航 * [API 参考](./api.md) - 完整的 API 方法、属性和事件说明 * [使用示例](./examples.md) - 各种使用场景的示例代码 * [技术细节](./technical.md) - 内部实现原理和技术细节 * [常见问题](./faq.md) - 常见问题解答 ## 🎯 基本概念 ### 显示位置 cToast 支持9种预设显示位置： ```vb ' 左侧系列 LeftTop ' 左上（堆叠） LeftCenter ' 左中（覆盖） LeftBottom ' 左下（堆叠） ' 中间系列 CenterTop ' 居上（顺序堆叠） Center ' 居中（覆盖） CenterBottom ' 居下（倒序堆叠） ' 右侧系列 RightTop ' 右上（堆叠） RightCenter ' 右中（覆盖） RightBottom ' 右下（堆叠） ``` ### 状态主题 ```vb Info ' 信息（蓝色） Success ' 成功（绿色） Warning ' 警告（黄色） Danger ' 危险（红色） ``` ### 颜色主题 ```vb Light ' 浅色主题（默认） Dark ' 深色主题 ``` ## 💡 常用模式 ### 1. 简单提示 ```vb ' 信息提示 With New cToast .Show "这是一条信息提示" End With ' 成功提示 With New cToast .State(Success).Show "操作成功！" End With ' 错误提示 With New cToast .State(Danger).Show "操作失败，请重试" End With ``` ### 2. 持久显示（不自动关闭） ```vb With New cToast .Pos(RightBottom).Show "重要通知：服务器将在今晚22:00进行维护", 0, "系统通知" End With ``` ### 3. 命名管理 ```vb Dim Toast As New cToast ' 为弹窗命名 Toast.Tag("msg1").Pos(RightTop).Show "消息1", 0 ' 单独关闭指定弹窗 Toast.CloseMe "msg1" ``` ### 4. 批量管理 ```vb Dim Toast As New cToast ' 显示多个弹窗 Toast.Pos(RightTop).State(Success).Show "成功1", 0 Toast.Pos(RightTop).State(Warning).Show "警告1", 0 ' 检查数量 Debug.Print "当前弹窗数：" & Toast.Count ' 关闭所有弹窗 Toast.CloseAll ``` ## 🎪 窗体类型 cToast 内部使用两种不同的窗体实现： | 窗体类型 | 使用位置 | 特点 | | ------------ | ------------------------------- | ------------------------------------- | | FToastCenter | Center, CenterTop, CenterBottom | 居中显示，底部颜色条 | | FToastDrawer | 其他6个位置 | 侧边抽屉风格，侧边颜色条 + 标题和内容 | ## 🎨 预览效果 ### FToastCenter（居中弹窗） * 简洁的居中显示 * 底部状态颜色条 * 适合重要提示和确认信息 ### FToastDrawer（侧边弹窗） * 左侧或右侧显示 * 侧边状态颜色条 * 包含标题和内容两行 * 适合多条消息堆叠 ## 🔗 相关资源 * **源码位置**：`vbman/src/Toast/` * **演示程序**：`vbman-demo/demos/Toast/` * **依赖组件**：`cShadow`（阴影效果） ## 📝 注意事项 1. **居中位置不支持堆叠**：Center、LeftCenter、RightCenter 位置调用 InstIndex 无效 2. **Tag 唯一性**：相同 TagName 的弹窗不会重复创建 3. **自动堆叠**：未手动调用 InstIndex 时，系统会自动堆叠 4. **鼠标悬停**：悬停时会暂停倒计时，移开后恢复 5. **资源释放**：窗体卸载时会自动从集合中移除 ## 🤝 社区支持 * 💬 **QQ交流群**：915520648 [点击这里加群](http://qm.qq.com/cgi-bin/qm/qr?_wv=1027\&k=maQtC3a5Zxb3gMLvwpj6oE5fwmZGCOlY\&authKey=8%2FhBgSMLqADLatzXghFXO5BIBa%2BxSoHO%2FHFvtbZQk2kURUx%2FegxZukzAvhSPX6WJ\&noverify=0\&group_code=915520648) --- --- url: /en/vbman/Toast.md --- # cToast Notification Component cToast is the core class in the VBMan framework for displaying message notification popups, providing a simple and elegant solution for message notifications. ## ✨ Core Features * 🎯 **9 Display Positions**: Support for center, four corners, four midpoints, and 9 different positions on screen * 🎨 **4 State Themes**: Info, Success, Warning, Danger * 🌓 **2 Color Themes**: Light, Dark * 📦 **Smart Stacking**: Automatic sequential stacking or reverse stacking * 🖱️ **Mouse Hover Pause**: Pause countdown on hover, resume on move away * 🎭 **Non-focus Window**: Does not affect user's current operations ![VBMAN Toast](/images/vbman/toast/demo2.png) ## 🚀 Quick Start ### Global Singleton (Simplest Usage) The VBMAN framework provides a global singleton object that can be called from anywhere without New: ```vb ' Global singleton - call directly from anywhere VBMAN.Toast.Show "Hello, greetings from anywhere" ``` This is the simplest way to use, no instance creation needed, perfect for quick notifications. ### Simplest Usage ```vb ' Default center display With New cToast .Show "Operation successful!" End With ``` ### Chain Call ```vb ' Display success notification in top-right corner With New cToast .Pos(RightTop).State(Success).Show "Saved successfully", 2000, "Notification" End With ``` ### Auto Stacking ```vb ' Auto stack multiple messages in top-right corner With New cToast .Pos(RightTop) .State(Success).Show "First message", 0 .State(Warning).Show "Second message", 0 .State(Info).Show "Third message", 0 End With ``` ## 📚 Documentation Navigation * [API Reference](./api.md) - Complete API methods, properties, and events documentation * [Examples](./examples.md) - Example code for various usage scenarios * [Technical Details](./technical.md) - Internal implementation principles and technical details * [FAQ](./faq.md) - Frequently Asked Questions ## 🎯 Basic Concepts ### Display Positions cToast supports 9 preset display positions: ```vb ' Left series LeftTop ' Top-left (stacking) LeftCenter ' Left-center (overlay) LeftBottom ' Bottom-left (stacking) ' Center series CenterTop ' Top-center (sequential stacking) Center ' Center (overlay) CenterBottom ' Bottom-center (reverse stacking) ' Right series RightTop ' Top-right (stacking) RightCenter ' Right-center (overlay) RightBottom ' Bottom-right (stacking) ``` ### State Themes ```vb Info ' Information (blue) Success ' Success (green) Warning ' Warning (yellow) Danger ' Danger (red) ``` ### Color Themes ```vb Light ' Light theme (default) Dark ' Dark theme ``` ## 💡 Common Patterns ### 1. Simple Notification ```vb ' Information notification With New cToast .Show "This is an information message" End With ' Success notification With New cToast .State(Success).Show "Operation successful!" End With ' Error notification With New cToast .State(Danger).Show "Operation failed, please try again" End With ``` ### 2. Persistent Display (No Auto Close) ```vb With New cToast .Pos(RightBottom).Show "Important Notice: Server maintenance scheduled for tonight 22:00", 0, "System Notification" End With ``` ### 3. Named Management ```vb Dim Toast As New cToast ' Name the popup Toast.Tag("msg1").Pos(RightTop).Show "Message 1", 0 ' Close specific popup by name Toast.CloseMe "msg1" ``` ### 4. Batch Management ```vb Dim Toast As New cToast ' Display multiple popups Toast.Pos(RightTop).State(Success).Show "Success 1", 0 Toast.Pos(RightTop).State(Warning).Show "Warning 1", 0 ' Check count Debug.Print "Current popups: " & Toast.Count ' Close all popups Toast.CloseAll ``` ## 🎪 Form Types cToast internally uses two different form implementations: | Form Type | Used Position | Features | | ------------ | ------------------------------- | ----------------------------------------------------- | | FToastCenter | Center, CenterTop, CenterBottom | Center display, bottom color bar | | FToastDrawer | Other 6 positions | Side drawer style, side color bar + title and content | ## 🎨 Preview Effects ### FToastCenter (Center Popup) * Clean center display * Bottom status color bar * Suitable for important notifications and confirmations ### FToastDrawer (Side Popup) * Left or right side display * Side status color bar * Contains title and content lines * Suitable for stacking multiple messages ## 🔗 Related Resources * **Source Location**: `vbman/src/Toast/` * **Demo Program**: `vbman-demo/demos/Toast/` * **Dependency Component**: `cShadow` (Shadow effect) ## 📝 Notes 1. **Center Position Does Not Support Stacking**: Calling InstIndex on Center, LeftCenter, RightCenter positions has no effect 2. **Tag Uniqueness**: Popups with the same TagName will not be created repeatedly 3. **Auto Stacking**: When InstIndex is not manually called, the system will automatically stack 4. **Mouse Hover**: Countdown pauses on hover, resumes after moving away 5. **Resource Release**: Forms are automatically removed from the collection when unloaded ## 🤝 Community Support * 💬 **QQ Group**: 915520648 [Click to join](http://qm.qq.com/cgi-bin/qm/qr?_wv=1027\&k=maQtC3a5Zxb3gMLvwpj6oE5fwmZGCOlY\&authKey=8%2FhBgSMLqADLatzXghFXO5BIBa%2BxSoHO%2FHFvtbZQk2kURUx%2FegxZukzAvhSPX6WJ\&noverify=0\&group_code=915520648) --- --- url: /zh/vbman/tools/fso/cToolsFso.md --- # cToolsFso 类 文件系统操作工具类，提供路径处理、目录管理等常用功能。 ## 说明 `cToolsFso` 是对 `Scripting.FileSystemObject` 的封装，提供更便捷的文件路径处理和目录操作功能。内部通过 `Inst` 属性暴露原始的 FSO 对象，方便进行高级操作。 **引用库：** * `Microsoft Scripting Runtime` (scrrun.dll) *** ## 属性 | 属性名 | 类型 | 说明 | |--------|------|------| | `Inst` | `Scripting.FileSystemObject` | FSO 实例对象，可直接访问原始 FSO 方法 | *** ## 方法 ### IsFullPath 判断路径是否为完整路径（包含盘符）。 **语法：** ```vb Public Function IsFullPath(Path As String) As Boolean ``` **参数：** | 参数 | 类型 | 说明 | |------|------|------| | `Path` | `String` | 要检查的路径 | **返回值：** * `True` - 是完整路径（包含 `:\`） * `False` - 是相对路径 **示例：** ```vb Dim Fso As New cToolsFso Debug.Print Fso.IsFullPath("C:\Windows\System32") ' True Debug.Print Fso.IsFullPath("..\data\file.txt") ' False Debug.Print Fso.IsFullPath("data\file.txt") ' False ``` *** ### AutoCompleteFullPath 自动补全为完整路径，支持相对路径转绝对路径。 **语法：** ```vb Public Function AutoCompleteFullPath(Path As String, Optional IsFile As Boolean) As String ``` **参数：** | 参数 | 类型 | 说明 | |------|------|------| | `Path` | `String` | 原始路径 | | `IsFile` | `Boolean` | 可选。是否为文件路径（影响末尾斜杠处理） | **返回值：** * 完整路径字符串 **说明：** * 如果路径已是完整路径，则直接返回 * 如果是相对路径，则在前面追加 `App.Path` * 自动清理路径中的多余斜杠 **示例：** ```vb Dim Fso As New cToolsFso ' 相对路径转绝对路径 Debug.Print Fso.AutoCompleteFullPath("data\config.ini") ' 输出: C:\Program Files\MyApp\data\config.ini ' 已是完整路径则保持不变 Debug.Print Fso.AutoCompleteFullPath("D:\\backup\\data.txt") ' 输出: D:\backup\data.txt ``` *** ### ClearSpan 清理路径中的斜杠，统一为反斜杠格式。 **语法：** ```vb Public Function ClearSpan(Path As String, Optional IsFile As Boolean) As String ``` **参数：** | 参数 | 类型 | 说明 | |------|------|------| | `Path` | `String` | 要清理的路径 | | `IsFile` | `Boolean` | 可选。是否为文件路径（目录会自动添加末尾斜杠） | **返回值：** * 清理后的路径字符串 **说明：** * 将 `//`、`\/`、`/` 统一替换为 `\` * 如果是目录路径，自动在末尾添加 `\` **示例：** ```vb Dim Fso As New cToolsFso ' 统一斜杠格式 Debug.Print Fso.ClearSpan("C://Windows\\System32//file.txt", True) ' 输出: C:\Windows\System32\file.txt ' 目录路径自动添加末尾斜杠 Debug.Print Fso.ClearSpan("C:\\Windows\\System32", False) ' 输出: C:\Windows\System32\ ``` *** ### AutoMakeDir 自动创建目录（如果不存在）。 **语法：** ```vb Public Function AutoMakeDir(ByVal Path As String, Optional IsFile As Boolean) As String ``` **参数：** | 参数 | 类型 | 说明 | |------|------|------| | `Path` | `String` | 目录路径或文件路径 | | `IsFile` | `Boolean` | 可选。如果为 True，则自动提取父目录创建 | **返回值：** * 创建的目录路径（已清理格式） **说明：** * 使用 Windows API `MakeSureDirectoryPathExists` 创建目录 * 支持多级目录创建 * 目录已存在时不会报错 **示例：** ```vb Dim Fso As New cToolsFso ' 创建目录 Dim DirPath As String DirPath = Fso.AutoMakeDir("C:\\MyApp\\Data\\Logs", False) Debug.Print "已创建目录: " & DirPath ' 从文件路径中提取并创建目录 DirPath = Fso.AutoMakeDir("C:\\MyApp\\Data\\file.txt", True) ' 会创建 C:\MyApp\Data 目录 ``` *** ### AppPath 获取应用程序路径（根据运行模式自动调整）。 **语法：** ```vb Public Function AppPath(Optional ByVal Path As String) As String ``` **参数：** | 参数 | 类型 | 说明 | |------|------|------| | `Path` | `String` | 可选。要追加的子路径 | **返回值：** * 应用程序路径字符串 **说明：** * IDE 模式（`App.LogMode = 0`）：返回 `App.Path\..\dist\EXE\` * 编译模式：返回 `App.Path\` **示例：** ```vb Dim Fso As New cToolsFso ' 获取应用路径 Debug.Print Fso.AppPath() ' 获取应用路径下的子目录 Debug.Print Fso.AppPath("data\config.ini") ``` *** ### MakeNewFileFulPath 生成新的文件名（添加后缀）。 **语法：** ```vb Public Function MakeNewFileFulPath(FileSrc As String, AppendFix As String, Optional JoinStr As String = "_") As String ``` **参数：** | 参数 | 类型 | 说明 | |------|------|------| | `FileSrc` | `String` | 原始文件路径 | | `AppendFix` | `String` | 要添加的后缀 | | `JoinStr` | `String` | 可选。连接符，默认为 `_` | **返回值：** * 新的文件名（不含路径） **说明：** * 保留原文件扩展名 * 在文件名和扩展名之间插入连接符和后缀 **示例：** ```vb Dim Fso As New cToolsFso ' 生成备份文件名 Debug.Print Fso.MakeNewFileFulPath("C:\\data\\document.txt", "backup") ' 输出: document_backup.txt ' 使用自定义连接符 Debug.Print Fso.MakeNewFileFulPath("photo.jpg", "2024", "-") ' 输出: photo-2024.jpg ``` *** ## 使用示例 ### 综合示例：文件备份 ```vb Sub BackupFileExample() Dim Fso As New cToolsFso Dim SrcFile As String Dim BackupDir As String Dim BackupFile As String ' 源文件 SrcFile = "C:\\MyApp\\data\\important.dat" ' 确保备份目录存在 BackupDir = Fso.AutoMakeDir("C:\\MyApp\\backup\\", False) ' 生成备份文件名 BackupFile = BackupDir & Fso.MakeNewFileFulPath(SrcFile, Format(Now, "yyyymmdd")) ' 使用 FSO 复制文件 Fso.Inst.CopyFile SrcFile, BackupFile, True Debug.Print "备份完成: " & BackupFile End Sub ``` ### 综合示例：遍历目录 ```vb Sub ListDirectoryExample() Dim Fso As New cToolsFso Dim Folder As Scripting.Folder Dim SubFolder As Scripting.Folder Dim File As Scripting.File ' 获取目录对象 Set Folder = Fso.Inst.GetFolder("C:\\Windows") ' 遍历子目录 Debug.Print "=== 子目录 ===" For Each SubFolder In Folder.SubFolders Debug.Print SubFolder.Name & " (" & SubFolder.Size & " bytes)" Next ' 遍历文件 Debug.Print "=== 文件 ===" For Each File In Folder.Files Debug.Print File.Name & " (" & File.Size & " bytes)" Next End Sub ``` --- --- url: /en/vbman/tools/fso/cToolsFso.md --- # cToolsFso Class File system operation utility class, providing common functions like path processing and directory management. ## Description `cToolsFso` is a wrapper for `Scripting.FileSystemObject`, providing more convenient file path processing and directory operation functionality. The original FSO object is exposed through the `Inst` property for advanced operations. **Required Library:** * `Microsoft Scripting Runtime` (scrrun.dll) *** ## Properties | Property Name | Type | Description | |---------------|------|-------------| | `Inst` | `Scripting.FileSystemObject` | FSO instance object, can directly access original FSO methods | *** ## Methods ### IsFullPath Determines whether the path is a full path (contains drive letter). **Syntax:** ```vb Public Function IsFullPath(Path As String) As Boolean ``` **Parameters:** | Parameter | Type | Description | |-----------|------|-------------| | `Path` | `String` | Path to check | **Returns:** * `True` - Is full path (contains `:\`) * `False` - Is relative path **Example:** ```vb Dim Fso As New cToolsFso Debug.Print Fso.IsFullPath("C:\Windows\System32") ' True Debug.Print Fso.IsFullPath("..\data\file.txt") ' False Debug.Print Fso.IsFullPath("data\file.txt") ' False ``` *** ### AutoCompleteFullPath Auto-completes to full path, supports relative path to absolute path conversion. **Syntax:** ```vb Public Function AutoCompleteFullPath(Path As String, Optional IsFile As Boolean) As String ``` **Parameters:** | Parameter | Type | Description | |-----------|------|-------------| | `Path` | `String` | Original path | | `IsFile` | `Boolean` | Optional. Whether it's a file path (affects trailing slash handling) | **Returns:** * Full path string **Description:** * If path is already a full path, returns it directly * If relative path, prepends `App.Path` * Automatically cleans up extra slashes in path **Example:** ```vb Dim Fso As New cToolsFso ' Relative path to absolute path Debug.Print Fso.AutoCompleteFullPath("data\config.ini") ' Output: C:\Program Files\MyApp\data\config.ini ' Already full path, remains unchanged Debug.Print Fso.AutoCompleteFullPath("D:\\backup\\data.txt") ' Output: D:\backup\data.txt ``` *** ### ClearSpan Cleans up slashes in the path, unified to backslash format. **Syntax:** ```vb Public Function ClearSpan(Path As String, Optional IsFile As Boolean) As String ``` **Parameters:** | Parameter | Type | Description | |-----------|------|-------------| | `Path` | `String` | Path to clean | | `IsFile` | `Boolean` | Optional. Whether it's a file path (directory will auto-add trailing slash) | **Returns:** * Cleaned path string **Description:** * Unifies `//`, `\/`, `/` to `\` * If directory path, automatically adds trailing `\` **Example:** ```vb Dim Fso As New cToolsFso ' Unify slash format Debug.Print Fso.ClearSpan("C://Windows\\System32//file.txt", True) ' Output: C:\Windows\System32\file.txt ' Directory path auto-adds trailing slash Debug.Print Fso.ClearSpan("C:\\Windows\\System32", False) ' Output: C:\Windows\System32\ ``` *** ### AutoMakeDir Automatically creates a directory (if it doesn't exist). **Syntax:** ```vb Public Function AutoMakeDir(ByVal Path As String, Optional IsFile As Boolean) As String ``` **Parameters:** | Parameter | Type | Description | |-----------|------|-------------| | `Path` | `String` | Directory path or file path | | `IsFile` | `Boolean` | Optional. If True, automatically extracts parent directory to create | **Returns:** * Created directory path (cleaned format) **Description:** * Uses Windows API `MakeSureDirectoryPathExists` to create directory * Supports multi-level directory creation * Does not report error if directory already exists **Example:** ```vb Dim Fso As New cToolsFso ' Create directory Dim DirPath As String DirPath = Fso.AutoMakeDir("C:\\MyApp\\Data\\Logs", False) Debug.Print "Directory created: " & DirPath ' Extract and create directory from file path DirPath = Fso.AutoMakeDir("C:\\MyApp\\Data\\file.txt", True) ' Creates C:\MyApp\Data directory ``` *** ### AppPath Gets the application path (automatically adjusts based on run mode). **Syntax:** ```vb Public Function AppPath(Optional ByVal Path As String) As String ``` **Parameters:** | Parameter | Type | Description | |-----------|------|-------------| | `Path` | `String` | Optional. Sub-path to append | **Returns:** * Application path string **Description:** * IDE mode (`App.LogMode = 0`): returns `App.Path\..\dist\EXE\` * Compiled mode: returns `App.Path\` **Example:** ```vb Dim Fso As New cToolsFso ' Get application path Debug.Print Fso.AppPath() ' Get subdirectory under application path Debug.Print Fso.AppPath("data\config.ini") ``` *** ### MakeNewFileFulPath Generates a new file name (adds suffix). **Syntax:** ```vb Public Function MakeNewFileFulPath(FileSrc As String, AppendFix As String, Optional JoinStr As String = "_") As String ``` **Parameters:** | Parameter | Type | Description | |-----------|------|-------------| | `FileSrc` | `String` | Original file path | | `AppendFix` | `String` | Suffix to add | | `JoinStr` | `String` | Optional. Join string, default is `_` | **Returns:** * New file name (without path) **Description:** * Preserves original file extension * Inserts join string and suffix between filename and extension **Example:** ```vb Dim Fso As New cToolsFso ' Generate backup filename Debug.Print Fso.MakeNewFileFulPath("C:\\data\\document.txt", "backup") ' Output: document_backup.txt ' Use custom join string Debug.Print Fso.MakeNewFileFulPath("photo.jpg", "2024", "-") ' Output: photo-2024.jpg ``` *** ## Usage Examples ### Comprehensive Example: File Backup ```vb Sub BackupFileExample() Dim Fso As New cToolsFso Dim SrcFile As String Dim BackupDir As String Dim BackupFile As String ' Source file SrcFile = "C:\\MyApp\\data\\important.dat" ' Ensure backup directory exists BackupDir = Fso.AutoMakeDir("C:\\MyApp\\backup\\", False) ' Generate backup filename BackupFile = BackupDir & Fso.MakeNewFileFulPath(SrcFile, Format(Now, "yyyymmdd")) ' Copy file using FSO Fso.Inst.CopyFile SrcFile, BackupFile, True Debug.Print "Backup completed: " & BackupFile End Sub ``` ### Comprehensive Example: Traverse Directory ```vb Sub ListDirectoryExample() Dim Fso As New cToolsFso Dim Folder As Scripting.Folder Dim SubFolder As Scripting.Folder Dim File As Scripting.File ' Get directory object Set Folder = Fso.Inst.GetFolder("C:\\Windows") ' Traverse subdirectories Debug.Print "=== Subdirectories ===" For Each SubFolder In Folder.SubFolders Debug.Print SubFolder.Name & " (" & SubFolder.Size & " bytes)" Next ' Traverse files Debug.Print "=== Files ===" For Each File In Folder.Files Debug.Print File.Name & " (" & File.Size & " bytes)" Next End Sub ``` --- --- url: /zh/vbman/tools/fso/cToolsStream.md --- # cToolsStream 类 基于 ADODB.Stream 的流式文件操作类，支持文本和二进制数据读写。 ## 说明 `cToolsStream` 是对 `ADODB.Stream` 对象的封装，提供简化的文件读写接口。支持按行读写模式，适合处理文本配置文件。 **引用库：** * `Microsoft ActiveX Data Objects 2.8 Library` (msado28.tlb) **特点：** * 支持文本和二进制两种模式 * 支持按行读写（将文件内容按行分割存储） * 自动处理编码（UTF-8、ANSI 等） *** ## 属性 | 属性名 | 类型 | 说明 | |--------|------|------| | `Inst` | `ADODB.Stream` | ADO Stream 实例对象 | | `LastError` | `String` | 最后一次错误信息 | | `LineNumber` | `Long` | 当前行号（按行模式下使用） | | `UseLine` | `Boolean` | 是否启用按行读写模式 | | `LineData` | `cCollection` | 按行存储的数据集合 | | `Txt` | `cToolsStr` | 字符串工具实例 | *** ## 方法 ### UseLineMode 设置是否启用按行读写模式。 **语法：** ```vb Public Function UseLineMode(v As Boolean) As cToolsStream ``` **参数：** | 参数 | 类型 | 说明 | |------|------|------| | `v` | `Boolean` | `True`=启用按行模式, `False`=禁用 | **返回值：** * 返回自身实例，支持链式调用 **说明：** * 启用后，`LineData` 集合将作为数据主体 * `Inst` 中保存的是原始文件内容 **示例：** ```vb Dim Stream As New cToolsStream ' 启用按行模式 Stream.UseLineMode True ``` *** ### ReadLine 从指定行读入一行内容。 **语法：** ```vb Public Function ReadLine(Optional ByVal Line As Long) As String ``` **参数：** | 参数 | 类型 | 说明 | |------|------|------| | `Line` | `Long` | 可选。指定行号（1-based），不提供则使用 `LineNumber` | **返回值：** * 该行内容字符串 **异常：** * 未启用按行模式时抛出错误 **说明：** * 读取后 `LineNumber` 自动 +1 * 如果提供 `Line` 参数，则设置 `LineNumber = Line` **示例：** ```vb Dim Stream As New cToolsStream Stream.UseLineMode True ' 加载文件（会自动分割为行） Stream.LoadFileAsText "C:\\data\\config.ini", "UTF-8" ' 逐行读取 Dim Line1 As String Line1 = Stream.ReadLine() ' 读取第 1 行 Dim Line5 As String Line5 = Stream.ReadLine(5) ' 读取第 5 行 ``` *** ### WriteLine 向指定行写入内容。 **语法：** ```vb Public Function WriteLine(Text As String, Optional ByVal Line As Long) As Boolean ``` **参数：** | 参数 | 类型 | 说明 | |------|------|------| | `Text` | `String` | 要写入的内容 | | `Line` | `Long` | 可选。指定行号，不提供则使用 `LineNumber` | **返回值：** * `True` - 写入成功 **异常：** * 未启用按行模式时抛出错误 **说明：** * 写入后 `LineNumber` 自动 +1 * 如果行号已存在，会替换原有内容 **示例：** ```vb Dim Stream As New cToolsStream Stream.UseLineMode True ' 写入多行 Stream.WriteLine "[Section1]", 1 Stream.WriteLine "Key1=Value1", 2 Stream.WriteLine "Key2=Value2", 3 ' 保存文件 Stream.SaveFileAsText "C:\\data\\config.ini", , "UTF-8" ``` *** ### LoadFileAsText 以文本模式加载文件。 **语法：** ```vb Public Function LoadFileAsText(ByVal FileName As String, Optional ByVal CharSet As String = "UTF-8") As String ``` **参数：** | 参数 | 类型 | 说明 | |------|------|------| | `FileName` | `String` | 文件路径 | | `CharSet` | `String` | 可选。字符编码，默认为 `UTF-8` | **返回值：** * 文件内容字符串 **说明：** * 如果启用了按行模式，内容会自动按行分割存入 `LineData` * 加载后 `LineNumber` 重置为 1 **示例：** ```vb Dim Stream As New cToolsStream Dim Content As String ' 基本加载 Content = Stream.LoadFileAsText("C:\\data\\readme.txt", "UTF-8") Debug.Print Content ' 按行模式加载 Stream.UseLineMode True Content = Stream.LoadFileAsText("C:\\data\\config.ini", "UTF-8") ' 现在可以使用 ReadLine 访问各行 Debug.Print Stream.ReadLine(1) ``` *** ### SaveFileAsText 以文本模式保存文件。 **语法：** ```vb Public Function SaveFileAsText(ByVal FileName As String, Optional Data As Variant, Optional ByVal CharSet As String = "UTF-8") As Boolean ``` **参数：** | 参数 | 类型 | 说明 | |------|------|------| | `FileName` | `String` | 目标文件路径 | | `Data` | `Variant` | 可选。要保存的数据，不提供则使用 `LineData`（按行模式）或 `Inst` | | `CharSet` | `String` | 可选。字符编码，默认为 `UTF-8` | **返回值：** * `True` - 保存成功 **说明：** * 文件已存在会覆盖 * 按行模式下，如果不提供 `Data`，自动使用 `LineData` 集合 **示例：** ```vb Dim Stream As New cToolsStream ' 直接保存字符串 Stream.SaveFileAsText "C:\\data\\output.txt", "Hello World", "UTF-8" ' 按行模式保存 Stream.UseLineMode True Stream.WriteLine "Line 1", 1 Stream.WriteLine "Line 2", 2 Stream.SaveFileAsText "C:\\data\\lines.txt", , "UTF-8" ``` *** ### LoadFileAsBinary 以二进制模式加载文件。 **语法：** ```vb Public Function LoadFileAsBinary(ByVal Path As String, OutData() As Byte) As Boolean ``` **参数：** | 参数 | 类型 | 说明 | |------|------|------| | `Path` | `String` | 文件路径 | | `OutData` | `Byte()` | 输出字节数组 | **返回值：** * `True` - 加载成功 * `False` - 加载失败（错误信息在 `LastError`） **示例：** ```vb Dim Stream As New cToolsStream Dim Bytes() As Byte If Stream.LoadFileAsBinary("C:\\data\\file.bin", Bytes) Then Debug.Print "加载成功，字节数: " & UBound(Bytes) + 1 Else Debug.Print "加载失败: " & Stream.LastError End If ``` *** ### SaveFileAsBinary 以二进制模式保存文件。 **语法：** ```vb Public Function SaveFileAsBinary(ByVal Path As String, OutData() As Byte) As Boolean ``` **参数：** | 参数 | 类型 | 说明 | |------|------|------| | `Path` | `String` | 目标文件路径 | | `OutData` | `Byte()` | 要保存的字节数组 | **返回值：** * `True` - 保存成功 * `False` - 保存失败（错误信息在 `LastError`） **示例：** ```vb Dim Stream As New cToolsStream Dim Bytes() As Byte ' 填充数据 ReDim Bytes(0 To 3) Bytes(0) = &H48 ' H Bytes(1) = &H65 ' e Bytes(2) = &H6C ' l Bytes(3) = &H6C ' l If Stream.SaveFileAsBinary("C:\\data\\output.bin", Bytes) Then Debug.Print "保存成功" Else Debug.Print "保存失败: " & Stream.LastError End If ``` *** ## 使用示例 ### 示例 1：简单的文本文件读写 ```vb Sub SimpleTextExample() Dim Stream As New cToolsStream Dim Content As String ' 写入文件 Stream.SaveFileAsText "C:\\data\\test.txt", "Hello World 你好世界", "UTF-8" ' 读取文件 Content = Stream.LoadFileAsText("C:\\data\\test.txt", "UTF-8") Debug.Print Content End Sub ``` ### 示例 2：按行读写配置文件 ```vb Sub ConfigFileExample() Dim Stream As New cToolsStream ' 启用按行模式 Stream.UseLineMode True ' 创建配置内容 Stream.WriteLine "[Database]", 1 Stream.WriteLine "Server=localhost", 2 Stream.WriteLine "Port=3306", 3 Stream.WriteLine "Database=mydb", 4 Stream.WriteLine "", 5 Stream.WriteLine "[Settings]", 6 Stream.WriteLine "DebugMode=True", 7 Stream.WriteLine "Timeout=30", 8 ' 保存配置 Stream.SaveFileAsText "C:\\data\\app.ini", , "UTF-8" ' 读取配置 Stream.LoadFileAsText "C:\\data\\app.ini", "UTF-8" Dim i As Long For i = 1 To 8 Debug.Print "Line " & i & ": " & Stream.ReadLine(i) Next i End Sub ``` ### 示例 3：修改配置文件 ```vb Sub ModifyConfigExample() Dim Stream As New cToolsStream ' 启用按行模式并加载文件 Stream.UseLineMode True Stream.LoadFileAsText "C:\\data\\app.ini", "UTF-8" ' 查找并修改特定行 Dim i As Long For i = 1 To Stream.LineData.Count Dim Line As String Line = Stream.ReadLine(i) ' 修改端口号 If Left(Line, 5) = "Port=" Then Stream.WriteLine "Port=5432", i Debug.Print "已修改第 " & i & " 行" End If Next i ' 保存修改 Stream.SaveFileAsText "C:\\data\\app.ini", , "UTF-8" End Sub ``` ### 示例 4：二进制文件处理 ```vb Sub BinaryFileExample() Dim Stream As New cToolsStream Dim InData() As Byte Dim OutData() As Byte ' 加载二进制文件 If Not Stream.LoadFileAsBinary("C:\\data\\input.bin", InData) Then Debug.Print "加载失败: " & Stream.LastError Exit Sub End If Debug.Print "原始文件大小: " & UBound(InData) + 1 & " 字节" ' 处理数据（例如：简单加密 - 每个字节 XOR 0xFF） ReDim OutData(UBound(InData)) Dim i As Long For i = 0 To UBound(InData) OutData(i) = InData(i) Xor &HFF Next i ' 保存处理后的数据 If Not Stream.SaveFileAsBinary("C:\\data\\output.bin", OutData) Then Debug.Print "保存失败: " & Stream.LastError Exit Sub End If Debug.Print "二进制处理完成" End Sub ``` ### 示例 5：文件编码转换 ```vb Sub EncodingConversionExample() Dim Stream As New cToolsStream Dim Content As String ' 读取 ANSI 文件 Content = Stream.LoadFileAsText("C:\\data\\ansi.txt", "GBK") Debug.Print "原文: " & Content ' 保存为 UTF-8 Stream.SaveFileAsText "C:\\data\\utf8.txt", Content, "UTF-8" Debug.Print "编码转换完成: ANSI -> UTF-8" End Sub ``` *** ## 注意事项 1. **编码支持**：ADO Stream 支持的编码包括 `UTF-8`、`UTF-16`、`ANSI`、`GBK` 等 2. **空值处理**：ADO Stream 不能写入空字符串，内部会自动转换为空格 3. **资源释放**：类终止时会自动关闭 Stream，但建议显式管理资源 4. **大文件**：二进制模式适合处理大文件，但会占用内存（整个文件读入数组） 5. **错误处理**：二进制操作返回布尔值表示成功/失败，错误信息在 `LastError` --- --- url: /en/vbman/tools/fso/cToolsStream.md --- # cToolsStream Class Stream file operations class based on ADODB.Stream, supports text and binary data read/write. ## Description `cToolsStream` is a wrapper for `ADODB.Stream` object, providing simplified file read/write interface. Supports line-by-line read/write mode, suitable for processing text configuration files. **Required Library:** * `Microsoft ActiveX Data Objects 2.8 Library` (msado28.tlb) **Features:** * Supports text and binary modes * Supports line-by-line read/write (splits file content by lines and stores) * Automatically handles encoding (UTF-8, ANSI, etc.) *** ## Properties | Property Name | Type | Description | |---------------|------|-------------| | `Inst` | `ADODB.Stream` | ADO Stream instance object | | `LastError` | `String` | Last error message | | `LineNumber` | `Long` | Current line number (used in line mode) | | `UseLine` | `Boolean` | Whether line-by-line read/write mode is enabled | | `LineData` | `cCollection` | Line-stored data collection | | `Txt` | `cToolsStr` | String tools instance | *** ## Methods ### UseLineMode Sets whether to enable line-by-line read/write mode. **Syntax:** ```vb Public Function UseLineMode(v As Boolean) As cToolsStream ``` **Parameters:** | Parameter | Type | Description | |-----------|------|-------------| | `v` | `Boolean` | `True`=enable line mode, `False`=disable | **Returns:** * Returns self instance, supports method chaining **Description:** * When enabled, `LineData` collection serves as the data body * `Inst` saves the original file content **Example:** ```vb Dim Stream As New cToolsStream ' Enable line mode Stream.UseLineMode True ``` *** ### ReadLine Reads one line of content from specified line. **Syntax:** ```vb Public Function ReadLine(Optional ByVal Line As Long) As String ``` **Parameters:** | Parameter | Type | Description | |-----------|------|-------------| | `Line` | `Long` | Optional. Specify line number (1-based), if not provided uses `LineNumber` | **Returns:** * Line content string **Exceptions:** * Throws error when line mode is not enabled **Description:** * After reading, `LineNumber` automatically increments by 1 * If `Line` parameter is provided, sets `LineNumber = Line` **Example:** ```vb Dim Stream As New cToolsStream Stream.UseLineMode True ' Load file (will auto-split into lines) Stream.LoadFileAsText "C:\\data\\config.ini", "UTF-8" ' Read line by line Dim Line1 As String Line1 = Stream.ReadLine() ' Read line 1 Dim Line5 As String Line5 = Stream.ReadLine(5) ' Read line 5 ``` *** ### WriteLine Writes content to specified line. **Syntax:** ```vb Public Function WriteLine(Text As String, Optional ByVal Line As Long) As Boolean ``` **Parameters:** | Parameter | Type | Description | |-----------|------|-------------| | `Text` | `String` | Content to write | | `Line` | `Long` | Optional. Specify line number, if not provided uses `LineNumber` | **Returns:** * `True` - Write successful **Exceptions:** * Throws error when line mode is not enabled **Description:** * After writing, `LineNumber` automatically increments by 1 * If line number already exists, replaces original content **Example:** ```vb Dim Stream As New cToolsStream Stream.UseLineMode True ' Write multiple lines Stream.WriteLine "[Section1]", 1 Stream.WriteLine "Key1=Value1", 2 Stream.WriteLine "Key2=Value2", 3 ' Save file Stream.SaveFileAsText "C:\\data\\config.ini", , "UTF-8" ``` *** ### LoadFileAsText Loads file in text mode. **Syntax:** ```vb Public Function LoadFileAsText(ByVal FileName As String, Optional ByVal CharSet As String = "UTF-8") As String ``` **Parameters:** | Parameter | Type | Description | |-----------|------|-------------| | `FileName` | `String` | File path | | `CharSet` | `String` | Optional. Character encoding, default is `UTF-8` | **Returns:** * File content string **Description:** * If line mode is enabled, content is auto-split by lines and stored in `LineData` * `LineNumber` resets to 1 after loading **Example:** ```vb Dim Stream As New cToolsStream Dim Content As String ' Basic loading Content = Stream.LoadFileAsText("C:\\data\\readme.txt", "UTF-8") Debug.Print Content ' Load in line mode Stream.UseLineMode True Content = Stream.LoadFileAsText("C:\\data\\config.ini", "UTF-8") ' Now you can use ReadLine to access each line Debug.Print Stream.ReadLine(1) ``` *** ### SaveFileAsText Saves file in text mode. **Syntax:** ```vb Public Function SaveFileAsText(ByVal FileName As String, Optional Data As Variant, Optional ByVal CharSet As String = "UTF-8") As Boolean ``` **Parameters:** | Parameter | Type | Description | |-----------|------|-------------| | `FileName` | `String` | Target file path | | `Data` | `Variant` | Optional. Data to save, if not provided uses `LineData` (line mode) or `Inst` | | `CharSet` | `String` | Optional. Character encoding, default is `UTF-8` | **Returns:** * `True` - Save successful **Description:** * Overwrites if file already exists * In line mode, if `Data` is not provided, automatically uses `LineData` collection **Example:** ```vb Dim Stream As New cToolsStream ' Save string directly Stream.SaveFileAsText "C:\\data\\output.txt", "Hello World", "UTF-8" ' Save in line mode Stream.UseLineMode True Stream.WriteLine "Line 1", 1 Stream.WriteLine "Line 2", 2 Stream.SaveFileAsText "C:\\data\\lines.txt", , "UTF-8" ``` *** ### LoadFileAsBinary Loads file in binary mode. **Syntax:** ```vb Public Function LoadFileAsBinary(ByVal Path As String, OutData() As Byte) As Boolean ``` **Parameters:** | Parameter | Type | Description | |-----------|------|-------------| | `Path` | `String` | File path | | `OutData` | `Byte()` | Output byte array | **Returns:** * `True` - Load successful * `False` - Load failed (error message in `LastError`) **Example:** ```vb Dim Stream As New cToolsStream Dim Bytes() As Byte If Stream.LoadFileAsBinary("C:\\data\\file.bin", Bytes) Then Debug.Print "Load successful, byte count: " & UBound(Bytes) + 1 Else Debug.Print "Load failed: " & Stream.LastError End If ``` *** ### SaveFileAsBinary Saves file in binary mode. **Syntax:** ```vb Public Function SaveFileAsBinary(ByVal Path As String, OutData() As Byte) As Boolean ``` **Parameters:** | Parameter | Type | Description | |-----------|------|-------------| | `Path` | `String` | Target file path | | `OutData` | `Byte()` | Byte array to save | **Returns:** * `True` - Save successful * `False` - Save failed (error message in `LastError`) **Example:** ```vb Dim Stream As New cToolsStream Dim Bytes() As Byte ' Fill data ReDim Bytes(0 To 3) Bytes(0) = &H48 ' H Bytes(1) = &H65 ' e Bytes(2) = &H6C ' l Bytes(3) = &H6C ' l If Stream.SaveFileAsBinary("C:\\data\\output.bin", Bytes) Then Debug.Print "Save successful" Else Debug.Print "Save failed: " & Stream.LastError End If ``` *** ## Usage Examples ### Example 1: Simple Text File Read/Write ```vb Sub SimpleTextExample() Dim Stream As New cToolsStream Dim Content As String ' Write file Stream.SaveFileAsText "C:\\data\\test.txt", "Hello World 你好世界", "UTF-8" ' Read file Content = Stream.LoadFileAsText("C:\\data\\test.txt", "UTF-8") Debug.Print Content End Sub ``` ### Example 2: Line-by-Line Read/Write Configuration File ```vb Sub ConfigFileExample() Dim Stream As New cToolsStream ' Enable line mode Stream.UseLineMode True ' Create configuration content Stream.WriteLine "[Database]", 1 Stream.WriteLine "Server=localhost", 2 Stream.WriteLine "Port=3306", 3 Stream.WriteLine "Database=mydb", 4 Stream.WriteLine "", 5 Stream.WriteLine "[Settings]", 6 Stream.WriteLine "DebugMode=True", 7 Stream.WriteLine "Timeout=30", 8 ' Save configuration Stream.SaveFileAsText "C:\\data\\app.ini", , "UTF-8" ' Read configuration Stream.LoadFileAsText "C:\\data\\app.ini", "UTF-8" Dim i As Long For i = 1 To 8 Debug.Print "Line " & i & ": " & Stream.ReadLine(i) Next i End Sub ``` ### Example 3: Modify Configuration File ```vb Sub ModifyConfigExample() Dim Stream As New cToolsStream ' Enable line mode and load file Stream.UseLineMode True Stream.LoadFileAsText "C:\\data\\app.ini", "UTF-8" ' Find and modify specific line Dim i As Long For i = 1 To Stream.LineData.Count Dim Line As String Line = Stream.ReadLine(i) ' Modify port number If Left(Line, 5) = "Port=" Then Stream.WriteLine "Port=5432", i Debug.Print "Modified line " & i End If Next i ' Save modification Stream.SaveFileAsText "C:\\data\\app.ini", , "UTF-8" End Sub ``` ### Example 4: Binary File Processing ```vb Sub BinaryFileExample() Dim Stream As New cToolsStream Dim InData() As Byte Dim OutData() As Byte ' Load binary file If Not Stream.LoadFileAsBinary("C:\\data\\input.bin", InData) Then Debug.Print "Load failed: " & Stream.LastError Exit Sub End If Debug.Print "Original file size: " & UBound(InData) + 1 & " bytes" ' Process data (e.g., simple encryption - XOR each byte with 0xFF) ReDim OutData(UBound(InData)) Dim i As Long For i = 0 To UBound(InData) OutData(i) = InData(i) Xor &HFF Next i ' Save processed data If Not Stream.SaveFileAsBinary("C:\\data\\output.bin", OutData) Then Debug.Print "Save failed: " & Stream.LastError Exit Sub End If Debug.Print "Binary processing completed" End Sub ``` ### Example 5: File Encoding Conversion ```vb Sub EncodingConversionExample() Dim Stream As New cToolsStream Dim Content As String ' Read ANSI file Content = Stream.LoadFileAsText("C:\\data\\ansi.txt", "GBK") Debug.Print "Original: " & Content ' Save as UTF-8 Stream.SaveFileAsText "C:\\data\\utf8.txt", Content, "UTF-8" Debug.Print "Encoding conversion completed: ANSI -> UTF-8" End Sub ``` *** ## Notes 1. **Encoding Support**: ADO Stream supports encodings including `UTF-8`, `UTF-16`, `ANSI`, `GBK`, etc. 2. **Empty Value Handling**: ADO Stream cannot write empty strings, internally auto-converts to space 3. **Resource Release**: Stream is automatically closed when class terminates, but explicit resource management is recommended 4. **Large Files**: Binary mode is suitable for handling large files, but will consume memory (entire file loaded into array) 5. **Error Handling**: Binary operations return boolean indicating success/failure, error message in `LastError` --- --- url: /zh/vbman/websocket/client.md --- # cWebSocketClient 类参考 ## 📋 类概述 `cWebSocketClient` 是 WebSocket 客户端实现类，提供连接到 WebSocket 服务器、发送/接收消息、自动握手等功能。 *** ## 📡 事件列表 | 事件名 | 触发时机 | 参数 | |--------|----------|------| | `OnOpen` | 连接成功建立 | 无 | | `OnClose` | 连接已关闭 | `Code` (关闭码), `Reason` (关闭原因) | | `OnTextMessage` | 收到文本消息 | `Message` (消息内容) | | `OnBinaryMessage` | 收到二进制消息 | `Data()` (字节数组) | | `OnError` | 发生错误 | `Description` (错误描述) | | `OnPong` | 收到 Pong 响应 | `Data()` (Pong 负载) | *** ## 🔧 属性参考 ### State - 连接状态 **类型**: `WsState` (枚举)\ **读写**: 只读 **值**: | 常量 | 值 | 说明 | |------|-----|------| | `WS_STATE_CLOSED` | 0 | 已关闭 | | `WS_STATE_CONNECTING` | 1 | 正在连接/握手 | | `WS_STATE_OPEN` | 2 | 已连接，可以发送消息 | | `WS_STATE_CLOSING` | 3 | 正在关闭 | **示例**: ```vb If m_Client.State = WS_STATE_OPEN Then m_Client.SendText "Hello" Else Debug.Print "未连接" End If ``` *** ### URL - 连接地址 **类型**: `String`\ **读写**: 只读 **说明**: 当前或最后连接的 WebSocket URL。 **示例**: ```vb Debug.Print "连接到: " & m_Client.URL ' 输出: 连接到: ws://127.0.0.1:8080 ``` *** ### Host - 服务器主机名 **类型**: `String`\ **读写**: 只读 **说明**: 从 URL 解析的服务器主机名或 IP 地址。 **示例**: ```vb Debug.Print "服务器: " & m_Client.Host ``` *** ### Port - 服务器端口 **类型**: `Long`\ **读写**: 只读 **说明**: 从 URL 解析的服务器端口号。 **示例**: ```vb Debug.Print "端口: " & m_Client.Port ``` *** ### AutoPing - 自动 Ping **类型**: `Boolean`\ **读写**: 读写 **说明**: 是否启用自动 Ping（保活功能）。默认为 `False`。 **示例**: ```vb ' 启用自动 Ping m_Client.AutoPing = True ' 禁用自动 Ping m_Client.AutoPing = False ``` *** ### PingInterval - Ping 间隔 **类型**: `Long`\ **读写**: 读写 **说明**: 自动 Ping 的间隔时间（毫秒）。默认为 30000 (30 秒)。 **示例**: ```vb ' 设置 Ping 间隔为 20 秒 m_Client.PingInterval = 20000 ``` *** ## 🚀 方法参考 ### Connect - 连接服务器 **语法**: ```vb Public Sub Connect(ByVal WebSocketURL As String, Optional ByVal SubProtocol As String = "") ``` **参数**: | 参数 | 类型 | 说明 | |------|------|------| | `WebSocketURL` | String | WebSocket 服务器 URL，格式：`ws[s]://host[:port][/path][?query]` | | `SubProtocol` | String（可选） | WebSocket 子协议 | **URL 格式**: * 标准格式: `ws://example.com:8080/chat` * 默认端口: `ws://example.com/chat` (默认 80) * 查询参数: `ws://example.com/chat?token=abc123` * 安全连接: `wss://example.com` (暂未实现) **示例**: ```vb ' 基本连接 m_Client.Connect "ws://127.0.0.1:8080" ' 带路径的连接 m_Client.Connect "ws://example.com/chat" ' 带查询参数的连接 m_Client.Connect "ws://example.com/chat?token=abc123" ' 指定子协议 m_Client.Connect "ws://example.com/chat", "chat.v1" ``` **错误处理**: ```vb Private Sub cmdConnect_Click() On Error GoTo EH m_Client.Connect "ws://example.com:8080" Exit Sub EH: Debug.Print "连接失败: " & Err.Description End Sub ``` *** ### CloseConnection - 关闭连接 **语法**: ```vb Public Sub CloseConnection(Optional ByVal Code As WsCloseCode = WS_CLOSE_NORMAL, _ Optional ByVal Reason As String = "") ``` **参数**: | 参数 | 类型 | 说明 | |------|------|------| | `Code` | WsCloseCode（可选） | 关闭状态码，默认 `WS_CLOSE_NORMAL` | | `Reason` | String（可选） | 关闭原因 | **常用关闭码**: ```vb m_Client.CloseConnection WS_CLOSE_NORMAL, "正常关闭" m_Client.CloseConnection WS_CLOSE_GOING_AWAY, "用户退出" m_Client.CloseConnection WS_CLOSE_PROTOCOL_ERROR, "协议错误" ``` **示例**: ```vb ' 正常关闭 m_Client.CloseConnection ' 指定关闭码和原因 m_Client.CloseConnection WS_CLOSE_GOING_AWAY, "用户注销" ' 窗体关闭时自动断开 Private Sub Form_Unload(Cancel As Integer) m_Client.CloseConnection WS_CLOSE_GOING_AWAY, "应用关闭" End Sub ``` *** ### SendText - 发送文本消息 **语法**: ```vb Public Sub SendText(ByVal Message As String) ``` **参数**: | 参数 | 类型 | 说明 | |------|------|------| | `Message` | String | 要发送的文本消息 | **说明**: 消息会自动转换为 UTF-8 编码并添加 WebSocket 帧头。客户端发送的帧会自动掩码。 **示例**: ```vb ' 发送简单文本 m_Client.SendText "Hello WebSocket!" ' 发送 JSON 数据 Dim sJSON As String sJSON = "{""type"":""message"", ""content"":""Hello""}" m_Client.SendText sJSON ' 发送多行文本 m_Client.SendText "第一行" & vbCrLf & "第二行" ``` **错误处理**: ```vb On Error GoTo EH m_Client.SendText "Hello" Exit Sub EH: Debug.Print "发送失败: " & Err.Description ``` *** ### SendBinary - 发送二进制消息 **语法**: ```vb Public Sub SendBinary(Data() As Byte) ``` **参数**: | 参数 | 类型 | 说明 | |------|------|------| | `Data()` | Byte() | 要发送的二进制数据 | **示例**: ```vb ' 发送字节数组 Dim baData() As Byte baData = StringToBytes("Hello") m_Client.SendBinary baData ' 发送图片数据 Dim baImage() As Byte baImage = LoadImageToByteArray() m_Client.SendBinary baImage ' 发送序列化对象 Dim baObj() As Byte baObj = SerializeObject(myObject) m_Client.SendBinary baObj ``` *** ### SendPing - 发送 Ping 帧 **语法**: ```vb Public Sub SendPing(Optional Payload As Variant) ``` **参数**: | 参数 | 类型 | 说明 | |------|------|------| | `Payload` | Variant（可选） | Ping 负载，可以是字符串或字节数组 | **说明**: 用于连接保活，服务器会自动回复 Pong 帧。 **示例**: ```vb ' 发送空 Ping（保活） m_Client.SendPing ' 发送带数据的 Ping m_Client.SendPing "ping" ' 发送带二进制数据的 Ping Dim baData() As Byte baData = StringToUTF8("ping") m_Client.SendPing baData ' 测量延迟 Dim lStartTime As Long lStartTime = GetTickCount() m_Client.SendPing "ping" Private Sub m_Client_OnPong(Data() As Byte) Dim lElapsed As Long lElapsed = GetTickCount() - lStartTime Debug.Print "延迟: " & lElapsed & " ms" End Sub ``` *** ## 📡 事件详解 ### OnOpen - 连接成功 **语法**: ```vb Event OnOpen() ``` **说明**: WebSocket 握手成功后触发，此时可以开始发送消息。 **示例**: ```vb Private Sub m_Client_OnOpen() Debug.Print "已成功连接到 WebSocket 服务器" ' 发送欢迎消息 m_Client.SendText "Hello Server!" ' 更新 UI lblStatus.Caption = "已连接" cmdSend.Enabled = True End Sub ``` *** ### OnClose - 连接关闭 **语法**: ```vb Event OnClose(ByVal Code As WsCloseCode, ByVal Reason As String) ``` **参数**: | 参数 | 类型 | 说明 | |------|------|------| | `Code` | WsCloseCode | 关闭状态码 | | `Reason` | String | 关闭原因 | **示例**: ```vb Private Sub m_Client_OnClose(ByVal Code As WsCloseCode, ByVal Reason As String) Debug.Print "连接已关闭" Debug.Print "状态码: " & Code Debug.Print "原因: " & Reason ' 根据关闭码处理 Select Case Code Case WS_CLOSE_NORMAL Debug.Print "正常关闭" Case WS_CLOSE_ABNORMAL Debug.Print "异常关闭" ' 尝试重连 If m_bAutoReconnect Then tmrReconnect.Enabled = True End If Case WS_CLOSE_GOING_AWAY Debug.Print "服务器关闭" Case Else Debug.Print "其他原因: " & Reason End Select ' 更新 UI lblStatus.Caption = "已断开" cmdSend.Enabled = False End Sub ``` *** ### OnTextMessage - 收到文本消息 **语法**: ```vb Event OnTextMessage(ByVal Message As String) ``` **参数**: | 参数 | 类型 | 说明 | |------|------|------| | `Message` | String | 收到的文本消息（UTF-8 解码后） | **示例**: ```vb Private Sub m_Client_OnTextMessage(ByVal Message As String) Debug.Print "收到消息: " & Message ' 处理 JSON 消息 If Left$(Message, 1) = "{" Then Dim sType As String sType = GetJSONField(Message, "type") Select Case sType Case "chat" DisplayChatMessage Message Case "notification" DisplayNotification Message End Select Else ' 简单文本消息 txtMessages.Text = txtMessages.Text & Message & vbCrLf End If End Sub ``` *** ### OnBinaryMessage - 收到二进制消息 **语法**: ```vb Event OnBinaryMessage(Data() As Byte) ``` **参数**: | 参数 | 类型 | 说明 | |------|------|------| | `Data()` | Byte() | 收到的二进制数据 | **示例**: ```vb Private Sub m_Client_OnBinaryMessage(Data() As Byte) Debug.Print "收到二进制消息: " & (UBound(Data) + 1) & " 字节" ' 检查数据类型（假设前 4 字节是类型标识） If UBound(Data) >= 3 Then Dim lType As Long lType = CLng(Data(0)) * 256& ^ 3 + CLng(Data(1)) * 256& ^ 2 + _ CLng(Data(2)) * 256& + CLng(Data(3)) Select Case lType Case 1 ' 文本 Dim sText As String sText = UTF8ToString(ExtractData(Data, 4)) Debug.Print "文本数据: " & sText Case 2 ' 图片 DisplayImage ExtractData(Data, 4) Case 3 ' 自定义 ProcessCustomData ExtractData(Data, 4) End Select End If End Sub ``` *** ### OnError - 发生错误 **语法**: ```vb Event OnError(ByVal Description As String) ``` **参数**: | 参数 | 类型 | 说明 | |------|------|------| | `Description` | String | 错误描述 | **示例**: ```vb Private Sub m_Client_OnError(ByVal Description As String) Debug.Print "错误: " & Description ' 显示错误提示 MsgBox "发生错误: " & Description, vbExclamation ' 记录错误日志 LogError Description ' 更新 UI lblStatus.Caption = "错误" End Sub ``` *** ### OnPong - 收到 Pong 响应 **语法**: ```vb Event OnPong(Data() As Byte) ``` **参数**: | 参数 | 类型 | 说明 | |------|------|------| | `Data()` | Byte() | Pong 负载（对应 Ping 的数据） | **说明**: 通常用于测量网络延迟或确认连接活性。 **示例**: ```vb Private m_lPingTimes() As Long Private m_lPingIndex As Long Private Sub SendPingForLatency() ReDim m_lPingTimes(1) As Long m_lPingIndex = 0 m_lPingTimes(0) = GetTickCount() m_Client.SendPing "ping" End Sub Private Sub m_Client_OnPong(Data() As Byte) m_lPingTimes(1) = GetTickCount() Dim lLatency As Long lLatency = m_lPingTimes(1) - m_lPingTimes(0) Debug.Print "网络延迟: " & lLatency & " ms" ' 更新 UI lblLatency.Caption = lLatency & " ms" End Sub ``` *** ## 📝 完整示例 ### 基本客户端示例 ```vb Private WithEvents m_Client As cWebSocketClient Private Sub Form_Load() Set m_Client = New cWebSocketClient End Sub Private Sub cmdConnect_Click() m_Client.Connect "ws://127.0.0.1:8080" End Sub Private Sub cmdSend_Click() m_Client.SendText txtMessage.Text End Sub Private Sub cmdDisconnect_Click() m_Client.CloseConnection End Sub Private Sub m_Client_OnOpen() Debug.Print "已连接" cmdSend.Enabled = True End Sub Private Sub m_Client_OnTextMessage(ByVal Message As String) txtLog.Text = txtLog.Text & Message & vbCrLf End Sub Private Sub m_Client_OnClose(ByVal Code As WsCloseCode, ByVal Reason As String) Debug.Print "已断开: " & Reason cmdSend.Enabled = False End Sub ``` ### 带重连的客户端 ```vb Private WithEvents m_Client As cWebSocketClient Private m_bAutoReconnect As Boolean Private m_sServerURL As String Private Sub Form_Load() Set m_Client = New cWebSocketClient m_bAutoReconnect = True m_sServerURL = "ws://127.0.0.1:8080" ConnectToServer End Sub Private Sub ConnectToServer() If m_Client.State = WS_STATE_CLOSED Then Debug.Print "正在连接..." m_Client.Connect m_sServerURL End If End Sub Private Sub m_Client_OnOpen() Debug.Print "已连接" tmrReconnect.Enabled = False End Sub Private Sub m_Client_OnClose(ByVal Code As WsCloseCode, ByVal Reason As String) Debug.Print "连接关闭: " & Reason If m_bAutoReconnect Then Debug.Print "3 秒后重连..." tmrReconnect.Interval = 3000 tmrReconnect.Enabled = True End If End Sub Private Sub tmrReconnect_Timer() tmrReconnect.Enabled = False ConnectToServer End Sub ``` *** **最后更新**: 2026-01-10 --- --- url: /en/vbman/websocket/client.md --- # cWebSocketClient Class Reference ## 📋 Class Overview `cWebSocketClient` is a WebSocket client implementation class that provides functionality to connect to WebSocket servers, send/receive messages, and handle automatic handshakes. *** ## 📡 Event List | Event Name | Trigger Timing | Parameters | |------------|----------------|------------| | `OnOpen` | Connection successfully established | None | | `OnClose` | Connection closed | `Code` (Close code), `Reason` (Close reason) | | `OnTextMessage` | Text message received | `Message` (Message content) | | `OnBinaryMessage` | Binary message received | `Data()` (Byte array) | | `OnError` | Error occurred | `Description` (Error description) | | `OnPong` | Pong response received | `Data()` (Pong payload) | *** ## 🔧 Property Reference ### State - Connection State **Type**: `WsState` (Enum)\ **Read/Write**: Read-only **Values**: | Constant | Value | Description | |----------|-------|-------------| | `WS_STATE_CLOSED` | 0 | Closed | | `WS_STATE_CONNECTING` | 1 | Connecting/handshaking | | `WS_STATE_OPEN` | 2 | Connected, can send messages | | `WS_STATE_CLOSING` | 3 | Closing | **Example**: ```vb If m_Client.State = WS_STATE_OPEN Then m_Client.SendText "Hello" Else Debug.Print "Not connected" End If ``` *** ### URL - Connection URL **Type**: `String`\ **Read/Write**: Read-only **Description**: The current or last connected WebSocket URL. **Example**: ```vb Debug.Print "Connected to: " & m_Client.URL ' Output: Connected to: ws://127.0.0.1:8080 ``` *** ### Host - Server Hostname **Type**: `String`\ **Read/Write**: Read-only **Description**: Server hostname or IP address parsed from URL. **Example**: ```vb Debug.Print "Server: " & m_Client.Host ``` *** ### Port - Server Port **Type**: `Long`\ **Read/Write**: Read-only **Description**: Server port number parsed from URL. **Example**: ```vb Debug.Print "Port: " & m_Client.Port ``` *** ### AutoPing - Auto Ping **Type**: `Boolean`\ **Read/Write**: Read/Write **Description**: Whether to enable automatic Ping (keepalive feature). Default is `False`. **Example**: ```vb ' Enable auto Ping m_Client.AutoPing = True ' Disable auto Ping m_Client.AutoPing = False ``` *** ### PingInterval - Ping Interval **Type**: `Long`\ **Read/Write**: Read/Write **Description**: Auto Ping interval time in milliseconds. Default is 30000 (30 seconds). **Example**: ```vb ' Set Ping interval to 20 seconds m_Client.PingInterval = 20000 ``` *** ## 🚀 Method Reference ### Connect - Connect to Server **Syntax**: ```vb Public Sub Connect(ByVal WebSocketURL As String, Optional ByVal SubProtocol As String = "") ``` **Parameters**: | Parameter | Type | Description | |-----------|------|-------------| | `WebSocketURL` | String | WebSocket server URL, format: `ws[s]://host[:port][/path][?query]` | | `SubProtocol` | String (Optional) | WebSocket sub-protocol | **URL Format**: * Standard format: `ws://example.com:8080/chat` * Default port: `ws://example.com/chat` (default 80) * Query parameters: `ws://example.com/chat?token=abc123` * Secure connection: `wss://example.com` (not yet implemented) **Example**: ```vb ' Basic connection m_Client.Connect "ws://127.0.0.1:8080" ' Connection with path m_Client.Connect "ws://example.com/chat" ' Connection with query parameters m_Client.Connect "ws://example.com/chat?token=abc123" ' Specify sub-protocol m_Client.Connect "ws://example.com/chat", "chat.v1" ``` **Error Handling**: ```vb Private Sub cmdConnect_Click() On Error GoTo EH m_Client.Connect "ws://example.com:8080" Exit Sub EH: Debug.Print "Connection failed: " & Err.Description End Sub ``` *** ### CloseConnection - Close Connection **Syntax**: ```vb Public Sub CloseConnection(Optional ByVal Code As WsCloseCode = WS_CLOSE_NORMAL, _ Optional ByVal Reason As String = "") ``` **Parameters**: | Parameter | Type | Description | |-----------|------|-------------| | `Code` | WsCloseCode (Optional) | Close status code, default `WS_CLOSE_NORMAL` | | `Reason` | String (Optional) | Close reason | **Common Close Codes**: ```vb m_Client.CloseConnection WS_CLOSE_NORMAL, "Normal closure" m_Client.CloseConnection WS_CLOSE_GOING_AWAY, "User leaving" m_Client.CloseConnection WS_CLOSE_PROTOCOL_ERROR, "Protocol error" ``` **Example**: ```vb ' Normal close m_Client.CloseConnection ' Specify close code and reason m_Client.CloseConnection WS_CLOSE_GOING_AWAY, "User logout" ' Auto disconnect on form close Private Sub Form_Unload(Cancel As Integer) m_Client.CloseConnection WS_CLOSE_GOING_AWAY, "Application closing" End Sub ``` *** ### SendText - Send Text Message **Syntax**: ```vb Public Sub SendText(ByVal Message As String) ``` **Parameters**: | Parameter | Type | Description | |-----------|------|-------------| | `Message` | String | Text message to send | **Description**: Message is automatically converted to UTF-8 encoding and WebSocket frame header is added. Frames sent by client are automatically masked. **Example**: ```vb ' Send simple text m_Client.SendText "Hello WebSocket!" ' Send JSON data Dim sJSON As String sJSON = "{""type"":""message"", ""content"":""Hello""}" m_Client.SendText sJSON ' Send multi-line text m_Client.SendText "First line" & vbCrLf & "Second line" ``` **Error Handling**: ```vb On Error GoTo EH m_Client.SendText "Hello" Exit Sub EH: Debug.Print "Send failed: " & Err.Description ``` *** ### SendBinary - Send Binary Message **Syntax**: ```vb Public Sub SendBinary(Data() As Byte) ``` **Parameters**: | Parameter | Type | Description | |-----------|------|-------------| | `Data()` | Byte() | Binary data to send | **Example**: ```vb ' Send byte array Dim baData() As Byte baData = StringToBytes("Hello") m_Client.SendBinary baData ' Send image data Dim baImage() As Byte baImage = LoadImageToByteArray() m_Client.SendBinary baImage ' Send serialized object Dim baObj() As Byte baObj = SerializeObject(myObject) m_Client.SendBinary baObj ``` *** ### SendPing - Send Ping Frame **Syntax**: ```vb Public Sub SendPing(Optional Payload As Variant) ``` **Parameters**: | Parameter | Type | Description | |-----------|------|-------------| | `Payload` | Variant (Optional) | Ping payload, can be string or byte array | **Description**: Used for connection keepalive, server automatically replies with Pong frame. **Example**: ```vb ' Send empty Ping (keepalive) m_Client.SendPing ' Send Ping with data m_Client.SendPing "ping" ' Send Ping with binary data Dim baData() As Byte baData = StringToUTF8("ping") m_Client.SendPing baData ' Measure latency Dim lStartTime As Long lStartTime = GetTickCount() m_Client.SendPing "ping" Private Sub m_Client_OnPong(Data() As Byte) Dim lElapsed As Long lElapsed = GetTickCount() - lStartTime Debug.Print "Latency: " & lElapsed & " ms" End Sub ``` *** ## 📡 Event Details ### OnOpen - Connection Opened **Syntax**: ```vb Event OnOpen() ``` **Description**: Triggered after WebSocket handshake successful, now you can start sending messages. **Example**: ```vb Private Sub m_Client_OnOpen() Debug.Print "Successfully connected to WebSocket server" ' Send welcome message m_Client.SendText "Hello Server!" ' Update UI lblStatus.Caption = "Connected" cmdSend.Enabled = True End Sub ``` *** ### OnClose - Connection Closed **Syntax**: ```vb Event OnClose(ByVal Code As WsCloseCode, ByVal Reason As String) ``` **Parameters**: | Parameter | Type | Description | |-----------|------|-------------| | `Code` | WsCloseCode | Close status code | | `Reason` | String | Close reason | **Example**: ```vb Private Sub m_Client_OnClose(ByVal Code As WsCloseCode, ByVal Reason As String) Debug.Print "Connection closed" Debug.Print "Status code: " & Code Debug.Print "Reason: " & Reason ' Handle based on close code Select Case Code Case WS_CLOSE_NORMAL Debug.Print "Normal closure" Case WS_CLOSE_ABNORMAL Debug.Print "Abnormal closure" ' Try to reconnect If m_bAutoReconnect Then tmrReconnect.Enabled = True End If Case WS_CLOSE_GOING_AWAY Debug.Print "Server closed" Case Else Debug.Print "Other reason: " & Reason End Select ' Update UI lblStatus.Caption = "Disconnected" cmdSend.Enabled = False End Sub ``` *** ### OnTextMessage - Text Message Received **Syntax**: ```vb Event OnTextMessage(ByVal Message As String) ``` **Parameters**: | Parameter | Type | Description | |-----------|------|-------------| | `Message` | String | Received text message (UTF-8 decoded) | **Example**: ```vb Private Sub m_Client_OnTextMessage(ByVal Message As String) Debug.Print "Received message: " & Message ' Handle JSON message If Left$(Message, 1) = "{" Then Dim sType As String sType = GetJSONField(Message, "type") Select Case sType Case "chat" DisplayChatMessage Message Case "notification" DisplayNotification Message End Select Else ' Simple text message txtMessages.Text = txtMessages.Text & Message & vbCrLf End If End Sub ``` *** ### OnBinaryMessage - Binary Message Received **Syntax**: ```vb Event OnBinaryMessage(Data() As Byte) ``` **Parameters**: | Parameter | Type | Description | |-----------|------|-------------| | `Data()` | Byte() | Received binary data | **Example**: ```vb Private Sub m_Client_OnBinaryMessage(Data() As Byte) Debug.Print "Received binary message: " & (UBound(Data) + 1) & " bytes" ' Check data type (assume first 4 bytes are type identifier) If UBound(Data) >= 3 Then Dim lType As Long lType = CLng(Data(0)) * 256& ^ 3 + CLng(Data(1)) * 256& ^ 2 + _ CLng(Data(2)) * 256& + CLng(Data(3)) Select Case lType Case 1 ' Text Dim sText As String sText = UTF8ToString(ExtractData(Data, 4)) Debug.Print "Text data: " & sText Case 2 ' Image DisplayImage ExtractData(Data, 4) Case 3 ' Custom ProcessCustomData ExtractData(Data, 4) End Select End If End Sub ``` *** ### OnError - Error Occurred **Syntax**: ```vb Event OnError(ByVal Description As String) ``` **Parameters**: | Parameter | Type | Description | |-----------|------|-------------| | `Description` | String | Error description | **Example**: ```vb Private Sub m_Client_OnError(ByVal Description As String) Debug.Print "Error: " & Description ' Show error alert MsgBox "Error occurred: " & Description, vbExclamation ' Log error LogError Description ' Update UI lblStatus.Caption = "Error" End Sub ``` *** ### OnPong - Pong Received **Syntax**: ```vb Event OnPong(Data() As Byte) ``` **Parameters**: | Parameter | Type | Description | |-----------|------|-------------| | `Data()` | Byte() | Pong payload (corresponds to Ping data) | **Description**: Usually used for measuring network latency or confirming connection activity. **Example**: ```vb Private m_lPingTimes() As Long Private m_lPingIndex As Long Private Sub SendPingForLatency() ReDim m_lPingTimes(1) As Long m_lPingIndex = 0 m_lPingTimes(0) = GetTickCount() m_Client.SendPing "ping" End Sub Private Sub m_Client_OnPong(Data() As Byte) m_lPingTimes(1) = GetTickCount() Dim lLatency As Long lLatency = m_lPingTimes(1) - m_lPingTimes(0) Debug.Print "Network latency: " & lLatency & " ms" ' Update UI lblLatency.Caption = lLatency & " ms" End Sub ``` *** ## 📝 Complete Example ### Basic Client Example ```vb Private WithEvents m_Client As cWebSocketClient Private Sub Form_Load() Set m_Client = New cWebSocketClient End Sub Private Sub cmdConnect_Click() m_Client.Connect "ws://127.0.0.1:8080" End Sub Private Sub cmdSend_Click() m_Client.SendText txtMessage.Text End Sub Private Sub cmdDisconnect_Click() m_Client.CloseConnection End Sub Private Sub m_Client_OnOpen() Debug.Print "Connected" cmdSend.Enabled = True End Sub Private Sub m_Client_OnTextMessage(ByVal Message As String) txtLog.Text = txtLog.Text & Message & vbCrLf End Sub Private Sub m_Client_OnClose(ByVal Code As WsCloseCode, ByVal Reason As String) Debug.Print "Disconnected: " & Reason cmdSend.Enabled = False End Sub ``` ### Client with Reconnect ```vb Private WithEvents m_Client As cWebSocketClient Private m_bAutoReconnect As Boolean Private m_sServerURL As String Private Sub Form_Load() Set m_Client = New cWebSocketClient m_bAutoReconnect = True m_sServerURL = "ws://127.0.0.1:8080" ConnectToServer End Sub Private Sub ConnectToServer() If m_Client.State = WS_STATE_CLOSED Then Debug.Print "Connecting..." m_Client.Connect m_sServerURL End If End Sub Private Sub m_Client_OnOpen() Debug.Print "Connected" tmrReconnect.Enabled = False End Sub Private Sub m_Client_OnClose(ByVal Code As WsCloseCode, ByVal Reason As String) Debug.Print "Connection closed: " & Reason If m_bAutoReconnect Then Debug.Print "Reconnecting in 3 seconds..." tmrReconnect.Interval = 3000 tmrReconnect.Enabled = True End If End Sub Private Sub tmrReconnect_Timer() tmrReconnect.Enabled = False ConnectToServer End Sub ``` *** **Last Updated**: 2026-01-10 --- --- url: /zh/vbman/websocket/frame.md --- # cWebSocketFrame 类参考 ## 📋 类概述 `cWebSocketFrame` 是 WebSocket 帧解析和构建类，用于处理 WebSocket 协议的帧格式。 ### 设计特点 * **只读解析** - `ParseHeader()` 不会修改输入数据 * **分离 unmask** - 解析头部后，再单独提取并 unmask 负载 * **支持构建** - 可以构建各种类型的 WebSocket 帧 * **分片支持** - 正确处理分片帧（CONTINUATION） *** ## 📊 属性参考 ### FIN - 最终帧标志 **类型**: `Boolean`\ **读写**: 只读（解析后） **说明**: 标识这是否是消息的最后一帧。 ```vb If oFrame.FIN Then Debug.Print "这是最后一帧" Else Debug.Print "还有后续帧" End If ``` *** ### RSV1, RSV2, RSV3 - 保留位 **类型**: `Boolean`\ **读写**: 只读（解析后） **说明**: WebSocket 协议的保留位。通常为 `False`，用于扩展。 ```vb If oFrame.RSV1 Or oFrame.RSV2 Or oFrame.RSV3 Then Debug.Print "使用了扩展" End If ``` *** ### OpCode - 操作码 **类型**: `WsOpCode` (枚举)\ **读写**: 只读（解析后） **值**: | OpCode | 常量 | 说明 | |--------|-------|------| | 0 | WS\_OPCODE\_CONTINUATION | 分片帧的后续帧 | | 1 | WS\_OPCODE\_TEXT | 文本数据帧 | | 2 | WS\_OPCODE\_BINARY | 二进制数据帧 | | 8 | WS\_OPCODE\_CLOSE | 关闭连接帧 | | 9 | WS\_OPCODE\_PING | Ping 帧 | | 10 | WS\_OPCODE\_PONG | Pong 帧 | ```vb Select Case oFrame.OpCode Case WS_OPCODE_TEXT Debug.Print "文本帧" Case WS_OPCODE_BINARY Debug.Print "二进制帧" Case WS_OPCODE_CLOSE Debug.Print "关闭帧" Case WS_OPCODE_PING Debug.Print "Ping 帧" Case WS_OPCODE_PONG Debug.Print "Pong 帧" End Select ``` *** ### HasMask - 是否有掩码 **类型**: `Boolean`\ **读写**: 只读（解析后） **说明**: 标识负载是否使用了掩码。客户端发送的帧必须有掩码，服务端发送的帧不应有掩码。 ```vb If oFrame.HasMask Then Debug.Print "帧已掩码" Else Debug.Print "帧未掩码" End If ``` *** ### PayloadLength - 负载长度 **类型**: `Long`\ **读写**: 只读（解析后） **说明**: 帧负载数据的长度（字节数）。 ```vb Debug.Print "负载长度: " & oFrame.PayloadLength & " 字节" ``` *** ### HeaderLength - 头部长度 **类型**: `Long`\ **读写**: 只读（解析后） **说明**: WebSocket 帧头的长度（包括扩展长度和掩码键）。 ```vb Debug.Print "头部长度: " & oFrame.HeaderLength & " 字节" ``` *** ### TotalFrameLength - 总帧长度 **类型**: `Long`\ **读写**: 只读（解析后） **说明**: 完整帧的长度（头部 + 负载）。 ```vb Debug.Print "总帧长度: " & oFrame.TotalFrameLength & " 字节" ``` *** ### IsValid - 是否有效 **类型**: `Boolean`\ **读写**: 只读（解析后） **说明**: 帧头是否成功解析且有效。 ```vb If oFrame.IsValid Then Debug.Print "帧有效" Else Debug.Print "帧无效: " & oFrame.ErrorMessage End If ``` *** ### ErrorMessage - 错误消息 **类型**: `String`\ **读写**: 只读（解析后） **说明**: 当帧无效时，包含错误描述。 ```vb If Not oFrame.IsValid Then Debug.Print "错误: " & oFrame.ErrorMessage End If ``` *** ### IsControlFrame - 是否为控制帧 **类型**: `Boolean`\ **读写**: 只读 **说明**: 判断当前帧是否为控制帧（CLOSE、PING、PONG）。 ```vb If oFrame.IsControlFrame Then Debug.Print "这是控制帧" ' 控制帧不能分片 If Not oFrame.FIN Then Debug.Print "警告：控制帧不应分片" End If End If ``` *** ### IsDataFrame - 是否为数据帧 **类型**: `Boolean`\ **读写**: 只读 **说明**: 判断当前帧是否为数据帧（TEXT、BINARY、CONTINUATION）。 ```vb If oFrame.IsDataFrame Then Debug.Print "这是数据帧" ' 可以分片 End If ``` *** ## 🚀 方法参考 ### ParseHeader - 解析帧头 **语法**: ```vb Public Function ParseHeader(ByRef Buffer As cByteBuffer) As Boolean ``` **参数**: | 参数 | 类型 | 说明 | |------|------|------| | `Buffer` | cByteBuffer | 字节缓冲区 | **返回值**: `Boolean` - 解析成功返回 `True`，否则返回 `False` **说明**: * **只读操作** - 不会修改或消费缓冲区数据 * 需要至少 2 字节数据才能解析 * 解析后可通过属性访问帧头信息 **示例**: ```vb Dim oFrame As New cWebSocketFrame Dim oBuffer As cByteBuffer Set oBuffer = New cByteBuffer oBuffer.Append baReceivedData ' 解析头部 If oFrame.ParseHeader(oBuffer) Then Debug.Print "帧类型: " & oFrame.OpCode Debug.Print "负载长度: " & oFrame.PayloadLength ' 检查是否完整 If oFrame.IsCompleteFrame(oBuffer) Then ' 提取负载 Dim baPayload() As Byte baPayload = oFrame.ExtractPayload(oBuffer) End If Else Debug.Print "解析失败: " & oFrame.ErrorMessage End If ``` *** ### IsCompleteFrame - 检查帧是否完整 **语法**: ```vb Public Function IsCompleteFrame(ByRef Buffer As cByteBuffer) As Boolean ``` **参数**: | 参数 | 类型 | 说明 | |------|------|------| | `Buffer` | cByteBuffer | 字节缓冲区 | **返回值**: `Boolean` - 帧完整返回 `True`，否则返回 `False` **说明**: * 必须先调用 `ParseHeader()` 成功 * 检查缓冲区是否包含完整的帧 **示例**: ```vb If oFrame.ParseHeader(oBuffer) Then ' 检查是否完整 If oFrame.IsCompleteFrame(oBuffer) Then ' 可以提取 baPayload = oFrame.ExtractPayload(oBuffer) Else Debug.Print "需要更多数据" End If End If ``` *** ### ExtractPayload - 提取并 unmask 负载 **语法**: ```vb Public Function ExtractPayload(ByRef Buffer As cByteBuffer) As Byte() ``` **参数**: | 参数 | 类型 | 说明 | |------|------|------| | `Buffer` | cByteBuffer | 字节缓冲区 | **返回值**: `Byte()` - 提取的负载数据（已 unmask） **说明**: * 必须先调用 `ParseHeader()` 成功 * 会**消费**整个帧（从缓冲区移除） * 自动执行 unmask 操作（如果帧有掩码） **示例**: ```vb ' 完整的帧处理流程 If oFrame.ParseHeader(oBuffer) Then If oFrame.IsCompleteFrame(oBuffer) Then ' 提取负载（消费帧） Dim baPayload() As Byte baPayload = oFrame.ExtractPayload(oBuffer) ' 处理负载 ProcessPayload baPayload, oFrame.OpCode End If End If ``` *** ### SkipFrame - 跳过帧 **语法**: ```vb Public Sub SkipFrame(ByRef Buffer As cByteBuffer) ``` **参数**: | 参数 | 类型 | 说明 | |------|------|------| | `Buffer` | cByteBuffer | 字节缓冲区 | **说明**: 从缓冲区中移除整个帧，但不提取负载。用于处理不需要的帧。 **示例**: ```vb ' 跳过控制帧 If oFrame.ParseHeader(oBuffer) Then If oFrame.IsControlFrame Then ' 跳过控制帧 oFrame.SkipFrame oBuffer Else ' 处理数据帧 baPayload = oFrame.ExtractPayload(oBuffer) End If End If ``` *** ### BuildFrame - 构建帧 **语法**: ```vb Public Function BuildFrame(ByRef Payload() As Byte, _ ByVal OpCode As WsOpCode, _ Optional ByVal UseMask As Boolean = False, _ Optional ByVal IsFinal As Boolean = True) As Byte() ``` **参数**: | 参数 | 类型 | 说明 | |------|------|------| | `Payload` | Byte() | 负载数据 | | `OpCode` | WsOpCode | 操作码 | | `UseMask` | Boolean | 是否掩码 | | `IsFinal` | Boolean | 是否为最终帧 | **返回值**: `Byte()` - 完整的 WebSocket 帧字节数组 **说明**: * 客户端发送必须掩码 (`UseMask = True`) * 服务端发送不应掩码 (`UseMask = False`) * 掩码时自动生成随机掩码键 **示例**: ```vb ' 客户端发送（必须掩码） Dim baFrame() As Byte Dim baData() As Byte baData = StringToUTF8("Hello") baFrame = oFrame.BuildFrame(baData, WS_OPCODE_TEXT, True, True) Socket.SendData baFrame ' 服务端发送（不掩码） baFrame = oFrame.BuildFrame(baData, WS_OPCODE_TEXT, False, True) Socket.SendData baFrame ``` *** ### BuildTextFrame - 构建文本帧 **语法**: ```vb Public Function BuildTextFrame(ByVal Text As String, _ Optional ByVal UseMask As Boolean = False) As Byte() ``` **参数**: | 参数 | 类型 | 说明 | |------|------|------| | `Text` | String | 文本内容 | | `UseMask` | Boolean | 是否掩码 | **返回值**: `Byte()` - WebSocket 文本帧 **说明**: 文本会自动转换为 UTF-8 编码。 **示例**: ```vb ' 客户端发送文本 Dim baFrame() As Byte baFrame = oFrame.BuildTextFrame("Hello WebSocket!", True) Socket.SendData baFrame ``` *** ### BuildBinaryFrame - 构建二进制帧 **语法**: ```vb Public Function BuildBinaryFrame(ByRef Data() As Byte, _ Optional ByVal UseMask As Boolean = False) As Byte() ``` **参数**: | 参数 | 类型 | 说明 | |------|------|------| | `Data()` | Byte() | 二进制数据 | | `UseMask` | Boolean | 是否掩码 | **返回值**: `Byte()` - WebSocket 二进制帧 **示例**: ```vb ' 客户端发送二进制 Dim baData() As Byte baData = LoadFile("image.png") Dim baFrame() As Byte baFrame = oFrame.BuildBinaryFrame(baData, True) Socket.SendData baFrame ``` *** ### BuildCloseFrame - 构建关闭帧 **语法**: ```vb Public Function BuildCloseFrame(Optional ByVal StatusCode As WsCloseCode = WS_CLOSE_NORMAL, _ Optional ByVal Reason As String = "", _ Optional ByVal UseMask As Boolean = False) As Byte() ``` **参数**: | 参数 | 类型 | 说明 | |------|------|------| | `StatusCode` | WsCloseCode（可选） | 关闭状态码 | | `Reason` | String（可选） | 关闭原因 | | `UseMask` | Boolean（可选） | 是否掩码 | **返回值**: `Byte()` - WebSocket 关闭帧 **示例**: ```vb ' 正常关闭 Dim baFrame() As Byte baFrame = oFrame.BuildCloseFrame(WS_CLOSE_NORMAL, "正常关闭", True) Socket.SendData baFrame ' 协议错误 baFrame = oFrame.BuildCloseFrame(WS_CLOSE_PROTOCOL_ERROR, "无效帧", True) Socket.SendData baFrame ``` *** ### BuildPingFrame - 构建 Ping 帧 **语法**: ```vb Public Function BuildPingFrame(ByRef Payload() As Byte, _ Optional ByVal UseMask As Boolean = False) As Byte() ``` **参数**: | 参数 | 类型 | 说明 | |------|------|------| | `Payload()` | Byte() | Ping 负载 | | `UseMask` | Boolean（可选） | 是否掩码 | **返回值**: `Byte()` - WebSocket Ping 帧 **示例**: ```vb ' 发送空 Ping Dim baEmpty() As Byte Dim baFrame() As Byte baFrame = oFrame.BuildPingFrame(baEmpty, True) Socket.SendData baFrame ' 发送带数据的 Ping Dim baData() As Byte baData = StringToUTF8("ping") baFrame = oFrame.BuildPingFrame(baData, True) Socket.SendData baFrame ``` *** ### BuildPongFrame - 构建 Pong 帧 **语法**: ```vb Public Function BuildPongFrame(ByRef Payload() As Byte, _ Optional ByVal UseMask As Boolean = False) As Byte() ``` **参数**: | 参数 | 类型 | 说明 | |------|------|------| | `Payload()` | Byte() | Pong 负载 | | `UseMask` | Boolean（可选） | 是否掩码 | **返回值**: `Byte()` - WebSocket Pong 帧 **示例**: ```vb ' 回复 Pong（使用 Ping 的负载） Dim baFrame() As Byte baFrame = oFrame.BuildPongFrame(baPingPayload, True) Socket.SendData baFrame ``` *** ## 📝 使用示例 ### 基本帧解析流程 ```vb Private Sub ProcessWebSocketFrame(oBuffer As cByteBuffer) Dim oFrame As New cWebSocketFrame Do While oBuffer.Size >= 2 ' 1. 解析头部（只读） If Not oFrame.ParseHeader(oBuffer) Then Debug.Print "需要更多数据" Exit Do End If ' 2. 检查完整性 If Not oFrame.IsCompleteFrame(oBuffer) Then Debug.Print "需要更多数据" Exit Do End If ' 3. 提取负载（消费帧） Dim baPayload() As Byte baPayload = oFrame.ExtractPayload(oBuffer) ' 4. 处理帧 Select Case oFrame.OpCode Case WS_OPCODE_TEXT Dim sText As String sText = UTF8ToString(baPayload) Debug.Print "文本: " & sText Case WS_OPCODE_BINARY Debug.Print "二进制: " & (UBound(baPayload) + 1) & " 字节" Case WS_OPCODE_CLOSE Debug.Print "关闭帧" ProcessCloseFrame baPayload Case WS_OPCODE_PING Debug.Print "Ping 帧" ' 自动回复 Pong Dim baPong() As Byte baPong = oFrame.BuildPongFrame(baPayload, False) SendData baPong Case WS_OPCODE_PONG Debug.Print "Pong 帧" End Select Loop End Sub ``` ### 构建并发送帧 ```vb ' 客户端发送文本 Private Sub SendTextMessage(ByVal sText As String) Dim oFrame As New cWebSocketFrame Dim baFrame() As Byte ' 构建文本帧（必须掩码） baFrame = oFrame.BuildTextFrame(sText, True) ' 发送 m_Socket.SendData baFrame End Sub ' 客户端发送二进制 Private Sub SendBinaryMessage(ByVal baData() As Byte) Dim oFrame As New cWebSocketFrame Dim baFrame() As Byte ' 构建二进制帧（必须掩码） baFrame = oFrame.BuildBinaryFrame(baData, True) ' 发送 m_Socket.SendData baFrame End Sub ' 发送关闭帧 Private Sub SendCloseFrame() Dim oFrame As New cWebSocketFrame Dim baFrame() As Byte ' 构建关闭帧（必须掩码） baFrame = oFrame.BuildCloseFrame(WS_CLOSE_NORMAL, "正常关闭", True) ' 发送 m_Socket.SendData baFrame End Sub ``` *** **最后更新**: 2026-01-10 --- --- url: /en/vbman/websocket/frame.md --- # cWebSocketFrame Class Reference ## 📋 Class Overview `cWebSocketFrame` is a WebSocket frame parsing and building class, used to handle WebSocket protocol frame formats. ### Design Features * **Read-only parsing** - `ParseHeader()` does not modify input data * **Separated unmasking** - After parsing header, extract and unmask payload separately * **Build support** - Can build various types of WebSocket frames * **Fragmentation support** - Correctly handles fragmented frames (CONTINUATION) *** ## 📊 Property Reference ### FIN - Final Frame Flag **Type**: `Boolean`\ **Read/Write**: Read-only (after parsing) **Description**: Indicates whether this is the last frame of the message. ```vb If oFrame.FIN Then Debug.Print "This is the last frame" Else Debug.Print "More frames to come" End If ``` *** ### RSV1, RSV2, RSV3 - Reserved Bits **Type**: `Boolean`\ **Read/Write**: Read-only (after parsing) **Description**: Reserved bits in the WebSocket protocol. Usually `False`, used for extensions. ```vb If oFrame.RSV1 Or oFrame.RSV2 Or oFrame.RSV3 Then Debug.Print "Extension used" End If ``` *** ### OpCode - Operation Code **Type**: `WsOpCode` (Enum)\ **Read/Write**: Read-only (after parsing) **Values**: | OpCode | Constant | Description | |--------|----------|-------------| | 0 | WS\_OPCODE\_CONTINUATION | Continuation frames for fragmented messages | | 1 | WS\_OPCODE\_TEXT | Text data frame | | 2 | WS\_OPCODE\_BINARY | Binary data frame | | 8 | WS\_OPCODE\_CLOSE | Connection close frame | | 9 | WS\_OPCODE\_PING | Ping frame | | 10 | WS\_OPCODE\_PONG | Pong frame | ```vb Select Case oFrame.OpCode Case WS_OPCODE_TEXT Debug.Print "Text frame" Case WS_OPCODE_BINARY Debug.Print "Binary frame" Case WS_OPCODE_CLOSE Debug.Print "Close frame" Case WS_OPCODE_PING Debug.Print "Ping frame" Case WS_OPCODE_PONG Debug.Print "Pong frame" End Select ``` *** ### HasMask - Has Masking **Type**: `Boolean`\ **Read/Write**: Read-only (after parsing) **Description**: Indicates whether the payload is masked. Frames sent by client must be masked, frames sent by server should not be masked. ```vb If oFrame.HasMask Then Debug.Print "Frame is masked" Else Debug.Print "Frame is not masked" End If ``` *** ### PayloadLength - Payload Length **Type**: `Long`\ **Read/Write**: Read-only (after parsing) **Description**: The length of the frame payload data in bytes. ```vb Debug.Print "Payload length: " & oFrame.PayloadLength & " bytes" ``` *** ### HeaderLength - Header Length **Type**: `Long`\ **Read/Write**: Read-only (after parsing) **Description**: The length of the WebSocket frame header (including extended length and masking key). ```vb Debug.Print "Header length: " & oFrame.HeaderLength & " bytes" ``` *** ### TotalFrameLength - Total Frame Length **Type**: `Long`\ **Read/Write**: Read-only (after parsing) **Description**: The complete frame length (header + payload). ```vb Debug.Print "Total frame length: " & oFrame.TotalFrameLength & " bytes" ``` *** ### IsValid - Is Valid **Type**: `Boolean`\ **Read/Write**: Read-only (after parsing) **Description**: Whether the frame header was successfully parsed and is valid. ```vb If oFrame.IsValid Then Debug.Print "Frame is valid" Else Debug.Print "Frame is invalid: " & oFrame.ErrorMessage End If ``` *** ### ErrorMessage - Error Message **Type**: `String`\ **Read/Write**: Read-only (after parsing) **Description**: Contains error description when frame is invalid. ```vb If Not oFrame.IsValid Then Debug.Print "Error: " & oFrame.ErrorMessage End If ``` *** ### IsControlFrame - Is Control Frame **Type**: `Boolean`\ **Read/Write**: Read-only **Description**: Determines whether the current frame is a control frame (CLOSE, PING, PONG). ```vb If oFrame.IsControlFrame Then Debug.Print "This is a control frame" ' Control frames cannot be fragmented If Not oFrame.FIN Then Debug.Print "Warning: Control frames should not be fragmented" End If End If ``` *** ### IsDataFrame - Is Data Frame **Type**: `Boolean`\ **Read/Write**: Read-only **Description**: Determines whether the current frame is a data frame (TEXT, BINARY, CONTINUATION). ```vb If oFrame.IsDataFrame Then Debug.Print "This is a data frame" ' Can be fragmented End If ``` *** ## 🚀 Method Reference ### ParseHeader - Parse Frame Header **Syntax**: ```vb Public Function ParseHeader(ByRef Buffer As cByteBuffer) As Boolean ``` **Parameters**: | Parameter | Type | Description | |-----------|------|-------------| | `Buffer` | cByteBuffer | Byte buffer | **Return Value**: `Boolean` - Returns `True` if parsing successful, otherwise `False` **Description**: * **Read-only operation** - Does not modify or consume buffer data * Requires at least 2 bytes of data to parse * After parsing, frame header information can be accessed through properties **Example**: ```vb Dim oFrame As New cWebSocketFrame Dim oBuffer As cByteBuffer Set oBuffer = New cByteBuffer oBuffer.Append baReceivedData ' Parse header If oFrame.ParseHeader(oBuffer) Then Debug.Print "Frame type: " & oFrame.OpCode Debug.Print "Payload length: " & oFrame.PayloadLength ' Check if complete If oFrame.IsCompleteFrame(oBuffer) Then ' Extract payload Dim baPayload() As Byte baPayload = oFrame.ExtractPayload(oBuffer) End If Else Debug.Print "Parsing failed: " & oFrame.ErrorMessage End If ``` *** ### IsCompleteFrame - Check if Frame is Complete **Syntax**: ```vb Public Function IsCompleteFrame(ByRef Buffer As cByteBuffer) As Boolean ``` **Parameters**: | Parameter | Type | Description | |-----------|------|-------------| | `Buffer` | cByteBuffer | Byte buffer | **Return Value**: `Boolean` - Returns `True` if frame is complete, otherwise `False` **Description**: * Must call `ParseHeader()` successfully first * Checks if buffer contains a complete frame **Example**: ```vb If oFrame.ParseHeader(oBuffer) Then ' Check completeness If oFrame.IsCompleteFrame(oBuffer) Then ' Can extract baPayload = oFrame.ExtractPayload(oBuffer) Else Debug.Print "Need more data" End If End If ``` *** ### ExtractPayload - Extract and Unmask Payload **Syntax**: ```vb Public Function ExtractPayload(ByRef Buffer As cByteBuffer) As Byte() ``` **Parameters**: | Parameter | Type | Description | |-----------|------|-------------| | `Buffer` | cByteBuffer | Byte buffer | **Return Value**: `Byte()` - Extracted payload data (unmasked) **Description**: * Must call `ParseHeader()` successfully first * Will **consume** the entire frame (remove from buffer) * Automatically performs unmasking (if frame has masking) **Example**: ```vb ' Complete frame processing flow If oFrame.ParseHeader(oBuffer) Then If oFrame.IsCompleteFrame(oBuffer) Then ' Extract payload (consume frame) Dim baPayload() As Byte baPayload = oFrame.ExtractPayload(oBuffer) ' Process payload ProcessPayload baPayload, oFrame.OpCode End If End If ``` *** ### SkipFrame - Skip Frame **Syntax**: ```vb Public Sub SkipFrame(ByRef Buffer As cByteBuffer) ``` **Parameters**: | Parameter | Type | Description | |-----------|------|-------------| | `Buffer` | cByteBuffer | Byte buffer | **Description**: Removes the entire frame from the buffer without extracting payload. Used for processing unwanted frames. **Example**: ```vb ' Skip control frames If oFrame.ParseHeader(oBuffer) Then If oFrame.IsControlFrame Then ' Skip control frame oFrame.SkipFrame oBuffer Else ' Process data frame baPayload = oFrame.ExtractPayload(oBuffer) End If End If ``` *** ### BuildFrame - Build Frame **Syntax**: ```vb Public Function BuildFrame(ByRef Payload() As Byte, _ ByVal OpCode As WsOpCode, _ Optional ByVal UseMask As Boolean = False, _ Optional ByVal IsFinal As Boolean = True) As Byte() ``` **Parameters**: | Parameter | Type | Description | |-----------|------|-------------| | `Payload` | Byte() | Payload data | | `OpCode` | WsOpCode | Operation code | | `UseMask` | Boolean | Whether to mask | | `IsFinal` | Boolean | Whether this is the final frame | **Return Value**: `Byte()` - Complete WebSocket frame byte array **Description**: * Client sending must be masked (`UseMask = True`) * Server sending should not be masked (`UseMask = False`) * Automatically generates random masking key when masking **Example**: ```vb ' Client sending (must mask) Dim baFrame() As Byte Dim baData() As Byte baData = StringToUTF8("Hello") baFrame = oFrame.BuildFrame(baData, WS_OPCODE_TEXT, True, True) Socket.SendData baFrame ' Server sending (no mask) baFrame = oFrame.BuildFrame(baData, WS_OPCODE_TEXT, False, True) Socket.SendData baFrame ``` *** ### BuildTextFrame - Build Text Frame **Syntax**: ```vb Public Function BuildTextFrame(ByVal Text As String, _ Optional ByVal UseMask As Boolean = False) As Byte() ``` **Parameters**: | Parameter | Type | Description | |-----------|------|-------------| | `Text` | String | Text content | | `UseMask` | Boolean | Whether to mask | **Return Value**: `Byte()` - WebSocket text frame **Description**: Text is automatically converted to UTF-8 encoding. **Example**: ```vb ' Client sending text Dim baFrame() As Byte baFrame = oFrame.BuildTextFrame("Hello WebSocket!", True) Socket.SendData baFrame ``` *** ### BuildBinaryFrame - Build Binary Frame **Syntax**: ```vb Public Function BuildBinaryFrame(ByRef Data() As Byte, _ Optional ByVal UseMask As Boolean = False) As Byte() ``` **Parameters**: | Parameter | Type | Description | |-----------|------|-------------| | `Data()` | Byte() | Binary data | | `UseMask` | Boolean | Whether to mask | **Return Value**: `Byte()` - WebSocket binary frame **Example**: ```vb ' Client sending binary Dim baData() As Byte baData = LoadFile("image.png") Dim baFrame() As Byte baFrame = oFrame.BuildBinaryFrame(baData, True) Socket.SendData baFrame ``` *** ### BuildCloseFrame - Build Close Frame **Syntax**: ```vb Public Function BuildCloseFrame(Optional ByVal StatusCode As WsCloseCode = WS_CLOSE_NORMAL, _ Optional ByVal Reason As String = "", _ Optional ByVal UseMask As Boolean = False) As Byte() ``` **Parameters**: | Parameter | Type | Description | |-----------|------|-------------| | `StatusCode` | WsCloseCode (Optional) | Close status code | | `Reason` | String (Optional) | Close reason | | `UseMask` | Boolean (Optional) | Whether to mask | **Return Value**: `Byte()` - WebSocket close frame **Example**: ```vb ' Normal close Dim baFrame() As Byte baFrame = oFrame.BuildCloseFrame(WS_CLOSE_NORMAL, "Normal closure", True) Socket.SendData baFrame ' Protocol error baFrame = oFrame.BuildCloseFrame(WS_CLOSE_PROTOCOL_ERROR, "Invalid frame", True) Socket.SendData baFrame ``` *** ### BuildPingFrame - Build Ping Frame **Syntax**: ```vb Public Function BuildPingFrame(ByRef Payload() As Byte, _ Optional ByVal UseMask As Boolean = False) As Byte() ``` **Parameters**: | Parameter | Type | Description | |-----------|------|-------------| | `Payload()` | Byte() | Ping payload | | `UseMask` | Boolean (Optional) | Whether to mask | **Return Value**: `Byte()` - WebSocket Ping frame **Example**: ```vb ' Send empty Ping Dim baEmpty() As Byte Dim baFrame() As Byte baFrame = oFrame.BuildPingFrame(baEmpty, True) Socket.SendData baFrame ' Send Ping with data Dim baData() As Byte baData = StringToUTF8("ping") baFrame = oFrame.BuildPingFrame(baData, True) Socket.SendData baFrame ``` *** ### BuildPongFrame - Build Pong Frame **Syntax**: ```vb Public Function BuildPongFrame(ByRef Payload() As Byte, _ Optional ByVal UseMask As Boolean = False) As Byte() ``` **Parameters**: | Parameter | Type | Description | |-----------|------|-------------| | `Payload()` | Byte() | Pong payload | | `UseMask` | Boolean (Optional) | Whether to mask | **Return Value**: `Byte()` - WebSocket Pong frame **Example**: ```vb ' Reply Pong (using Ping's payload) Dim baFrame() As Byte baFrame = oFrame.BuildPongFrame(baPingPayload, True) Socket.SendData baFrame ``` *** ## 📝 Usage Examples ### Basic Frame Parsing Flow ```vb Private Sub ProcessWebSocketFrame(oBuffer As cByteBuffer) Dim oFrame As New cWebSocketFrame Do While oBuffer.Size >= 2 ' 1. Parse header (read-only) If Not oFrame.ParseHeader(oBuffer) Then Debug.Print "Need more data" Exit Do End If ' 2. Check completeness If Not oFrame.IsCompleteFrame(oBuffer) Then Debug.Print "Need more data" Exit Do End If ' 3. Extract payload (consume frame) Dim baPayload() As Byte baPayload = oFrame.ExtractPayload(oBuffer) ' 4. Process frame Select Case oFrame.OpCode Case WS_OPCODE_TEXT Dim sText As String sText = UTF8ToString(baPayload) Debug.Print "Text: " & sText Case WS_OPCODE_BINARY Debug.Print "Binary: " & (UBound(baPayload) + 1) & " bytes" Case WS_OPCODE_CLOSE Debug.Print "Close frame" ProcessCloseFrame baPayload Case WS_OPCODE_PING Debug.Print "Ping frame" ' Auto reply Pong Dim baPong() As Byte baPong = oFrame.BuildPongFrame(baPayload, False) SendData baPong Case WS_OPCODE_PONG Debug.Print "Pong frame" End Select Loop End Sub ``` ### Build and Send Frame ```vb ' Client sending text Private Sub SendTextMessage(ByVal sText As String) Dim oFrame As New cWebSocketFrame Dim baFrame() As Byte ' Build text frame (must mask) baFrame = oFrame.BuildTextFrame(sText, True) ' Send m_Socket.SendData baFrame End Sub ' Client sending binary Private Sub SendBinaryMessage(ByVal baData() As Byte) Dim oFrame As New cWebSocketFrame Dim baFrame() As Byte ' Build binary frame (must mask) baFrame = oFrame.BuildBinaryFrame(baData, True) ' Send m_Socket.SendData baFrame End Sub ' Send close frame Private Sub SendCloseFrame() Dim oFrame As New cWebSocketFrame Dim baFrame() As Byte ' Build close frame (must mask) baFrame = oFrame.BuildCloseFrame(WS_CLOSE_NORMAL, "Normal closure", True) ' Send m_Socket.SendData baFrame End Sub ``` *** **Last Updated**: 2026-01-10 --- --- url: /zh/vbman/websocket/server.md --- # cWebSocketServer 类参考 ## 📋 类概述 `cWebSocketServer` 是 WebSocket 服务端实现类，提供监听端口、管理多个客户端连接、广播消息等功能。 *** ## 📡 事件列表 | 事件名 | 触发时机 | 参数 | |--------|----------|------| | `OnStart` | 服务器启动 | `Port` (监听端口) | | `OnStop` | 服务器停止 | 无 | | `OnClientConnect` | 新客户端连接 | `ClientID`, `RemoteAddress`, `RemotePort` | | `OnClientDisconnect` | 客户端断开 | `ClientID`, `Reason` | | `OnClientTextMessage` | 收到客户端文本消息 | `ClientID`, `Message` | | `OnClientBinaryMessage` | 收到客户端二进制消息 | `ClientID`, `Data()` | | `OnError` | 发生错误 | `Description` | *** ## 🔧 属性参考 ### Port - 监听端口 **类型**: `Long`\ **读写**: 只读 **说明**: 当前监听的端口号。 **示例**: ```vb Debug.Print "服务器监听端口: " & m_Server.Port ``` *** ### IsListening - 是否监听中 **类型**: `Boolean`\ **读写**: 只读 **说明**: 服务器是否正在监听。 **示例**: ```vb If m_Server.IsListening Then Debug.Print "服务器正在监听" End If ``` *** ### ClientCount - 客户端连接数 **类型**: `Long`\ **读写**: 只读 **说明**: 当前连接的客户端数量。 **示例**: ```vb Debug.Print "当前连接数: " & m_Server.ClientCount ' 更新 UI lblClientCount.Caption = "连接数: " & m_Server.ClientCount ``` *** ### ClientIDs - 客户端 ID 数组 **类型**: `Variant` (String 数组)\ **读写**: 只读 **说明**: 所有连接客户端的 ID 数组。 **示例**: ```vb ' 获取所有客户端 ID Dim vIDs() As Variant vIDs = m_Server.ClientIDs ' 遍历所有客户端 ID Dim i As Long For i = LBound(vIDs) To UBound(vIDs) Debug.Print "客户端: " & vIDs(i) Next i ``` *** ## 🚀 方法参考 ### Listen - 启动监听 **语法**: ```vb Public Sub Listen(Optional ByVal Port As Long = 8080) ``` **参数**: | 参数 | 类型 | 说明 | |------|------|------| | `Port` | Long（可选） | 监听端口号，默认 8080 | **说明**: * 如果服务器已在监听，会先停止再启动 * 启动后会触发 `OnStart` 事件 * 会自动初始化客户端集合 **示例**: ```vb ' 使用默认端口 8080 m_Server.Listen ' 指定端口 m_Server.Listen 9000 ' 从配置文件读取端口 m_Server.Listen CLng(GetConfig("ServerPort")) ``` **错误处理**: ```vb Private Sub cmdStart_Click() On Error GoTo EH m_Server.Listen CLng(txtPort.Text) Debug.Print "服务器已启动" Exit Sub EH: Debug.Print "启动失败: " & Err.Description MsgBox "无法启动服务器: " & Err.Description, vbExclamation End Sub ``` *** ### StopServer - 停止服务器 **语法**: ```vb Public Sub StopServer() ``` **说明**: * 会向所有客户端发送关闭帧 * 关闭所有客户端连接 * 清空客户端集合 * 关闭监听 Socket * 触发 `OnStop` 事件 **示例**: ```vb ' 停止服务器 m_Server.StopServer Debug.Print "服务器已停止" ' 窗体关闭时自动停止 Private Sub Form_Unload(Cancel As Integer) m_Server.StopServer End Sub ``` *** ### SendText - 发送文本消息 **语法**: ```vb Public Sub SendText(ByVal ClientID As String, ByVal Message As String) ``` **参数**: | 参数 | 类型 | 说明 | |------|------|------| | `ClientID` | String | 目标客户端 ID | | `Message` | String | 要发送的文本消息 | **说明**: 向指定客户端发送文本消息。消息会自动添加 WebSocket 帧头，服务端发送不进行掩码。 **示例**: ```vb ' 发送欢迎消息 m_Server.SendText ClientID, "欢迎连接到 WebSocket 服务器！" ' 回显消息 m_Server.SendText ClientID, "服务器收到: " & Message ' 发送 JSON 数据 Dim sJSON As String sJSON = "{""type"":""notification"", ""message"":""Hello""}" m_Server.SendText ClientID, sJSON ' 发送系统消息 m_Server.SendText ClientID, "[系统] 服务器将于 5 分钟后维护" ``` *** ### SendBinary - 发送二进制消息 **语法**: ```vb Public Sub SendBinary(ByVal ClientID As String, Data() As Byte) ``` **参数**: | 参数 | 类型 | 说明 | |------|------|------| | `ClientID` | String | 目标客户端 ID | | `Data()` | Byte() | 要发送的二进制数据 | **示例**: ```vb ' 发送图片数据 Dim baImage() As Byte baImage = LoadImageAsByteArray() m_Server.SendBinary ClientID, baImage ' 发送文件数据 Dim baFile() As Byte baFile = LoadFile("document.pdf") m_Server.SendBinary ClientID, baFile ' 发送序列化对象 Dim baObj() As Byte baObj = SerializeObject(myObject) m_Server.SendBinary ClientID, baObj ``` *** ### BroadcastText - 广播文本消息 **语法**: ```vb Public Sub BroadcastText(ByVal Message As String, Optional ByVal ExcludeClientID As String = "") ``` **参数**: | 参数 | 类型 | 说明 | |------|------|------| | `Message` | String | 要广播的文本消息 | | `ExcludeClientID` | String（可选） | 排除的客户端 ID（不向该客户端发送） | **说明**: 向所有连接的客户端发送文本消息。帧只构建一次，然后发送给所有客户端，提高性能。 **示例**: ```vb ' 向所有客户端广播 m_Server.BroadcastText "欢迎来到聊天室！" ' 广播但不包括发送者 m_Server.BroadcastText Message, SenderClientID ' 系统公告 m_Server.BroadcastText "[系统] 服务器将在 5 分钟后重启" ' 聊天消息广播 Private Sub m_Server_OnClientTextMessage(ByVal ClientID As String, ByVal Message As String) ' 将消息广播给所有客户端，但不包括发送者 m_Server.BroadcastText ClientID & ": " & Message, ClientID End Sub ' 定时广播 Private Sub Timer1_Timer() Dim sTime As String sTime = Format$(Now, "yyyy-mm-dd hh:nn:ss") m_Server.BroadcastText "[时间] " & sTime End Sub ``` *** ### BroadcastBinary - 广播二进制消息 **语法**: ```vb Public Sub BroadcastBinary(Data() As Byte, Optional ByVal ExcludeClientID As String = "") ``` **参数**: | 参数 | 类型 | 说明 | |------|------|------| | `Data()` | Byte() | 要广播的二进制数据 | | `ExcludeClientID` | String（可选） | 排除的客户端 ID | **示例**: ```vb ' 广播图片更新 Dim baImage() As Byte baImage = GetUpdatedImage() m_Server.BroadcastBinary baImage ' 广播配置文件 Dim baConfig() As Byte baConfig = SerializeConfig() m_Server.BroadcastBinary baConfig ' 排除发送者 m_Server.BroadcastBinary baData, SenderClientID ``` *** ### DisconnectClient - 断开客户端连接 **语法**: ```vb Public Sub DisconnectClient(ByVal ClientID As String, _ Optional ByVal Code As WsCloseCode = WS_CLOSE_NORMAL, _ Optional ByVal Reason As String = "") ``` **参数**: | 参数 | 类型 | 说明 | |------|------|------| | `ClientID` | String | 要断开的客户端 ID | | `Code` | WsCloseCode（可选） | 关闭状态码，默认 `WS_CLOSE_NORMAL` | | `Reason` | String（可选） | 关闭原因 | **示例**: ```vb ' 正常断开 m_Server.DisconnectClient ClientID ' 指定关闭原因 m_Server.DisconnectClient ClientID, WS_CLOSE_GOING_AWAY, "管理员断开" ' 违规用户断开 If IsViolation(ClientID) Then m_Server.DisconnectClient ClientID, WS_CLOSE_POLICY_VIOLATION, "违反聊天规则" End If ' 服务器维护时断开所有客户端 Private Sub PrepareForMaintenance() Dim vIDs() As Variant Dim i As Long vIDs = m_Server.ClientIDs For i = LBound(vIDs) To UBound(vIDs) m_Server.DisconnectClient vIDs(i), WS_CLOSE_GOING_AWAY, "服务器维护中" Next i End Sub ``` *** ## 📡 事件详解 ### OnStart - 服务器启动 **语法**: ```vb Event OnStart(ByVal Port As Long) ``` **参数**: | 参数 | 类型 | 说明 | |------|------|------| | `Port` | Long | 监听的端口号 | **示例**: ```vb Private Sub m_Server_OnStart(ByVal Port As Long) Debug.Print "服务器已启动，监听端口: " & Port ' 更新 UI lblStatus.Caption = "运行中" lblPort.Caption = Port ' 记录日志 LogEvent "Server started on port " & Port ' 启动定时任务 Timer1.Enabled = True End Sub ``` *** ### OnStop - 服务器停止 **语法**: ```vb Event OnStop() ``` **示例**: ```vb Private Sub m_Server_OnStop() Debug.Print "服务器已停止" ' 更新 UI lblStatus.Caption = "已停止" ' 记录日志 LogEvent "Server stopped" ' 停止定时任务 Timer1.Enabled = False End Sub ``` *** ### OnClientConnect - 客户端连接 **语法**: ```vb Event OnClientConnect(ByVal ClientID As String, ByVal RemoteAddress As String, ByVal RemotePort As Long) ``` **参数**: | 参数 | 类型 | 说明 | |------|------|------| | `ClientID` | String | 客户端唯一标识（格式：`Client#N`） | | `RemoteAddress` | String | 客户端 IP 地址 | | `RemotePort` | Long | 客户端端口 | **示例**: ```vb Private Sub m_Server_OnClientConnect(ByVal ClientID As String, ByVal RemoteAddress As String, ByVal RemotePort As Long) Debug.Print "客户端连接: " & ClientID & " (" & RemoteAddress & ":" & RemotePort & ")" ' 添加到客户端列表 lstClients.AddItem ClientID & " - " & RemoteAddress ' 发送欢迎消息 m_Server.SendText ClientID, "欢迎连接到 WebSocket 服务器！" ' 发送当前在线人数 m_Server.SendText ClientID, "当前在线人数: " & m_Server.ClientCount ' 广播新用户上线 m_Server.BroadcastText "[系统] " & ClientID & " 已上线", ClientID ' 记录连接日志 LogConnection ClientID, RemoteAddress, RemotePort, "Connected" ' IP 黑白名单检查（实际应该在握手阶段） If IsBlacklisted(RemoteAddress) Then m_Server.DisconnectClient ClientID, WS_CLOSE_POLICY_VIOLATION, "IP 被拒绝" LogConnection ClientID, RemoteAddress, RemotePort, "Blocked (Blacklist)" End If End Sub ``` *** ### OnClientDisconnect - 客户端断开 **语法**: ```vb Event OnClientDisconnect(ByVal ClientID As String, ByVal Reason As String) ``` **参数**: | 参数 | 类型 | 说明 | |------|------|------| | `ClientID` | String | 客户端 ID | | `Reason` | String | 断开原因 | **示例**: ```vb Private Sub m_Server_OnClientDisconnect(ByVal ClientID As String, ByVal Reason As String) Debug.Print "客户端断开: " & ClientID & " - " & Reason ' 从列表中移除 Dim i As Long For i = 0 To lstClients.ListCount - 1 If InStr(lstClients.List(i), ClientID) > 0 Then lstClients.RemoveItem i Exit For End If Next ' 更新连接数 UpdateClientCount ' 广播用户下线 m_Server.BroadcastText "[系统] " & ClientID & " 已离线" ' 记录断开日志 LogDisconnect ClientID, Reason ' 如果是 VIP 用户，发送通知 If IsVIPClient(ClientID) Then NotifyAdmin "VIP user " & ClientID & " disconnected: " & Reason End If End Sub ``` *** ### OnClientTextMessage - 收到客户端文本消息 **语法**: ```vb Event OnClientTextMessage(ByVal ClientID As String, ByVal Message As String) ``` **参数**: | 参数 | 类型 | 说明 | |------|------|------| | `ClientID` | String | 发送消息的客户端 ID | | `Message` | String | 消息内容 | **示例**: ```vb Private Sub m_Server_OnClientTextMessage(ByVal ClientID As String, ByVal Message As String) Debug.Print "收到来自 " & ClientID & " 的消息: " & Message ' 记录消息日志 LogMessage ClientID, Message ' 处理命令 If Left$(Message, 1) = "/" Then ProcessCommand ClientID, Message Exit Sub End If ' 回显消息 m_Server.SendText ClientID, "服务器收到: " & Message ' 广播给其他客户端（聊天模式） If m_bChatMode Then m_Server.BroadcastText ClientID & ": " & Message, ClientID End If ' 特殊命令：broadcast If LCase$(Message) = "broadcast" Then m_Server.BroadcastText "这是一条广播消息，来自客户端 " & ClientID, ClientID End If End Sub Private Sub ProcessCommand(ByVal ClientID As String, ByVal Command As String) Dim sCmd As String Dim sArgs() As String Dim sArgsList As String ' 解析命令 sCmd = LCase$(Mid$(Command, 2)) sArgsList = Mid$(Command, 2) sArgs = Split(sArgsList, " ") Select Case sCmd Case "users" ' 列出所有用户 Dim sUserList As String sUserList = "在线用户: " Dim vIDs() As Variant vIDs = m_Server.ClientIDs Dim i As Long For i = LBound(vIDs) To UBound(vIDs) sUserList = sUserList & vIDs(i) & " " Next i m_Server.SendText ClientID, sUserList Case "time" ' 发送服务器时间 m_Server.SendText ClientID, "服务器时间: " & Now Case "ping" ' 回复 Pong m_Server.SendText ClientID, "pong" Case Else m_Server.SendText ClientID, "未知命令: " & sCmd End Select End Sub ``` *** ### OnClientBinaryMessage - 收到客户端二进制消息 **语法**: ```vb Event OnClientBinaryMessage(ByVal ClientID As String, Data() As Byte) ``` **参数**: | 参数 | 类型 | 说明 | |------|------|------| | `ClientID` | String | 发送消息的客户端 ID | | `Data()` | Byte() | 二进制数据 | **示例**: ```vb Private Sub m_Server_OnClientBinaryMessage(ByVal ClientID As String, Data() As Byte) On Error Resume Next Debug.Print "收到来自 " & ClientID & " 的二进制消息: " & (UBound(Data) + 1) & " 字节" ' 记录二进制消息日志 LogBinaryMessage ClientID, UBound(Data) + 1 ' 检查数据类型（假设前 4 字节是类型标识） If UBound(Data) >= 3 Then Dim lType As Long lType = CLng(Data(0)) * 256& ^ 3 + CLng(Data(1)) * 256& ^ 2 + _ CLng(Data(2)) * 256& + CLng(Data(3)) Select Case lType Case 1 ' 图片上传 SaveUploadedPicture ClientID, ExtractData(Data, 4) m_Server.SendText ClientID, "图片已保存" Case 2 ' 文件上传 SaveUploadedFile ClientID, ExtractData(Data, 4) m_Server.SendText ClientID, "文件已保存" Case 3 ' 自定义数据 ProcessCustomData ClientID, ExtractData(Data, 4) Case Else Debug.Print "未知数据类型: " & lType End Select End If End Sub ``` *** ### OnError - 发生错误 **语法**: ```vb Event OnError(ByVal Description As String) ``` **参数**: | 参数 | 类型 | 说明 | |------|------|------| | `Description` | String | 错误描述 | **示例**: ```vb Private Sub m_Server_OnError(ByVal Description As String) Debug.Print "服务器错误: " & Description ' 记录错误日志 LogError Description ' 显示错误提示 If m_bShowErrors Then MsgBox "服务器错误: " & Description, vbExclamation End If ' 严重错误时停止服务器 If InStr(Description, "严重") > 0 Then m_Server.StopServer End If End Sub ``` *** ## 📝 完整示例 ### 基本聊天服务器 ```vb Private WithEvents m_Server As cWebSocketServer Private m_bChatMode As Boolean Private Sub Form_Load() Set m_Server = New cWebSocketServer m_bChatMode = True End Sub Private Sub cmdStart_Click() m_Server.Listen CLng(txtPort.Text) End Sub Private Sub cmdStop_Click() m_Server.StopServer End Sub Private Sub m_Server_OnStart(ByVal Port As Long) Debug.Print "服务器已启动: " & Port lblStatus.Caption = "运行中" End Sub Private Sub m_Server_OnClientConnect(ByVal ClientID As String, ByVal RemoteAddress As String, ByVal RemotePort As Long) Debug.Print "客户端连接: " & ClientID lstClients.AddItem ClientID m_Server.SendText ClientID, "欢迎来到聊天室！" m_Server.BroadcastText ClientID & " 加入了聊天室", ClientID End Sub Private Sub m_Server_OnClientDisconnect(ByVal ClientID As String, ByVal Reason As String) Debug.Print "客户端断开: " & ClientID Dim i As Long For i = 0 To lstClients.ListCount - 1 If lstClients.List(i) = ClientID Then lstClients.RemoveItem i Exit For End If Next m_Server.BroadcastText ClientID & " 离开了聊天室" End Sub Private Sub m_Server_OnClientTextMessage(ByVal ClientID As String, ByVal Message As String) Debug.Print ClientID & ": " & Message txtLog.Text = txtLog.Text & ClientID & ": " & Message & vbCrLf ' 广播给所有其他客户端 m_Server.BroadcastText ClientID & ": " & Message, ClientID End Sub Private Sub m_Server_OnError(ByVal Description As String) Debug.Print "错误: " & Description End Sub Private Sub Form_Unload(Cancel As Integer) m_Server.StopServer End Sub ``` *** **最后更新**: 2026-01-10 --- --- url: /en/vbman/websocket/server.md --- # cWebSocketServer Class Reference ## 📋 Class Overview `cWebSocketServer` is a WebSocket server implementation class that provides functionality to listen on ports, manage multiple client connections, and broadcast messages. *** ## 📡 Event List | Event Name | Trigger Timing | Parameters | |------------|----------------|------------| | `OnStart` | Server started | `Port` (Listening port) | | `OnStop` | Server stopped | None | | `OnClientConnect` | New client connected | `ClientID`, `RemoteAddress`, `RemotePort` | | `OnClientDisconnect` | Client disconnected | `ClientID`, `Reason` | | `OnClientTextMessage` | Text message received from client | `ClientID`, `Message` | | `OnClientBinaryMessage` | Binary message received from client | `ClientID`, `Data()` | | `OnError` | Error occurred | `Description` | *** ## 🔧 Property Reference ### Port - Listening Port **Type**: `Long`\ **Read/Write**: Read-only **Description**: The currently listening port number. **Example**: ```vb Debug.Print "Server listening port: " & m_Server.Port ``` *** ### IsListening - Is Listening **Type**: `Boolean`\ **Read/Write**: Read-only **Description**: Whether the server is currently listening. **Example**: ```vb If m_Server.IsListening Then Debug.Print "Server is listening" End If ``` *** ### ClientCount - Client Connection Count **Type**: `Long`\ **Read/Write**: Read-only **Description**: Number of currently connected clients. **Example**: ```vb Debug.Print "Current connections: " & m_Server.ClientCount ' Update UI lblClientCount.Caption = "Connections: " & m_Server.ClientCount ``` *** ### ClientIDs - Client ID Array **Type**: `Variant` (String array)\ **Read/Write**: Read-only **Description**: Array of all connected client IDs. **Example**: ```vb ' Get all client IDs Dim vIDs() As Variant vIDs = m_Server.ClientIDs ' Iterate all client IDs Dim i As Long For i = LBound(vIDs) To UBound(vIDs) Debug.Print "Client: " & vIDs(i) Next i ``` *** ## 🚀 Method Reference ### Listen - Start Listening **Syntax**: ```vb Public Sub Listen(Optional ByVal Port As Long = 8080) ``` **Parameters**: | Parameter | Type | Description | |-----------|------|-------------| | `Port` | Long (Optional) | Listening port number, default 8080 | **Description**: * If server is already listening, it will stop first then start * Triggers `OnStart` event after starting * Automatically initializes client collection **Example**: ```vb ' Use default port 8080 m_Server.Listen ' Specify port m_Server.Listen 9000 ' Read port from config file m_Server.Listen CLng(GetConfig("ServerPort")) ``` **Error Handling**: ```vb Private Sub cmdStart_Click() On Error GoTo EH m_Server.Listen CLng(txtPort.Text) Debug.Print "Server started" Exit Sub EH: Debug.Print "Start failed: " & Err.Description MsgBox "Cannot start server: " & Err.Description, vbExclamation End Sub ``` *** ### StopServer - Stop Server **Syntax**: ```vb Public Sub StopServer() ``` **Description**: * Sends close frames to all clients * Closes all client connections * Clears client collection * Closes listening socket * Triggers `OnStop` event **Example**: ```vb ' Stop server m_Server.StopServer Debug.Print "Server stopped" ' Auto stop on form close Private Sub Form_Unload(Cancel As Integer) m_Server.StopServer End Sub ``` *** ### SendText - Send Text Message **Syntax**: ```vb Public Sub SendText(ByVal ClientID As String, ByVal Message As String) ``` **Parameters**: | Parameter | Type | Description | |-----------|------|-------------| | `ClientID` | String | Target client ID | | `Message` | String | Text message to send | **Description**: Sends text message to specified client. Message is automatically added WebSocket frame header, server sends without masking. **Example**: ```vb ' Send welcome message m_Server.SendText ClientID, "Welcome to WebSocket Server!" ' Echo message m_Server.SendText ClientID, "Server received: " & Message ' Send JSON data Dim sJSON As String sJSON = "{""type"":""notification"", ""message"":""Hello""}" m_Server.SendText ClientID, sJSON ' Send system message m_Server.SendText ClientID, "[System] Server will maintain in 5 minutes" ``` *** ### SendBinary - Send Binary Message **Syntax**: ```vb Public Sub SendBinary(ByVal ClientID As String, Data() As Byte) ``` **Parameters**: | Parameter | Type | Description | |-----------|------|-------------| | `ClientID` | String | Target client ID | | `Data()` | Byte() | Binary data to send | **Example**: ```vb ' Send image data Dim baImage() As Byte baImage = LoadImageAsByteArray() m_Server.SendBinary ClientID, baImage ' Send file data Dim baFile() As Byte baFile = LoadFile("document.pdf") m_Server.SendBinary ClientID, baFile ' Send serialized object Dim baObj() As Byte baObj = SerializeObject(myObject) m_Server.SendBinary ClientID, baObj ``` *** ### BroadcastText - Broadcast Text Message **Syntax**: ```vb Public Sub BroadcastText(ByVal Message As String, Optional ByVal ExcludeClientID As String = "") ``` **Parameters**: | Parameter | Type | Description | |-----------|------|-------------| | `Message` | String | Text message to broadcast | | `ExcludeClientID` | String (Optional) | Client ID to exclude (don't send to this client) | **Description**: Sends text message to all connected clients. Frame is built once then sent to all clients for better performance. **Example**: ```vb ' Broadcast to all clients m_Server.BroadcastText "Welcome to chat room!" ' Broadcast excluding sender m_Server.BroadcastText Message, SenderClientID ' System announcement m_Server.BroadcastText "[System] Server will restart in 5 minutes" ' Chat message broadcast Private Sub m_Server_OnClientTextMessage(ByVal ClientID As String, ByVal Message As String) ' Broadcast message to all other clients, excluding sender m_Server.BroadcastText ClientID & ": " & Message, ClientID End Sub ' Scheduled broadcast Private Sub Timer1_Timer() Dim sTime As String sTime = Format$(Now, "yyyy-mm-dd hh:nn:ss") m_Server.BroadcastText "[Time] " & sTime End Sub ``` *** ### BroadcastBinary - Broadcast Binary Message **Syntax**: ```vb Public Sub BroadcastBinary(Data() As Byte, Optional ByVal ExcludeClientID As String = "") ``` **Parameters**: | Parameter | Type | Description | |-----------|------|-------------| | `Data()` | Byte() | Binary data to broadcast | | `ExcludeClientID` | String (Optional) | Client ID to exclude | **Example**: ```vb ' Broadcast image update Dim baImage() As Byte baImage = GetUpdatedImage() m_Server.BroadcastBinary baImage ' Broadcast config file Dim baConfig() As Byte baConfig = SerializeConfig() m_Server.BroadcastBinary baConfig ' Exclude sender m_Server.BroadcastBinary baData, SenderClientID ``` *** ### DisconnectClient - Disconnect Client **Syntax**: ```vb Public Sub DisconnectClient(ByVal ClientID As String, _ Optional ByVal Code As WsCloseCode = WS_CLOSE_NORMAL, _ Optional ByVal Reason As String = "") ``` **Parameters**: | Parameter | Type | Description | |-----------|------|-------------| | `ClientID` | String | Client ID to disconnect | | `Code` | WsCloseCode (Optional) | Close status code, default `WS_CLOSE_NORMAL` | | `Reason` | String (Optional) | Close reason | **Example**: ```vb ' Normal disconnect m_Server.DisconnectClient ClientID ' Specify close reason m_Server.DisconnectClient ClientID, WS_CLOSE_GOING_AWAY, "Admin disconnect" ' Violating user disconnect If IsViolation(ClientID) Then m_Server.DisconnectClient ClientID, WS_CLOSE_POLICY_VIOLATION, "Violating chat rules" End If ' Disconnect all clients during maintenance Private Sub PrepareForMaintenance() Dim vIDs() As Variant Dim i As Long vIDs = m_Server.ClientIDs For i = LBound(vIDs) To UBound(vIDs) m_Server.DisconnectClient vIDs(i), WS_CLOSE_GOING_AWAY, "Server maintenance" Next i End Sub ``` *** ## 📡 Event Details ### OnStart - Server Started **Syntax**: ```vb Event OnStart(ByVal Port As Long) ``` **Parameters**: | Parameter | Type | Description | |-----------|------|-------------| | `Port` | Long | Listening port number | **Example**: ```vb Private Sub m_Server_OnStart(ByVal Port As Long) Debug.Print "Server started, listening on port: " & Port ' Update UI lblStatus.Caption = "Running" lblPort.Caption = Port ' Log event LogEvent "Server started on port " & Port ' Start scheduled tasks Timer1.Enabled = True End Sub ``` *** ### OnStop - Server Stopped **Syntax**: ```vb Event OnStop() ``` **Example**: ```vb Private Sub m_Server_OnStop() Debug.Print "Server stopped" ' Update UI lblStatus.Caption = "Stopped" ' Log event LogEvent "Server stopped" ' Stop scheduled tasks Timer1.Enabled = False End Sub ``` *** ### OnClientConnect - Client Connected **Syntax**: ```vb Event OnClientConnect(ByVal ClientID As String, ByVal RemoteAddress As String, ByVal RemotePort As Long) ``` **Parameters**: | Parameter | Type | Description | |-----------|------|-------------| | `ClientID` | String | Unique client identifier (format: `Client#N`) | | `RemoteAddress` | String | Client IP address | | `RemotePort` | Long | Client port | **Example**: ```vb Private Sub m_Server_OnClientConnect(ByVal ClientID As String, ByVal RemoteAddress As String, ByVal RemotePort As Long) Debug.Print "Client connected: " & ClientID & " (" & RemoteAddress & ":" & RemotePort & ")" ' Add to client list lstClients.AddItem ClientID & " - " & RemoteAddress ' Send welcome message m_Server.SendText ClientID, "Welcome to WebSocket Server!" ' Send current online count m_Server.SendText ClientID, "Current online users: " & m_Server.ClientCount ' Broadcast new user online m_Server.BroadcastText "[System] " & ClientID & " is now online", ClientID ' Log connection LogConnection ClientID, RemoteAddress, RemotePort, "Connected" ' IP whitelist/blacklist check (should be during handshake) If IsBlacklisted(RemoteAddress) Then m_Server.DisconnectClient ClientID, WS_CLOSE_POLICY_VIOLATION, "IP blocked" LogConnection ClientID, RemoteAddress, RemotePort, "Blocked (Blacklist)" End If End Sub ``` *** ### OnClientDisconnect - Client Disconnected **Syntax**: ```vb Event OnClientDisconnect(ByVal ClientID As String, ByVal Reason As String) ``` **Parameters**: | Parameter | Type | Description | |-----------|------|-------------| | `ClientID` | String | Client ID | | `Reason` | String | Disconnect reason | **Example**: ```vb Private Sub m_Server_OnClientDisconnect(ByVal ClientID As String, ByVal Reason As String) Debug.Print "Client disconnected: " & ClientID & " - " & Reason ' Remove from list Dim i As Long For i = 0 To lstClients.ListCount - 1 If InStr(lstClients.List(i), ClientID) > 0 Then lstClients.RemoveItem i Exit For End If Next ' Update connection count UpdateClientCount ' Broadcast user offline m_Server.BroadcastText "[System] " & ClientID & " is now offline" ' Log disconnect LogDisconnect ClientID, Reason ' If VIP user, send notification If IsVIPClient(ClientID) Then NotifyAdmin "VIP user " & ClientID & " disconnected: " & Reason End If End Sub ``` *** ### OnClientTextMessage - Text Message Received from Client **Syntax**: ```vb Event OnClientTextMessage(ByVal ClientID As String, ByVal Message As String) ``` **Parameters**: | Parameter | Type | Description | |-----------|------|-------------| | `ClientID` | String | Client ID sending the message | | `Message` | String | Message content | **Example**: ```vb Private Sub m_Server_OnClientTextMessage(ByVal ClientID As String, ByVal Message As String) Debug.Print "Received message from " & ClientID & ": " & Message ' Log message LogMessage ClientID, Message ' Handle command If Left$(Message, 1) = "/" Then ProcessCommand ClientID, Message Exit Sub End If ' Echo message m_Server.SendText ClientID, "Server received: " & Message ' Broadcast to other clients (chat mode) If m_bChatMode Then m_Server.BroadcastText ClientID & ": " & Message, ClientID End If ' Special command: broadcast If LCase$(Message) = "broadcast" Then m_Server.BroadcastText "This is a broadcast message from client " & ClientID, ClientID End If End Sub Private Sub ProcessCommand(ByVal ClientID As String, ByVal Command As String) Dim sCmd As String Dim sArgs() As String Dim sArgsList As String ' Parse command sCmd = LCase$(Mid$(Command, 2)) sArgsList = Mid$(Command, 2) sArgs = Split(sArgsList, " ") Select Case sCmd Case "users" ' List all users Dim sUserList As String sUserList = "Online users: " Dim vIDs() As Variant vIDs = m_Server.ClientIDs Dim i As Long For i = LBound(vIDs) To UBound(vIDs) sUserList = sUserList & vIDs(i) & " " Next i m_Server.SendText ClientID, sUserList Case "time" ' Send server time m_Server.SendText ClientID, "Server time: " & Now Case "ping" ' Reply Pong m_Server.SendText ClientID, "pong" Case Else m_Server.SendText ClientID, "Unknown command: " & sCmd End Select End Sub ``` *** ### OnClientBinaryMessage - Binary Message Received from Client **Syntax**: ```vb Event OnClientBinaryMessage(ByVal ClientID As String, Data() As Byte) ``` **Parameters**: | Parameter | Type | Description | |-----------|------|-------------| | `ClientID` | String | Client ID sending the message | | `Data()` | Byte() | Binary data | **Example**: ```vb Private Sub m_Server_OnClientBinaryMessage(ByVal ClientID As String, Data() As Byte) On Error Resume Next Debug.Print "Received binary message from " & ClientID & ": " & (UBound(Data) + 1) & " bytes" ' Log binary message LogBinaryMessage ClientID, UBound(Data) + 1 ' Check data type (assume first 4 bytes are type identifier) If UBound(Data) >= 3 Then Dim lType As Long lType = CLng(Data(0)) * 256& ^ 3 + CLng(Data(1)) * 256& ^ 2 + _ CLng(Data(2)) * 256& + CLng(Data(3)) Select Case lType Case 1 ' Image upload SaveUploadedPicture ClientID, ExtractData(Data, 4) m_Server.SendText ClientID, "Image saved" Case 2 ' File upload SaveUploadedFile ClientID, ExtractData(Data, 4) m_Server.SendText ClientID, "File saved" Case 3 ' Custom data ProcessCustomData ClientID, ExtractData(Data, 4) Case Else Debug.Print "Unknown data type: " & lType End Select End If End Sub ``` *** ### OnError - Error Occurred **Syntax**: ```vb Event OnError(ByVal Description As String) ``` **Parameters**: | Parameter | Type | Description | |-----------|------|-------------| | `Description` | String | Error description | **Example**: ```vb Private Sub m_Server_OnError(ByVal Description As String) Debug.Print "Server error: " & Description ' Log error LogError Description ' Show error alert If m_bShowErrors Then MsgBox "Server error: " & Description, vbExclamation End If ' Stop server on critical error If InStr(Description, "critical") > 0 Then m_Server.StopServer End If End Sub ``` *** ## 📝 Complete Example ### Basic Chat Server ```vb Private WithEvents m_Server As cWebSocketServer Private m_bChatMode As Boolean Private Sub Form_Load() Set m_Server = New cWebSocketServer m_bChatMode = True End Sub Private Sub cmdStart_Click() m_Server.Listen CLng(txtPort.Text) End Sub Private Sub cmdStop_Click() m_Server.StopServer End Sub Private Sub m_Server_OnStart(ByVal Port As Long) Debug.Print "Server started: " & Port lblStatus.Caption = "Running" End Sub Private Sub m_Server_OnClientConnect(ByVal ClientID As String, ByVal RemoteAddress As String, ByVal RemotePort As Long) Debug.Print "Client connected: " & ClientID lstClients.AddItem ClientID m_Server.SendText ClientID, "Welcome to chat room!" m_Server.BroadcastText ClientID & " joined chat room", ClientID End Sub Private Sub m_Server_OnClientDisconnect(ByVal ClientID As String, ByVal Reason As String) Debug.Print "Client disconnected: " & ClientID Dim i As Long For i = 0 To lstClients.ListCount - 1 If lstClients.List(i) = ClientID Then lstClients.RemoveItem i Exit For End If Next m_Server.BroadcastText ClientID & " left chat room" End Sub Private Sub m_Server_OnClientTextMessage(ByVal ClientID As String, ByVal Message As String) Debug.Print ClientID & ": " & Message txtLog.Text = txtLog.Text & ClientID & ": " & Message & vbCrLf ' Broadcast to all other clients m_Server.BroadcastText ClientID & ": " & Message, ClientID End Sub Private Sub m_Server_OnError(ByVal Description As String) Debug.Print "Error: " & Description End Sub Private Sub Form_Unload(Cancel As Integer) m_Server.StopServer End Sub ``` *** **Last Updated**: 2026-01-10 --- --- url: /zh/vbman2/webview2/methods.md --- # cWebView2Host 方法参考 ## 📋 方法总览 | 分类 | 方法 | 说明 | |------|------|------| | **生命周期** | Initialize | 初始化 WebView2 控件 | | **导航** | Navigate | 导航到指定 URL | | | NavigateCustom | 自定义请求导航（支持 POST/PUT） | | | NavigateToString | 加载 HTML 字符串 | | | GoBack | 后退 | | | GoForward | 前进 | | | Reload | 重新加载 | | **脚本** | ExecuteScript | 异步执行 JavaScript | | | JsRun | 同步调用 JS 函数 | | | JsRunAsync | 异步调用 JS 函数（返回 token） | | | JsProp | 同步读取 JS 属性 | | **消息** | PostWebMessage | 向 WebView 发送字符串消息 | | | PostWebMessageJSON | 向 WebView 发送 JSON 消息 | | **COM 对象** | AddObject | 注入 COM 宿主对象到 JS 全局 | | | RemoveObject | 移除已注入的 COM 宿主对象 | | **脚本注入** | AddScriptToExecuteOnDocumentCreated | 页面创建时自动执行脚本 | | **资源过滤** | AddWebResourceRequestedFilter | 添加 Web 资源请求过滤器 | | | RemoveWebResourceRequestedFilter | 移除 Web 资源请求过滤器 | | **开发工具** | OpenDevToolsWindow | 打开 DevTools 窗口 | | | CallDevToolsProtocolMethod | 异步调用 CDP 方法 | | | CallDevToolsProtocolMethodSync | 同步调用 CDP 方法 | | **虚拟主机** | SetVirtualHostNameToFolderMapping | 映射虚拟主机名到本地文件夹 | | | ClearVirtualHostNameToFolderMapping | 清除虚拟主机名映射 | | **PDF** | PrintToPdf | 将当前页面打印为 PDF | | **挂起/恢复** | Suspend | 挂起 WebView2 进程 | | | Resume | 恢复挂起的 WebView2 进程 | | **下载** | OpenDefaultDownloadDialog | 打开默认下载对话框 | | | CloseDefaultDownloadDialog | 关闭默认下载对话框 | | **窗口** | Resize | 调整 WebView2 控件大小 | | | SetFocus | 设置焦点到 WebView2 控件 | | | OpenTaskManagerWindow | 打开浏览器任务管理器 | | **数据绑定** | BindUI | 声明式 DOM 事件 -> 宿主方法绑定 | | | UnbindUI | 移除 DOM 事件绑定 | | | BindData | 声明式宿主数据 -> DOM 属性绑定 | | | UnbindData | 移除数据绑定 | | | SetData | 推送单个数据值到 DOM | | | SetDataBatch | 批量推送数据到 DOM | *** ## 🌐 生命周期方法 ### Initialize 初始化 WebView2 控件，创建环境、控制器并选择性地导航到指定 URL。 ```vb Public Function Initialize(HostOrHwnd As Variant, Optional HttpOrDir As String) As cWebView2Host ``` **参数**: * `HostOrHwnd` - 宿主窗口句柄（Long/LongPtr）或 VBA 对象（如 Form/Frame）。传入 Form 对象时自动获取 hWnd。 * `HttpOrDir` - 可选。URL 地址（如 `"https://vb6.pro"`）或本地文件夹路径（如 `App.Path & "\www"`）。传入文件夹路径时自动映射为 `http://vbman2.com/index.html`。省略则不自动导航。 **返回**: 返回 Me 自身，支持链式调用。 **说明**: * 自动检测宿主窗口类名，OForm 使用消息窗口适配器，其他使用子类化适配器 * 创建 Environment 时具有重试逻辑，最多 10 次尝试（自动递增 UserDataFolder 路径） * 传入 Form 对象时等效于传入 `Form.hWnd` **示例**: ```vb ' 最简两参数形式：窗口句柄 + URL wv.Initialize Me.hWnd, "https://vb6.pro" ' 传入 Form 对象 wv.Initialize Me, "https://vb6.pro" ' 加载本地文件夹 wv.Initialize Me.hWnd, App.Path & "\www" ' 延迟导航（不传第二个参数） wv.Initialize Me.hWnd ' 在 wv_Ready 事件中手动导航 ``` *** *** ## 🧭 导航方法 ### Navigate 导航到指定 URL。 ```vb Public Sub Navigate(ByVal Url As String) ``` **参数**: * `Url` - 目标 URL 地址 **示例**: ```vb wv.Navigate "https://example.com" ``` *** ### NavigateCustom 使用自定义 HTTP 方法和请求体导航。 ```vb Public Sub NavigateCustom(ByVal Url As String, ByVal Method As String, ByVal Body As String, Optional ByVal Headers As String) ``` **参数**: * `Url` - 目标 URL 地址 * `Method` - HTTP 方法（如 `"POST"`, `"PUT"`, `"DELETE"`） * `Body` - 请求体内容（UTF-8 编码） * `Headers` - 可选。自定义请求头，JSON 格式 **示例**: ```vb ' POST 请求 wv.NavigateCustom "https://api.example.com/data", "POST", "{""key"":""value""}", "{""Content-Type"":""application/json""}" ``` *** ### NavigateToString 将 HTML 字符串加载到 WebView2 中渲染。 ```vb Public Sub NavigateToString(ByVal HtmlContent As String) ``` **参数**: * `HtmlContent` - 完整的 HTML 字符串 **示例**: ```vb wv.NavigateToString "

    Hello WebView2

    " ' 从 VB6 资源文件加载 wv.NavigateToString VBMAN2.Res(LoadResData("INDEX.HTML", "WWW")).ReturnString() ``` *** ### GoBack / GoForward / Reload 浏览器导航控制。 ```vb Public Sub GoBack() Public Sub GoForward() Public Sub Reload() ``` **示例**: ```vb If wv.CanGoBack Then wv.GoBack If wv.CanGoForward Then wv.GoForward wv.Reload ``` *** ## ⚡ 脚本方法 ### ExecuteScript 异步执行 JavaScript 代码，结果通过 JsAsyncResult 事件返回。 ```vb Public Sub ExecuteScript(ByVal JavaScript As String, Optional ByVal Token As Long = 0) ``` **参数**: * `JavaScript` - 要执行的 JavaScript 代码 * `Token` - 可选。自定义令牌，用于在 JsAsyncResult 事件中标识调用 **说明**: 异步执行，不阻塞 VB6 线程。执行结果在 `JsAsyncResult` 事件中获取。 **示例**: ```vb wv.ExecuteScript "document.title", 1001 Private Sub wv_JsAsyncResult(ByVal Token As Long, ByVal Result As String, ByVal ErrorCode As Long) If Token = 1001 Then Debug.Print "页面标题: " & Result End If End Sub ``` *** ### JsRun 同步调用 JavaScript 函数并返回结果。阻塞当前线程直到 JS 执行完成。 ```vb Public Function JsRun(ByVal Expression As String, Optional ByVal TimeoutMs As Long = 5000) As String ``` **参数**: * `Expression` - JavaScript 表达式或函数调用 * `TimeoutMs` - 可选。超时时间（毫秒），默认 5000 **返回**: JS 执行结果的 JSON 字符串 **说明**: 内部使用 Sleep + DoEvents 实现同步等待，不影响 VB6 窗体消息循环。 **示例**: ```vb Dim title As String title = wv.JsRun("document.title") Dim result As String result = wv.JsRun("JSON.stringify({name:'test', value:42})") ``` *** ### JsRunAsync 异步调用 JavaScript 函数，返回令牌用于在事件中追踪结果。 ```vb Public Function JsRunAsync(ByVal Expression As String) As Long ``` **参数**: * `Expression` - JavaScript 表达式 **返回**: 令牌（Token），在 `JsAsyncResult` 事件中用于匹配对应调用 **示例**: ```vb Dim token As Long token = wv.JsRunAsync("fetch('https://api.example.com/data').then(r=>r.json())") Private Sub wv_JsAsyncResult(ByVal Token As Long, ByVal Result As String, ByVal ErrorCode As Long) Debug.Print "Async result token=" & Token & ": " & Result End Sub ``` *** ### JsProp 同步读取 JavaScript 属性值。 ```vb Public Function JsProp(ByVal Expression As String, Optional ByVal TimeoutMs As Long = 5000) As String ``` **参数**: * `Expression` - JavaScript 属性表达式 * `TimeoutMs` - 可选。超时时间（毫秒），默认 5000 **返回**: 属性值的 JSON 字符串 **示例**: ```vb Dim url As String url = wv.JsProp("location.href") Dim userAgent As String userAgent = wv.JsProp("navigator.userAgent") ``` *** ## 📨 消息方法 ### PostWebMessage 向 WebView2 页面发送字符串消息，页面通过 `window.chrome.webview.addEventListener('message', ...)` 接收。 ```vb Public Sub PostWebMessage(ByVal Message As String) ``` **参数**: * `Message` - 要发送的消息字符串 **示例**: ```vb wv.PostWebMessage "Hello from VB6" ``` *** ### PostWebMessageJSON 向 WebView2 页面发送 JSON 格式消息。 ```vb Public Sub PostWebMessageJSON(ByVal JsonMessage As String) ``` **参数**: * `JsonMessage` - JSON 格式的消息字符串 **示例**: ```vb wv.PostWebMessageJSON "{""type"":""update"",""data"":{""name"":""test""}}" ``` *** ## 🔗 COM 对象方法 ### AddObject 将 COM 对象注入到 WebView2 的 JavaScript 全局命名空间中。 ```vb Public Sub AddObject(ByVal Name As String, ByVal Object As Object) ``` **参数**: * `Name` - JavaScript 中的全局对象名称 * `Object` - COM 对象实例 **说明**: 注入后，JS 中可通过 `window.chrome.webview.hostObjects.` 访问该对象的方法和属性。JS 调用 COM 方法默认是异步的（返回 Promise），需使用 `hostObjects.sync.` 进行同步调用。 **示例**: ```vb Dim myObj As New MyComClass wv.AddObject "myApi", myObj ' JS 中调用： ' const result = await window.chrome.webview.hostObjects.myApi.DoSomething("param"); ' const result = window.chrome.webview.hostObjects.sync.myApi.DoSomething("param"); ``` *** ### RemoveObject 移除已注入的 COM 宿主对象。 ```vb Public Sub RemoveObject(ByVal Name As String) ``` **参数**: * `Name` - 之前注入的对象名称 *** ## 💉 脚本注入方法 ### AddScriptToExecuteOnDocumentCreated 在页面文档创建时自动执行的脚本，适用于所有后续导航的页面。 ```vb Public Sub AddScriptToExecuteOnDocumentCreated(ByVal JavaScript As String) ``` **参数**: * `JavaScript` - 要注入的 JavaScript 代码 **说明**: 脚本在 DOM 尚未完成加载时执行，适合注入全局变量、覆盖原生方法等。必须在 WebView2 创建后调用。 **示例**: ```vb ' 注入全局调试函数 wv.AddScriptToExecuteOnDocumentCreated "window.__vb6Debug = true;" ' 拦截 console.log wv.AddScriptToExecuteOnDocumentCreated _ "window.console.log = function(msg) { window.chrome.webview.postMessage('[LOG] ' + msg); };" ``` *** ## 🔍 资源过滤方法 ### AddWebResourceRequestedFilter 添加 Web 资源请求过滤器，匹配的请求会触发 `WebResourceRequested` 事件。 ```vb Public Sub AddWebResourceRequestedFilter(ByVal Uri As String, ByVal ResourceContext As wv2WebResourceContext) ``` **参数**: * `Uri` - URI 匹配模式（支持通配符） * `ResourceContext` - 资源上下文类型（如 `wv2WebResourceContext_Document`） **示例**: ```vb ' 拦截所有图片请求 wv.AddWebResourceRequestedFilter "*", wv2WebResourceContext_Image ' 拦截特定域名的脚本 wv.AddWebResourceRequestedFilter "https://ads.example.com/*", wv2WebResourceContext_Script ``` *** ### RemoveWebResourceRequestedFilter 移除之前添加的资源请求过滤器。 ```vb Public Sub RemoveWebResourceRequestedFilter(ByVal Uri As String, ByVal ResourceContext As wv2WebResourceContext) ``` *** ## 🔧 开发工具方法 ### OpenDevToolsWindow 打开 WebView2 的开发者工具窗口。 ```vb Public Sub OpenDevToolsWindow() ``` *** ### CallDevToolsProtocolMethod 异步调用 Chrome DevTools Protocol 方法。 ```vb Public Sub CallDevToolsProtocolMethod(ByVal MethodName As String, ByVal ParametersAsJson As String, ByVal CustomEventId As String) ``` **参数**: * `MethodName` - CDP 方法名（如 `"Runtime.evaluate"`, `"Network.getCookies"`） * `ParametersAsJson` - 方法参数的 JSON 字符串 * `CustomEventId` - 自定义事件 ID，在 `DevToolsProtocolResponse` 事件中用于匹配 **说明**: 结果通过 `DevToolsProtocolResponse` 事件异步返回。 **示例**: ```vb wv.CallDevToolsProtocolMethod "Runtime.evaluate", _ "{""expression"":""document.title""}", "getTitle" Private Sub wv_DevToolsProtocolResponse(ByVal CustomEventId As Variant, ByVal JsonResponse As String) If CustomEventId = "getTitle" Then Debug.Print "CDP Title: " & JsonResponse End If End Sub ``` *** ### CallDevToolsProtocolMethodSync 同步调用 Chrome DevTools Protocol 方法，阻塞等待结果。 ```vb Public Function CallDevToolsProtocolMethodSync(ByVal MethodName As String, ByVal ParametersAsJson As String) As String ``` **参数**: * `MethodName` - CDP 方法名 * `ParametersAsJson` - 方法参数的 JSON 字符串 **返回**: CDP 响应的 JSON 字符串 **说明**: 使用 Sleep + DoEvents 实现同步等待，不影响 VB6 窗体消息循环。 **示例**: ```vb Dim cookies As String cookies = wv.CallDevToolsProtocolMethodSync("Network.getCookies", "{}") Dim version As String version = wv.CallDevToolsProtocolMethodSync("Browser.getVersion", "{}") ``` *** ## 🗂️ 虚拟主机方法 ### SetVirtualHostNameToFolderMapping 将虚拟主机名映射到本地文件夹，使 WebView2 可以通过 https:// 访问本地文件。 ```vb Public Sub SetVirtualHostNameToFolderMapping(ByVal HostName As String, ByVal FolderPath As String, Optional ByVal AccessKind As wv2HostResourceAccessKind = wv2HostResourceAccessKind_Allow) ``` **参数**: * `HostName` - 虚拟主机名（如 `"myapp.local"`） * `FolderPath` - 本地文件夹的绝对路径 * `AccessKind` - 可选。访问权限，默认为 Allow **示例**: ```vb wv.SetVirtualHostNameToFolderMapping "myapp.local", App.Path & "\www" wv.Navigate "https://myapp.local/index.html" ``` *** ### ClearVirtualHostNameToFolderMapping 清除虚拟主机名映射。 ```vb Public Sub ClearVirtualHostNameToFolderMapping(ByVal HostName As String) ``` *** ## 📑 PDF 方法 ### PrintToPdf 将当前页面打印为 PDF 文件。 ```vb Public Sub PrintToPdf(ByVal ResultFilePath As String, _ Optional ByVal Orientation As wv2PrintOrientation = wv2PrintOrientation_Portrait, _ Optional ByVal ScaleFactor As Single = 1.0, _ Optional ByVal PageWidth As Single = 0, _ Optional ByVal PageHeight As Single = 0, _ Optional ByVal MarginTop As Single = 0, _ Optional ByVal MarginBottom As Single = 0, _ Optional ByVal MarginLeft As Single = 0, _ Optional ByVal MarginRight As Single = 0, _ Optional ByVal ShouldPrintHeader As Boolean = False, _ Optional ByVal ShouldPrintFooter As Boolean = False) ``` **参数**: * `ResultFilePath` - PDF 输出文件路径 * `Orientation` - 可选。打印方向，默认纵向 * `ScaleFactor` - 可选。缩放因子，默认 1.0 * 其余参数为页面尺寸和边距设置 **说明**: 完成后触发 `PrintToPdfCompleted` 事件，失败触发 `PrintToPdfFailed` 事件。 *** ## 🔌 挂起/恢复方法 ### Suspend 挂起 WebView2 渲染进程以节省资源。 ```vb Public Sub Suspend() ``` **说明**: 完成后触发 `SuspendCompleted` 或 `SuspendFailed` 事件。 *** ### Resume 恢复挂起的 WebView2 进程。 ```vb Public Sub Resume() ``` *** ## 📥 下载方法 ### OpenDefaultDownloadDialog / CloseDefaultDownloadDialog 打开/关闭默认下载对话框。 ```vb Public Sub OpenDefaultDownloadDialog() Public Sub CloseDefaultDownloadDialog() ``` *** ## 🪟 窗口方法 ### Resize 调整 WebView2 控件大小以适应宿主窗口。 ```vb Public Sub Resize() ``` **说明**: 宿主窗口大小变化时调用，内部会自动读取宿主窗口客户区尺寸。 *** ### SetFocus 将焦点设置到 WebView2 控件。 ```vb Public Sub SetFocus() ``` *** ### OpenTaskManagerWindow 打开浏览器内置任务管理器窗口。 ```vb Public Sub OpenTaskManagerWindow() ``` *** ## 🔗 数据绑定方法 ### BindUI 声明式绑定 DOM 事件到宿主 VB 方法。当指定元素触发事件时，自动调用宿主对象的指定方法。 ```vb Public Function BindUI(ByVal HostInst As Object, ByVal HostFunction As String, ByVal QuerySelector As String, Optional ByVal IsOverWrite As Boolean = False, Optional ByVal EventName As String = "click") As String ``` **参数**: * `HostInst` - 宿主对象实例（通常传 `Me`，即 Form 自身） * `HostFunction` - 宿主对象上的 Public 方法名 * `QuerySelector` - CSS 选择器，定位 DOM 元素 * `IsOverWrite` - 可选。是否覆盖同名绑定，默认 False * `EventName` - 可选。DOM 事件名，默认 `"click"` **返回**: BindId，用于标识此绑定 **说明**: 宿主方法签名必须为 `Public Sub MethodName(ByVal EventName As String, ByVal Detail As String)`，其中 Detail 是 JSON 格式的事件详情。 **示例**: ```vb Dim bindId As String bindId = wv.BindUI(Me, "OnButtonClick", "#submit-btn") ' 带自定义事件名 wv.BindUI Me, "OnNameInput", "#name-input", EventName:="input" ' 回调方法 Public Sub OnButtonClick(ByVal EventName As String, ByVal Detail As String) Debug.Print "Button clicked! Detail: " & Detail End Sub ``` *** ### UnbindUI 移除 DOM 事件绑定。 ```vb Public Sub UnbindUI(ByVal QuerySelector As String, Optional ByVal EventName As String = "") ``` **参数**: * `QuerySelector` - 之前绑定时的 CSS 选择器 * `EventName` - 可选。指定移除某个事件，空则移除该元素所有绑定 *** ### BindData 声明式绑定数据键到 DOM 属性。当 SetData 更新该键时，所有绑定的 DOM 属性自动更新。 ```vb Public Sub BindData(ByVal Key As String, ByVal QuerySelector As String, Optional ByVal Attr As String = "textContent") ``` **参数**: * `Key` - 数据键名（自定义标识符） * `QuerySelector` - CSS 选择器，定位 DOM 元素 * `Attr` - 可选。DOM 属性名，默认 `"textContent"`。支持 `value`, `textContent`, `innerHTML`, `src`, `class`, `checked`, `visible`（自定义）等 **说明**: 同一个 Key 可以绑定到多个元素和不同属性。 **示例**: ```vb ' 同一数据绑定到输入框值和预览文本 wv.BindData "name", "#name-input", "value" wv.BindData "name", "#name-preview", "textContent" ' 绑定到 checkbox 的 checked 属性 wv.BindData "enabled", "#toggle-enabled", "checked" ' 绑定到自定义 visible 属性（控制显示/隐藏） wv.BindData "enabled", "#settings-panel", "visible" ' 绑定到图片 src wv.BindData "avatar", "#avatar-img", "src" ' 绑定到 CSS class wv.BindData "statusOnline", "#status-dot", "class" ``` *** ### UnbindData 移除数据绑定。 ```vb Public Sub UnbindData(ByVal Key As String) ``` **参数**: * `Key` - 要移除的数据键名 *** ### SetData 推送单个数据值到所有绑定的 DOM 元素。 ```vb Public Sub SetData(ByVal Key As String, ByVal Value As Variant) ``` **参数**: * `Key` - 数据键名 * `Value` - 数据值，支持 String、Boolean、Number **示例**: ```vb wv.SetData "name", "张伟" wv.SetData "enabled", True wv.SetData "count", 42 wv.SetData "avatar", "https://example.com/img.png" ``` *** ### SetDataBatch 批量推送数据到 DOM，参数为 JSON 对象字符串。 ```vb Public Sub SetDataBatch(ByVal Json As String) ``` **参数**: * `Json` - JSON 对象字符串，键为数据键名，值为数据值 **示例**: ```vb wv.SetDataBatch "{""name"":""张伟"",""enabled"":true,""count"":42}" ``` *** **最后更新**: 2026-06-24 --- --- url: /zh/vbman2/webview2/overview.md --- # cWebView2Host 类开发文档 > 🚀 **cWebView2Host** - 基于 [twinBASIC WebView2Package](https://docs.twinbasic.com/WebView2) 的 VB6/twinBASIC 嵌入式浏览器控件封装，由 woeoio@qq.com 开发（详见[致谢](../CREDITS.md)） ## 📖 目录 * [概述](#概述) * [核心亮点](#核心亮点) * [快速开始](#快速开始) * [架构设计](#架构设计) * [文档索引](#文档索引) *** ## 概述 `cWebView2Host` 是一个 COM 可创建类，为 VB6/VBA/twinBASIC 应用提供 Microsoft Edge WebView2 嵌入式浏览器能力。它封装了 WebView2 Win32 C API 的全部复杂性，提供了简洁的 VB 风格 API、完整的事件模型和声明式数据绑定系统。 ### ✨ 主要特性 * 🌐 **零配置嵌入** - 两行代码即可在窗体中嵌入完整的 Chromium 浏览器 * 📡 **40+ 事件** - 覆盖导航、脚本、鼠标、键盘、下载、PDF 打印等全场景 * 🔗 **声明式数据绑定** - BindUI/BindData 双向绑定，VB6 与 DOM 零胶水代码联动 * ⚡ **同步 JS 调用** - JsRun/JsProp 同步执行 JavaScript，告别异步回调地狱 * 🔧 **CDP 全能力** - 同步/异步调用 Chrome DevTools Protocol，深度控制浏览器 * 🛡️ **安全控制** - 证书错误绕过、HTTPS 过滤、脚本开关一站式配置 * 🍪 **Cookie 管理** - 简易/完整双模式获取 Cookie，含 HttpOnly 支持 * 📦 **本地资源映射** - 文件夹/资源文件/虚拟主机三种本地页面加载方式 * 🖥️ **多宿主适配** - VB6/Excel 子类化 + Access 消息窗口双策略自动适配 * 📑 **会话隔离** - 多实例独立 UserDataFolder，支持多账号并行 *** ## 核心亮点 ### 1️⃣ 两行代码嵌入浏览器 🌐 无需任何配置文件或初始化步骤，最小使用只需两个调用： ```vb Dim wv As New cWebView2Host Private Sub Form_Load() wv.Initialize Me.hWnd, "https://vb6.pro" End Sub ``` 一行声明、一行初始化，窗体中即刻拥有完整的 Edge 浏览器内核。 *** ### 2️⃣ 声明式双向数据绑定 🔗 VB6 与 Web UI 之间零胶水代码双向绑定，用声明代替命令： ```vb ' 宿主 -> UI：将 key 绑定到 DOM 属性 wv.BindData "name", "#name-input", "value" wv.BindData "name", "#name-preview", "textContent" ' UI -> 宿主：将 DOM 事件绑定到 VB6 方法 wv.BindUI Me, "OnNameInput", "#name-input", EventName:="input" ' 推送数据到 UI wv.SetData "name", "张伟" ``` *** ### 3️⃣ 同步 JavaScript 执行 ⚡ 无需回调，直接在 VB6 中同步获取 JS 返回值： ```vb ' 同步调用 JS 函数并获取返回值 Dim title As String title = wv.JsRun("document.title") ' 同步读取 JS 属性 Dim url As String url = wv.JsProp("location.href") ' 同步执行 CDP 命令 Dim cookies As String cookies = wv.CallDevToolsProtocolMethodSync("Network.getCookies", "{}") ``` *** ### 4️⃣ 完整的事件驱动模型 📡 覆盖 WebView2 全生命周期事件，从创建到销毁，从导航到交互： ```vb Dim WithEvents wv As cWebView2Host ' 生命周期 Private Sub wv_Create(): ... Private Sub wv_Ready(): ... ' 导航控制 Private Sub wv_NavigationStarting(ByVal Uri As String, ByRef Cancel As Boolean): ... Private Sub wv_NavigationComplete(ByVal IsSuccess As Boolean): ... ' 宿主鼠标/键盘 Private Sub wv_HostMouseDown(ByVal Button As Long, ByVal Shift As Long, ByVal X As Long, ByVal Y As Long): ... ' JS 消息 Private Sub wv_JsMessage(ByVal Message As String): ... ``` *** ### 5️⃣ 多宿主自动适配 🖥️ 同一套 API 自动适配 VB6、Excel UserForm 和 Access OForm 三种宿主环境： ```vb ' 三种宿主使用完全相同的 API wv.Initialize Me.hWnd, "https://vb6.pro" ' VB6 / Excel UserForm wv.Initialize Me, "https://vb6.pro" ' 传入 Form 对象（自动检测） ' Access 窗体自动检测 OForm 类名，切换为 MessageWindowAdapter ``` 内部自动检测宿主窗口类名，VB6/Excel 使用子类化适配器，Access 使用消息窗口适配器。 *** ## 快速开始 ### 最小示例 ```vb Dim wv As New cWebView2Host Private Sub Form_Load() wv.Initialize Me.hWnd, "https://vb6.pro" End Sub ``` ### 带事件处理的示例 ```vb Dim WithEvents wv As cWebView2Host Private Sub Form_Load() Set wv = New cWebView2Host wv.Initialize Me.hWnd, "https://vb6.pro" End Sub Private Sub wv_Ready() Me.Caption = wv.DocumentTitle Debug.Print "浏览器已就绪" End Sub Private Sub wv_DocumentTitleChanged() Me.Caption = wv.DocumentTitle End Sub ``` ### 加载本地 HTML 文件 ```vb ' 方式1：文件夹路径自动映射 '（等同于方式2，vbman2内部使用了 vbman2.com 虚拟域名） wv.Initialize Me.hWnd, App.Path & "\www" ' 方式2：虚拟主机名映射 wv.Initialize Me.hWnd wv.SetVirtualHostNameToFolderMapping "myapp.local", App.Path & "\www" wv.Navigate "https://myapp.local/index.html" ' 方式3：从 VB6 资源文件加载 wv.Initialize Me.hWnd ' 在 wv_Ready 事件中： wv.NavigateToString VBMAN2.Res(LoadResData("INDEX.HTML", "WWW")).ReturnString() ``` *** ## 架构设计 ### 类层次结构 ``` cWebView2Host (公开 COM 类，用户直接交互) ├── m_Core: WebView2Core (核心引擎，实现 21 个 COM 回调接口) │ ├── ICoreWebView2 ~ ICoreWebView2_9 (版本化接口缓存) │ ├── ICoreWebView2Settings ~ Settings6 │ ├── ICoreWebView2Environment ~ _8 │ └── 所有事件委托 Token 管理 │ ├── m_Cookies: cWebView2Cookies (Cookie 管理业务对象) │ └── GetCookies / GetCookiesFull / GetCookiesFullAsync │ ├── m_Script: cWebView2Script (脚本执行业务对象) │ └── Eval (同步 JS 表达式求值) │ ├── m_Security: cWebView2Security (安全/证书管理业务对象) │ └── CertificateErrorAction / AdditionalBrowserArguments │ ├── m_MouseProxy: WebView2MouseProxy (JS->宿主鼠标事件 COM 代理) │ └── 暴露为 JS 全局对象 mouseProxy │ ├── m_BindUIProxy: WebView2BindUIProxy (声明式绑定 COM 代理) │ ├── 暴露为 JS 全局对象 bindUIProxy │ ├── BindUI 事件绑定管理 │ ├── BindData 数据绑定管理 │ └── 导航后自动重建绑定 │ └── Adapter: IHostAdapter (宿主适配抽象层) ├── HostSubclassAdapter (VB6/Excel，子类化宿主窗口) └── MessageWindowAdapter (Access，消息窗口 + 轮询) ``` ### 对象关系图 ``` 用户代码 │ ▼ cWebView2Host ──────── 事件转发 ──────── WebView2Core (WithEvents) │ │ ├── Cookies ──────────────────────────────┤ CDP / document.cookie ├── Script ───────────────────────────────┤ ExecuteScript / JsRun ├── Security ─────────────────────────────┤ AdditionalBrowserArguments │ │ ├── BindUIProxy ◄── AddObject ────────────┤ JS 全局对象 bindUIProxy └── MouseProxy ◄── AddObject ────────────┤ JS 全局对象 mouseProxy ──────────────────────────┘ │ IHostAdapter (适配层) ┌─────────┴─────────┐ HostSubclassAdapter MessageWindowAdapter (VB6/Excel 子类化) (Access 消息窗口) ``` ### 初始化流程 ``` 1. cWebView2Host.Initialize(HostOrHwnd, HttpOrDir) 2. 自动检测宿主窗口类名 ├── "OForm" → 创建 MessageWindowAdapter └── 其他 → 创建 HostSubclassAdapter 3. Adapter.Attach() → 子类化宿主窗口 / 创建消息窗口 4. 创建 WebView2 Environment（含重试逻辑，最多 10 次） 5. 创建 WebView2 Controller 6. CacheWebViewObjects() → QI 缓存 ICoreWebView2_1~9 7. CacheSettingsObjects() → QI 缓存 Settings_1~6 8. 注入 MouseProxy / BindUIProxy COM 对象 9. 触发 Create 事件 10. WebView2 控件初始化完成 → 触发 Ready 事件 11. 若指定了 URL → 自动导航 ``` ### 三阶段初始化模式 对于需要在导航前配置环境参数的场景，使用三阶段模式： ``` 阶段1: Initialize (无 URL) → 创建 WebView2 控件 阶段2: wv_Create 事件 → 配置 EnvironmentOptions / Security 阶段3: wv_Ready 事件 → 执行 Navigate / NavigateToString ``` ```vb Private Sub Form_Load() Set wv = New cWebView2Host wv.Initialize Me.hWnd ' 阶段1：不传 URL End Sub Private Sub wv_Create() wv.EnvironmentOptions.UserDataFolder = App.Path & "\UserDir\account-001" wv.Security.CertificateErrorAction = CEA_AlwaysAllow ' 阶段2：配置 End Sub Private Sub wv_Ready() wv.Navigate "https://example.com" ' 阶段3：导航 End Sub ``` *** ## 文档索引 | 文档 | 描述 | | ---------------------------- | ------------------------------------ | | [方法参考](./methods.md) | cWebView2Host 全部公开方法 API 参考 | | [属性参考](./properties.md) | cWebView2Host 全部公开属性 API 参考 | | [事件参考](./events.md) | cWebView2Host 全部事件详细说明 | | [数据绑定专题](./bindui.md) | BindUI/BindData/SetData 双向绑定系统 | | [CDP 专题](./cdp.md) | Chrome DevTools Protocol 调用指南 | | [宿主适配专题](./hosting.md) | VB6/Excel/Access 多宿主集成指南 | | [使用时机参考](./usage-timing.md) | 各方法/事件的最佳使用时机对照表 | | [常见问题](./faq.md) | 开发中常见问题与解决方案 | *** ## 依赖关系 | 组件 | 描述 | | ----------------------------------- | ------------------------------------------------ | | **Microsoft Edge WebView2 Runtime** | 运行时依赖，需在目标机器安装 | | **vbman2\_win32.dll** | VBMAN2 类型库，提供 COM 注册 | | **WebView2 Win32 C API** | 底层 COM 接口，由 Abstract/ 目录下的接口定义封装 | *** ## 兼容性 * **VB6** - 完全兼容，支持子类化适配器 * **VBA (Excel)** - 完全兼容，UserForm 中使用子类化适配器 * **VBA (Access)** - 完全兼容，自动使用消息窗口适配器 * **twinBASIC** - 完全兼容，原生开发语言 * **Windows** - Windows 10 及以上版本（WebView2 Runtime 要求） * **WebView2 Runtime** - 86.0.616.0 及以上版本 *** ## 许可证 基于 Microsoft WebView2 SDK 开发 *** ## 作者 **cWebView2Host**: woeoio@qq.com *** **最后更新**: 2026-06-24 --- --- url: /zh/vbman2/webview2/events.md --- # cWebView2Host 事件参考 ## 📋 事件总览 cWebView2Host 提供 40+ 个事件，覆盖 WebView2 全生命周期。使用事件需以 `WithEvents` 声明变量： ```vb Dim WithEvents wv As cWebView2Host ``` ### 事件分类索引 | 分类 | 事件 | 触发时机 | |------|------|----------| | **生命周期** | Create | WebView2 控件创建完成 | | | Ready | WebView2 控件初始化完成，控件就绪 | | | Error | 创建或运行时发生错误 | | **导航** | NavigationStarting | 导航开始（可取消） | | | NavigationComplete | 导航完成 | | | SourceChanged | URL 发生变化 | | | DocumentTitleChanged | 文档标题变化 | | | DOMContentLoaded | DOM 加载完成 | | **权限/对话框** | PermissionRequested | 页面请求权限 | | | ScriptDialogOpening | 脚本对话框弹出（alert/confirm/prompt） | | | AcceleratorKeyPressed | 快捷键按下 | | | NewWindowRequested | 页面请求打开新窗口 | | **资源** | WebResourceRequested | Web 资源请求被拦截 | | | ProcessFailed | 浏览器进程失败 | | | DownloadStarting | 下载即将开始 | | **脚本** | JsAsyncResult | 异步脚本执行完成 | | | JsMessage | 收到 JS postMessage | | | DevToolsProtocolResponse | CDP 异步响应 | | **宿主鼠标** | HostMouseDown | 宿主区域鼠标按下 | | | HostMouseUp | 宿主区域鼠标释放 | | | HostMouseDblClick | 宿主区域鼠标双击 | | | HostMouseMove | 宿主区域鼠标移动 | | | HostMouseWheel | 宿主区域鼠标滚轮 | | | HostContextMenu | 宿主区域右键菜单 | | **宿主键盘** | HostKeyDown | 宿主区域按键按下 | | | HostKeyUp | 宿主区域按键释放 | | | HostKeyPress | 宿主区域按键输入 | | | HostFocus | WebView2 获得焦点 | | | HostBlur | WebView2 失去焦点 | | | HostResize | 宿主窗口大小变化 | | **用户鼠标** | UserMouseDown | 内容区域鼠标按下 | | | UserMouseUp | 内容区域鼠标释放 | | | UserMouseMove | 内容区域鼠标移动 | | | UserMouseWheel | 内容区域鼠标滚轮 | | | UserContextMenu | 内容区域右键菜单 | | | UserDblClick | 内容区域鼠标双击 | | **挂起** | SuspendCompleted | 挂起成功 | | | SuspendFailed | 挂起失败 | | **PDF** | PrintToPdfCompleted | PDF 打印成功 | | | PrintToPdfFailed | PDF 打印失败 | | **业务** | OnGetCookiesFull | 异步 Cookie 获取完成 | *** ## 🔄 生命周期事件 ### Create WebView2 控件创建完成，但尚未开始导航。 ```vb Private Sub wv_Create() ``` **触发时机**: WebView2 Environment 和 Controller 创建成功后。 **用途**: 这是配置 EnvironmentOptions 和 Security 的正确时机，因为此时环境已创建但导航尚未开始。 **示例**: ```vb Private Sub wv_Create() ' 配置用户数据目录 wv.EnvironmentOptions.UserDataFolder = App.Path & "\UserDir\account-001" ' 配置安全选项 wv.Security.CertificateErrorAction = CEA_AlwaysAllow End Sub ``` *** ### Ready WebView2 控件初始化完成，控件完全就绪。 ```vb Private Sub wv_Ready() ``` **触发时机**: WebView2 控件初始化完成后触发一次。后续不再触发此事件。 **用途**: 安全地执行初始化操作，如绑定事件、注册数据绑定、注入脚本等。 **示例**: ```vb Private Sub wv_Ready() Me.Caption = wv.DocumentTitle ' 设置数据绑定 wv.BindData "name", "#name-input", "value" wv.BindUI Me, "OnNameInput", "#name-input", EventName:="input" wv.SetData "name", "默认值" ' 注入脚本 wv.AddScriptToExecuteOnDocumentCreated "window.__appReady = true;" End Sub ``` *** ### Error 创建或运行时发生错误。 ```vb Private Sub wv_Error(ByVal Description As String) ``` **参数**: * `Description` - 错误描述信息 *** ## 🧭 导航事件 ### NavigationStarting 导航即将开始，可通过 Cancel 参数取消导航。 ```vb Private Sub wv_NavigationStarting(ByVal Uri As String, ByVal IsUserInitiated As Boolean, ByRef Cancel As Boolean) ``` **参数**: * `Uri` - 目标 URL * `IsUserInitiated` - 是否由用户操作（点击链接等）触发 * `Cancel` - 设为 True 可取消导航 **示例**: ```vb Private Sub wv_NavigationStarting(ByVal Uri As String, ByVal IsUserInitiated As Boolean, ByRef Cancel As Boolean) ' 阻止导航到特定域名 If InStr(UCase(Uri), "ADS.EXAMPLE.COM") > 0 Then Cancel = True End If End Sub ``` *** ### NavigationComplete 导航完成。 ```vb Private Sub wv_NavigationComplete(ByVal IsSuccess As Boolean, ByVal ErrorStatus As wv2ErrorStatus) ``` **参数**: * `IsSuccess` - 导航是否成功 * `ErrorStatus` - 错误状态码（成功时为 0） *** ### SourceChanged URL 发生变化。 ```vb Private Sub wv_SourceChanged(ByVal IsNewDocument As Boolean) ``` **参数**: * `IsNewDocument` - 是否为新文档（而非同页内导航） *** ### DocumentTitleChanged 文档标题发生变化。 ```vb Private Sub wv_DocumentTitleChanged() ``` **示例**: ```vb Private Sub wv_DocumentTitleChanged() Me.Caption = wv.DocumentTitle End Sub ``` *** ### DOMContentLoaded DOM 内容加载完成（早于 NavigationComplete）。 ```vb Private Sub wv_DOMContentLoaded() ``` **用途**: 在 DOM 就绪但资源（图片等）尚未完全加载时执行操作。 *** ## 🔐 权限/对话框事件 ### PermissionRequested 页面请求权限（地理位置、相机、麦克风等）。 ```vb Private Sub wv_PermissionRequested(ByVal Uri As String, ByVal PermissionKind As wv2PermissionKind, ByVal IsUserInitiated As Boolean, ByRef State As wv2PermissionState) ``` **参数**: * `Uri` - 请求权限的页面 URL * `PermissionKind` - 权限类型枚举 * `IsUserInitiated` - 是否由用户操作触发 * `State` - 权限状态，可设为 `wv2PermissionState_Allow` 或 `wv2PermissionState_Deny` **示例**: ```vb Private Sub wv_PermissionRequested(ByVal Uri As String, ByVal PermissionKind As wv2PermissionKind, ByVal IsUserInitiated As Boolean, ByRef State As wv2PermissionState) ' 自动允许来自受信域名的地理位置权限 If PermissionKind = wv2PermissionKind_Geolocation And InStr(Uri, "myapp.com") > 0 Then State = wv2PermissionState_Allow Else State = wv2PermissionState_Deny End If End Sub ``` *** ### ScriptDialogOpening JavaScript 对话框即将弹出（alert / confirm / prompt / beforeunload）。 ```vb Private Sub wv_ScriptDialogOpening(ByVal Kind As wv2ScriptDialogKind, ByVal Message As String, ByRef Accept As Boolean) ``` **参数**: * `Kind` - 对话框类型 * `Message` - 对话框消息内容 * `Accept` - 设为 True 接受对话框（等效于点击确定），False 取消 **说明**: 可用于自定义对话框样式，替换浏览器默认的对话框。 *** ### AcceleratorKeyPressed 快捷键按下事件。 ```vb Private Sub wv_AcceleratorKeyPressed(ByVal KeyEventKind As wv2KeyEventKind, ByVal VirtualKey As Long, ByRef Handled As Boolean) ``` **参数**: * `KeyEventKind` - 按键事件类型（KeyDown/Up/SystemKeyDown/Up） * `VirtualKey` - 虚拟键码 * `Handled` - 设为 True 阻止 WebView2 处理此按键 **示例**: ```vb Private Sub wv_AcceleratorKeyPressed(ByVal KeyEventKind As wv2KeyEventKind, ByVal VirtualKey As Long, ByRef Handled As Boolean) ' 拦截 F5 刷新 If VirtualKey = vbKeyF5 Then Handled = True ' 自定义刷新逻辑 End If End Sub ``` *** ### NewWindowRequested 页面请求打开新窗口（target="\_blank" 或 window.open）。 ```vb Private Sub wv_NewWindowRequested(ByVal Uri As String, ByVal IsUserInitiated As Boolean, ByRef Handled As Boolean) ``` **参数**: * `Uri` - 新窗口的目标 URL * `IsUserInitiated` - 是否由用户操作触发 * `Handled` - 设为 True 阻止打开新窗口 **示例**: ```vb Private Sub wv_NewWindowRequested(ByVal Uri As String, ByVal IsUserInitiated As Boolean, ByRef Handled As Boolean) ' 在当前窗口中导航（阻止弹窗） Handled = True wv.Navigate Uri End Sub ``` *** ## 📦 资源事件 ### WebResourceRequested Web 资源请求被 AddWebResourceRequestedFilter 匹配拦截。 ```vb Private Sub wv_WebResourceRequested(ByVal Request As WebView2Request, ByVal Response As WebView2Response) ``` **参数**: * `Request` - 请求对象，可读取 Method、Uri、Headers、Content * `Response` - 响应对象，设值后 WebView2 使用此响应替代实际网络请求 **说明**: 必须先调用 `AddWebResourceRequestedFilter` 注册过滤器，此事件才会触发。 *** ### ProcessFailed 浏览器进程失败。 ```vb Private Sub wv_ProcessFailed(ByVal FailedKind As wv2ProcessFailedKind) ``` **参数**: * `FailedKind` - 进程失败类型枚举 *** ### DownloadStarting 下载即将开始。 ```vb Private Sub wv_DownloadStarting(ByVal ResultFilePath As String, ByRef Cancel As Boolean, ByRef Handled As Boolean) ``` **参数**: * `ResultFilePath` - 下载文件路径 * `Cancel` - 设为 True 取消下载 * `Handled` - 设为 True 表示已处理 *** ## ⚡ 脚本事件 ### JsAsyncResult 异步脚本执行完成（ExecuteScript / JsRunAsync 的回调）。 ```vb Private Sub wv_JsAsyncResult(ByVal Token As Long, ByVal Result As String, ByVal ErrorCode As Long) ``` **参数**: * `Token` - 调用时指定的令牌 * `Result` - JS 执行结果的 JSON 字符串 * `ErrorCode` - 错误码，0 表示成功 **示例**: ```vb wv.ExecuteScript "document.title", 1001 wv.JsRunAsync "fetch('/api').then(r=>r.json())" ' 返回自动 token Private Sub wv_JsAsyncResult(ByVal Token As Long, ByVal Result As String, ByVal ErrorCode As Long) If ErrorCode = 0 Then Debug.Print "Token " & Token & " => " & Result End If End Sub ``` *** ### JsMessage 收到 JS 通过 `window.chrome.webview.postMessage()` 发送的消息。 ```vb Private Sub wv_JsMessage(ByVal Message As String) ``` **参数**: * `Message` - JS 发送的消息字符串 **示例**: ```vb ' VB6 侧 Private Sub wv_JsMessage(ByVal Message As String) Debug.Print "JS消息: " & Message End Sub ' JS 侧 window.chrome.webview.postMessage("Hello from JS"); ``` *** ### DevToolsProtocolResponse CDP 异步调用响应。 ```vb Private Sub wv_DevToolsProtocolResponse(ByVal CustomEventId As Variant, ByVal JsonResponse As String) ``` **参数**: * `CustomEventId` - 调用时指定的自定义事件 ID * `JsonResponse` - CDP 响应的 JSON 字符串 **示例**: ```vb wv.CallDevToolsProtocolMethod "Page.captureScreenshot", "{}", "screenshot" Private Sub wv_DevToolsProtocolResponse(ByVal CustomEventId As Variant, ByVal JsonResponse As String) If CustomEventId = "screenshot" Then ' 处理截图数据 End If End Sub ``` *** ## 🖱️ 宿主鼠标事件 宿主鼠标事件由宿主窗口子类化捕获，反映宿主窗口区域（非 WebView2 内容区域）的鼠标操作。 ### HostMouseDown ```vb Private Sub wv_HostMouseDown(ByVal Button As wv2MouseButton, ByVal Shift As wv2ShiftState, ByVal X As Long, ByVal Y As Long) ``` **参数**: * `Button` - 鼠标按钮（1=左键, 2=右键, 4=中键，位掩码） * `Shift` - 修饰键状态（1=Shift, 2=Ctrl, 4=Alt，位掩码） * `X`, `Y` - 鼠标坐标（客户端区域像素） *** ### HostMouseUp ```vb Private Sub wv_HostMouseUp(ByVal Button As wv2MouseButton, ByVal Shift As wv2ShiftState, ByVal X As Long, ByVal Y As Long) ``` *** ### HostMouseDblClick ```vb Private Sub wv_HostMouseDblClick(ByVal Button As wv2MouseButton, ByVal Shift As wv2ShiftState, ByVal X As Long, ByVal Y As Long) ``` *** ### HostMouseMove ```vb Private Sub wv_HostMouseMove(ByVal Button As wv2MouseButton, ByVal Shift As wv2ShiftState, ByVal X As Long, ByVal Y As Long) ``` **说明**: 需启用 `EnableMouseMoveEvents = True` 才会触发，默认关闭避免性能问题。 *** ### HostMouseWheel ```vb Private Sub wv_HostMouseWheel(ByVal Delta As Long, ByVal Shift As wv2ShiftState, ByVal X As Long, ByVal Y As Long) ``` **参数**: * `Delta` - 滚轮增量，正值向上滚动，负值向下 *** ### HostContextMenu ```vb Private Sub wv_HostContextMenu(ByVal X As Long, ByVal Y As Long) ``` *** ## ⌨️ 宿主键盘事件 ### HostKeyDown / HostKeyUp / HostKeyPress ```vb Private Sub wv_HostKeyDown(ByVal KeyCode As Long, ByVal Shift As wv2ShiftState) Private Sub wv_HostKeyUp(ByVal KeyCode As Long, ByVal Shift As wv2ShiftState) Private Sub wv_HostKeyPress(ByVal KeyAscii As Long) ``` *** ### HostFocus / HostBlur ```vb Private Sub wv_HostFocus() Private Sub wv_HostBlur() ``` *** ### HostResize ```vb Private Sub wv_HostResize() ``` **说明**: 宿主窗口大小变化时触发，可在此处调用 `wv.Resize()` 手动调整 WebView2 大小（如使用 MessageWindowAdapter 时）。 *** ## 🎯 用户鼠标事件 用户鼠标事件通过 `mouseProxy` COM 代理从 WebView2 内容区域同步回调到宿主。需启用 `EnableUserMouseEvents = True`。 ### UserMouseDown / UserMouseUp ```vb Private Sub wv_UserMouseDown(ByVal Button As Long, ByVal X As Long, ByVal Y As Long, ByVal Shift As Long, ByRef Handled As Boolean) Private Sub wv_UserMouseUp(ByVal Button As Long, ByVal X As Long, ByVal Y As Long, ByVal Shift As Long, ByRef Handled As Boolean) ``` **参数**: * `Button` - 鼠标按钮（1=左键, 2=右键, 4=中键） * `X`, `Y` - 内容区域内的像素坐标 * `Shift` - 修饰键状态 * `Handled` - 设为 True 阻止事件继续传播到 WebView2 *** ### UserMouseMove ```vb Private Sub wv_UserMouseMove(ByVal X As Long, ByVal Y As Long, ByVal Shift As Long, ByRef Handled As Boolean) ``` **说明**: 需额外启用 `EnableUserMouseMove = True`，默认关闭以避免性能问题。 *** ### UserMouseWheel ```vb Private Sub wv_UserMouseWheel(ByVal Delta As Long, ByVal X As Long, ByVal Y As Long, ByVal Shift As Long, ByRef Handled As Boolean) ``` *** ### UserContextMenu ```vb Private Sub wv_UserContextMenu(ByVal X As Long, ByVal Y As Long, ByRef Handled As Boolean) ``` *** ### UserDblClick ```vb Private Sub wv_UserDblClick(ByVal Button As Long, ByVal X As Long, ByVal Y As Long, ByVal Shift As Long, ByRef Handled As Boolean) ``` *** ## 🔌 挂起/PDF/业务事件 ### SuspendCompleted / SuspendFailed ```vb Private Sub wv_SuspendCompleted() Private Sub wv_SuspendFailed(ByVal ErrorCode As Long) ``` *** ### PrintToPdfCompleted / PrintToPdfFailed ```vb Private Sub wv_PrintToPdfCompleted(ByVal ResultFilePath As String) Private Sub wv_PrintToPdfFailed(ByVal ErrorCode As Long) ``` *** ### OnGetCookiesFull 异步获取完整 Cookie 完成。 ```vb Private Sub wv_OnGetCookiesFull(ByVal CookiesJson As String) ``` **触发时机**: 调用 `wv.Cookies.GetCookiesFullAsync()` 后异步返回时。 *** ## 📐 枚举参考 ### wv2MouseButton | 常量 | 值 | 说明 | |------|-----|------| | 左键 | 1 | 鼠标左键 | | 右键 | 2 | 鼠标右键 | | 中键 | 4 | 鼠标中键 | 位掩码组合，可同时包含多个值。 ### wv2ShiftState | 常量 | 值 | 说明 | |------|-----|------| | Shift | 1 | Shift 键 | | Ctrl | 2 | Ctrl 键 | | Alt | 4 | Alt 键 | 位掩码组合，检测方式：`If Shift And 2 Then ' Ctrl 按下` ### wv2ScriptDialogKind | 常量 | 说明 | |------|------| | Alert | alert() 对话框 | | Confirm | confirm() 对话框 | | Prompt | prompt() 对话框 | | BeforeUnload | beforeunload 对话框 | ### wv2PermissionKind | 常量 | 说明 | |------|------| | Unknown | 未知权限 | | Microphone | 麦克风 | | Camera | 摄像头 | | Geolocation | 地理位置 | | Notifications | 通知 | | OtherSensors | 其他传感器 | | ClipboardRead | 剪贴板读取 | ### wv2PermissionState | 常量 | 说明 | |------|------| | Default | 默认（由浏览器决定） | | Allow | 允许 | | Deny | 拒绝 | ### EnumCertificateErrorAction | 常量 | 值 | 说明 | |------|-----|------| | CEA\_Default | 0 | 默认行为（拒绝） | | CEA\_Cancel | 1 | 取消请求 | | CEA\_AlwaysAllow | 2 | 始终允许（注入命令行参数） | *** **最后更新**: 2026-06-24 --- --- url: /zh/vbman2/webview2/properties.md --- # cWebView2Host 属性参考 ## 📋 属性总览 | 分类 | 属性 | 类型 | 读写 | 说明 | |------|------|------|------|------| | **状态** | IsReady | Boolean | 只读 | WebView2 是否已就绪 | | | hWnd | LongPtr | 只读 | WebView2 子窗口句柄 | | | BrowserProcessId | Long | 只读 | 浏览器进程 ID | | | CanGoBack | Boolean | 只读 | 是否可以后退 | | | CanGoForward | Boolean | 只读 | 是否可以前进 | | | IsSuspended | Boolean | 只读 | 进程是否已挂起 | | | IsMuted | Boolean | 只读 | 页面是否静音 | | | IsDocumentPlayingAudio | Boolean | 只读 | 页面是否正在播放音频 | | | IsDefaultDownloadDialogOpen | Boolean | 只读 | 下载对话框是否打开 | | **文档** | DocumentURL | String | 只读 | 当前文档 URL | | | DocumentTitle | String | 只读 | 当前文档标题 | | | ZoomFactor | Double | 读写 | 缩放因子 | | **设置** | IsScriptEnabled | Boolean | 读写 | 是否启用 JavaScript | | | AreDevToolsEnabled | Boolean | 读写 | 是否启用 DevTools | | | IsStatusBarEnabled | Boolean | 读写 | 是否显示状态栏 | | | IsZoomControlEnabled | Boolean | 读写 | 是否允许用户缩放 | | | AreDefaultContextMenusEnabled | Boolean | 读写 | 是否启用右键菜单 | | | UserAgent | String | 读写 | 自定义 User-Agent | | | IsPinchZoomEnabled | Boolean | 读写 | 是否启用捏合缩放 | | | IsSwipeNavigationEnabled | Boolean | 读写 | 是否启用滑动导航 | | | IsPasswordAutoSaveEnabled | Boolean | 读写 | 是否启用密码自动保存 | | | IsGeneralAutoFillEnabled | Boolean | 读写 | 是否启用自动填充 | | | AreBrowserAcceleratorKeysEnabled | Boolean | 读写 | 是否启用浏览器快捷键 | | **功能检测** | Supports\* (8个) | Boolean | 只读 | 各版本接口支持情况 | | **子对象** | Cookies | cWebView2Cookies | 只读 | Cookie 管理对象 | | | Script | cWebView2Script | 只读 | 脚本执行对象 | | | Security | cWebView2Security | 只读 | 安全管理对象 | | | EnvironmentOptions | cWebView2EnvironmentOptions | 只读 | 环境选项对象 | | **适配器** | HostAdapterName | String | 只读 | 当前宿主适配器名称 | | **鼠标事件** | EnableUserMouseEvents | Boolean | 读写 | 是否启用内容区鼠标事件 | | | EnableUserMouseMove | Boolean | 读写 | 是否启用 mousemove 事件 | | | EnableMouseMoveEvents | Boolean | 读写 | 是否启用宿主 mousemove 事件 | *** ## 📊 状态属性 ### IsReady WebView2 控件是否已完全就绪，可以接受 API 调用。 **类型**: `Boolean`\ **读写**: 只读 **示例**: ```vb If wv.IsReady Then wv.Navigate "https://example.com" End If ``` *** ### hWnd WebView2 子窗口（Chrome\_WidgetWin\_0）的句柄。 **类型**: `LongPtr`\ **读写**: 只读 *** ### BrowserProcessId 浏览器渲染进程的 ID。 **类型**: `Long`\ **读写**: 只读 *** ### CanGoBack / CanGoForward 是否可以后退/前进。 **类型**: `Boolean`\ **读写**: 只读 **示例**: ```vb If wv.CanGoBack Then wv.GoBack ``` *** ### IsSuspended WebView2 渲染进程是否已挂起。 **类型**: `Boolean`\ **读写**: 只读 *** ### IsMuted 页面音频是否已静音。 **类型**: `Boolean`\ **读写**: 只读 *** ### IsDocumentPlayingAudio 当前页面是否正在播放音频。 **类型**: `Boolean`\ **读写**: 只读 *** ### IsDefaultDownloadDialogOpen 默认下载对话框是否已打开。 **类型**: `Boolean`\ **读写**: 只读 *** ## 📝 文档属性 ### DocumentURL 当前文档的 URL。 **类型**: `String`\ **读写**: 只读 **示例**: ```vb Debug.Print "当前URL: " & wv.DocumentURL ``` *** ### DocumentTitle 当前文档的标题。 **类型**: `String`\ **读写**: 只读 **说明**: 通常在 `DocumentTitleChanged` 事件中读取以更新窗体标题。 **示例**: ```vb Private Sub wv_DocumentTitleChanged() Me.Caption = wv.DocumentTitle End Sub ``` *** ### ZoomFactor 页面缩放因子。 **类型**: `Double`\ **读写**: 可读写 **说明**: 默认值为 1.0。设置为 0.5 表示 50%，2.0 表示 200%。 **示例**: ```vb wv.ZoomFactor = 1.5 ' 150% 缩放 Debug.Print "当前缩放: " & wv.ZoomFactor ``` *** ## ⚙️ 设置属性 ### IsScriptEnabled 是否启用 JavaScript 执行。 **类型**: `Boolean`\ **读写**: 可读写\ **默认**: `True` **说明**: 禁用后页面中的所有 JavaScript 不会执行。 *** ### AreDevToolsEnabled 是否允许用户打开 DevTools（F12）。 **类型**: `Boolean`\ **读写**: 可读写\ **默认**: `True` **说明**: 生产环境建议设为 False 以防止用户调试页面。 *** ### IsStatusBarEnabled 是否显示浏览器状态栏。 **类型**: `Boolean`\ **读写**: 可读写\ **默认**: `False` *** ### IsZoomControlEnabled 是否允许用户通过 Ctrl+滚轮 等方式缩放页面。 **类型**: `Boolean`\ **读写**: 可读写\ **默认**: `True` *** ### AreDefaultContextMenusEnabled 是否启用 WebView2 的默认右键上下文菜单。 **类型**: `Boolean`\ **读写**: 可读写\ **默认**: `True` **说明**: 如果自行处理右键菜单，可设为 False。 *** ### UserAgent 自定义 User-Agent 字符串。 **类型**: `String`\ **读写**: 可读写 **说明**: 设置后所有后续请求将使用此 User-Agent。设为空字符串恢复默认。 **示例**: ```vb wv.UserAgent = "Mozilla/5.0 (Custom App)" ``` *** ### IsPinchZoomEnabled 是否启用触摸屏捏合缩放。 **类型**: `Boolean`\ **读写**: 可读写\ **默认**: `True` *** ### IsSwipeNavigationEnabled 是否启用触摸屏滑动导航（前进/后退）。 **类型**: `Boolean`\ **读写**: 可读写\ **默认**: `True` *** ### IsPasswordAutoSaveEnabled 是否启用密码自动保存提示。 **类型**: `Boolean`\ **读写**: 可读写\ **默认**: `False` *** ### IsGeneralAutoFillEnabled 是否启用表单自动填充。 **类型**: `Boolean`\ **读写**: 可读写\ **默认**: `False` *** ### AreBrowserAcceleratorKeysEnabled 是否启用浏览器快捷键（如 Ctrl+F 搜索、Ctrl+P 打印等）。 **类型**: `Boolean`\ **读写**: 可读写\ **默认**: `True` **说明**: 如果不希望用户通过快捷键触发浏览器内置功能，设为 False。 *** ## 🔍 功能检测属性 8 个 `Supports*` 只读属性用于检测当前 WebView2 Runtime 是否支持特定版本的接口： | 属性 | 对应接口 | 说明 | |------|----------|------| | `SupportsWebView2` | ICoreWebView2 | 基础接口（始终为 True） | | `SupportsWebView3` | ICoreWebView2\_3 | DOMContentLoaded 等 | | `SupportsWebView4` | ICoreWebView2\_4 | Suspend/Resume | | `SupportsWebView5` | ICoreWebView2\_5 | 文件夹映射 | | `SupportsWebView6` | ICoreWebView2\_6 | DownloadStarting | | `SupportsWebView7` | ICoreWebView2\_7 | PrintToPdf | | `SupportsWebView8` | ICoreWebView2\_8 | Audio | | `SupportsWebView9` | ICoreWebView2\_9 | DownloadDialog | **类型**: `Boolean`\ **读写**: 只读 **示例**: ```vb If wv.SupportsWebView5 Then wv.SetVirtualHostNameToFolderMapping "myapp.local", App.Path & "\www" End If ``` *** ## 🔗 子对象属性 ### Cookies Cookie 管理业务对象。 **类型**: `cWebView2Cookies`\ **读写**: 只读 **说明**: 提供 `GetCookies` 和 `GetCookiesFull` 方法。 **示例**: ```vb Dim simple As String simple = wv.Cookies.GetCookies ' 简易 Cookie 列表 Dim full As String full = wv.Cookies.GetCookiesFull ' 完整 Cookie 详情（含 HttpOnly） ``` *** ### Script 脚本执行业务对象。 **类型**: `cWebView2Script`\ **读写**: 只读 **说明**: 提供 `Eval` 方法，用于同步执行 JavaScript 表达式。 **示例**: ```vb Dim html As String html = wv.Script.Eval("return document.querySelector('.title').innerHTML") ``` *** ### Security 安全/证书管理业务对象。 **类型**: `cWebView2Security`\ **读写**: 只读 **说明**: 提供 `CertificateErrorAction` 属性，控制证书错误处理行为。**必须在 Initialize 之前设置才生效**。 **示例**: ```vb ' 必须在 wv_Create 事件中配置 Private Sub wv_Create() wv.Security.CertificateErrorAction = CEA_AlwaysAllow End Sub ``` *** ### EnvironmentOptions WebView2 环境选项对象。 **类型**: `cWebView2EnvironmentOptions`\ **读写**: 只读 **属性**: | 子属性 | 类型 | 说明 | |--------|------|------| | `BrowserExecutableFolder` | String | 浏览器可执行文件目录 | | `UserDataFolder` | String | 用户数据文件夹路径 | | `AdditionalBrowserArguments` | String | 附加浏览器命令行参数 | | `Language` | String | 浏览器语言 | | `TargetCompatibleBrowserVersion` | String | 目标兼容浏览器版本 | | `AllowSingleSignOnUsingOSPrimaryAccount` | Boolean | 是否允许 OS 主账号 SSO | | `ExclusiveUserDataFolderAccess` | Boolean | 是否独占用户数据文件夹 | | `EnableTrackingPrevention` | Boolean | 是否启用跟踪防护 | **说明**: `UserDataFolder` 和 `AdditionalBrowserArguments` 等必须在 `wv_Create` 事件中设置。 **示例**: ```vb Private Sub wv_Create() wv.EnvironmentOptions.UserDataFolder = App.Path & "\UserDir\account-001" End Sub ``` *** ## 🖥️ 适配器属性 ### HostAdapterName 当前使用的宿主适配器名称。 **类型**: `String`\ **读写**: 只读 **值**: * `"HostSubclassAdapter"` - 子类化适配器（VB6/Excel） * `"MessageWindowAdapter"` - 消息窗口适配器（Access） **示例**: ```vb Debug.Print "适配器: " & wv.HostAdapterName ``` *** ## 🖱️ 鼠标事件属性 ### EnableUserMouseEvents 是否启用内容区域的用户鼠标事件（通过 JS 代理触发的 UserMouse\* 事件）。 **类型**: `Boolean`\ **读写**: 可读写\ **默认**: `False` **说明**: 启用后，WebView2 内容区域的鼠标事件会通过 `mouseProxy` COM 对象同步回调到宿主，触发 `UserMouseDown`、`UserMouseUp`、`UserMouseMove`、`UserMouseWheel`、`UserContextMenu`、`UserDblClick` 事件。 *** ### EnableUserMouseMove 是否启用内容区域的 mousemove 事件（仅当 EnableUserMouseEvents 为 True 时生效）。 **类型**: `Boolean`\ **读写**: 可读写\ **默认**: `False` **说明**: mousemove 事件频率极高，默认关闭以避免性能问题。仅在有拖拽等需求时启用。 *** ### EnableMouseMoveEvents 是否启用宿主窗口的 mousemove 事件（HostMouseMove）。 **类型**: `Boolean`\ **读写**: 可读写\ **默认**: `False` **说明**: 宿主鼠标移动事件频率极高，默认关闭以避免性能问题。 *** **最后更新**: 2026-06-24 --- --- url: /zh/vbman2/webview2/usage-timing.md --- # cWebView2Host 属性与方法使用时机参考 > 不同 API 在 WebView2 生命周期中的可用时机不同。本文将所有属性和方法按**最早可用时机**分类，帮助开发者避免在错误阶段调用导致失效或报错。 ## 🔄 生命周期阶段说明 WebView2 的完整生命周期包含 **初始化阶段** 和 **运行阶段**，所有事件如下： ### 初始化阶段（一次性，按顺序触发） ``` 用户调用 Initialize() ↓ ① Create 事件 ─── 配置 EnvironmentOptions / Security（仅此事件可设置） ↓ ② 内部创建 Environment（读取 EnvironmentOptions 配置） ↓ ③ 内部创建 Controller + CoreWebView（读取 Settings 配置） ↓ ④ Ready 事件 ─── 控件完全就绪，所有 API 开始可用 ↓ ⑤ 首次 Navigate（如果指定了 InitialURL） ``` ### 运行阶段（每次导航循环触发） ``` Navigate / NavigateCustom / NavigateToString / GoBack / GoForward / Reload ↓ ⑥ NavigationStarting ─── 可 Cancel 阻止导航 ↓ ⑦ SourceChanged ─── URL 变化（IsNewDocument 标识是否新页面） ↓ ┌─ ContentLoading（内部事件，未暴露） │ ⑧ DOMContentLoaded ─── DOM 就绪，可 BindUI / BindData / 执行 JS ↓ │ ⑨ DocumentTitleChanged ─── 标题变化 │ ⑩ NavigationComplete ─── 页面完全加载（含图片等资源） └────────────────────────────────────────┘ 每次导航都会重新触发 ⑥→⑩ ``` ### 运行阶段（随时可能触发的交互事件） ``` ┌─ 权限/对话框 ─────────────────────────────────┐ │ PermissionRequested 页面请求权限（地理/相机等）│ │ ScriptDialogOpening JS 弹框（alert/confirm） │ │ NewWindowRequested 页面请求开新窗口 │ │ AcceleratorKeyPressed 快捷键按下 │ └────────────────────────────────────────────────┘ ┌─ 资源/下载 ─────────────────────────────────────┐ │ WebResourceRequested 资源请求被拦截（需先注册） │ │ DownloadStarting 下载即将开始（可 Cancel） │ │ ProcessFailed 浏览器进程崩溃 │ └────────────────────────────────────────────────┘ ┌─ 脚本回调 ──────────────────────────────────────┐ │ JsAsyncResult 异步 JS 执行完成 │ │ JsMessage JS postMessage 到宿主 │ │ DevToolsProtocolResponse CDP 异步响应 │ └────────────────────────────────────────────────┘ ┌─ 宿主交互 ──────────────────────────────────────┐ │ HostMouseDown/Up/DblClick/Move/Wheel/ContextMenu│ │ HostKeyDown/Up/Press 键盘事件 │ │ HostFocus / HostBlur 焦点进出 │ │ HostResize 宿主窗口大小变化 │ └────────────────────────────────────────────────┘ ┌─ 内容区鼠标（需 EnableUserMouseEvents=True）────┐ │ UserMouseDown/Up/Move/Wheel/ContextMenu/DblClick│ └────────────────────────────────────────────────┘ ┌─ 异步操作回调 ──────────────────────────────────┐ │ SuspendCompleted / SuspendFailed │ │ PrintToPdfCompleted / PrintToPdfFailed │ │ OnGetCookiesFull │ └────────────────────────────────────────────────┘ ┌─ 错误 ─────────────────────────────────────────┐ │ Error 创建/运行时错误 │ └────────────────────────────────────────────────┘ ``` ### 阶段与 API 可用性对照 | 阶段 | 时机 | 可做的事 | |------|------|----------| | **Initialize 调用前** | 对象刚创建 | 仅可设置 EnvironmentOptions 的子属性 | | **Create 事件** | Environment 创建前 | 设置 EnvironmentOptions、Security 配置 | | **Ready 事件** | 控件完全就绪 | 导航、注册绑定、注入脚本、设置运行时属性 | | **DOMContentLoaded** | DOM 就绪 | BindUI、BindData、执行 JS（确保元素存在） | | **NavigationComplete** | 页面完全加载 | 所有运行时 API 无限制使用 | | **运行时任意时刻** | Ready 之后 | 所有 API 无限制使用 | *** ## 📋 属性使用时机总览 ### 🔴 仅 Create 事件（创建前配置） 这些属性影响 WebView2 Environment 的创建参数，**必须在 `wv_Create` 事件中设置**，之后修改无效。 | 属性 | 子属性 | 说明 | |------|--------|------| | **EnvironmentOptions** | `UserDataFolder` | 用户数据目录，创建 Environment 时读取，之后改了也不生效 | | | `BrowserExecutableFolder` | 浏览器可执行文件目录 | | | `AdditionalBrowserArguments` | 附加命令行参数（如 `--ignore-certificate-errors`） | | | `Language` | 浏览器默认语言 | | | `TargetCompatibleBrowserVersion` | 目标兼容版本 | | | `AllowSingleSignOnUsingOSPrimaryAccount` | SSO 配置 | | | `ExclusiveUserDataFolderAccess` | 独占数据目录 | | | `EnableTrackingPrevention` | 跟踪防护 | | **Security** | `CertificateErrorAction` | 证书错误处理策略，必须在 Create 前设置 | **示例**： ```vb Private Sub wv_Create() ' ★ 这些只能在 Create 事件中设置！ wv.EnvironmentOptions.UserDataFolder = App.Path & "\UserDir\account-001" wv.EnvironmentOptions.AdditionalBrowserArguments = "--ignore-certificate-errors" wv.Security.CertificateErrorAction = CEA_AlwaysAllow End Sub ``` ### 🟡 Ready 事件起可用（运行时设置） 这些属性需要 CoreWebView2 Controller/Settings 对象已创建，**从 `wv_Ready` 事件起可设置**。在 Create 事件中设置可能无效（底层 Settings 对象尚未创建）。 | 属性 | 说明 | 注意 | |------|------|------| | **IsPasswordAutoSaveEnabled** | 密码自动保存 | 默认 False，需在 Ready 后设置才生效 | | **IsGeneralAutoFillEnabled** | 表单自动填充 | 默认 False，需在 Ready 后设置才生效 | | **IsScriptEnabled** | JS 执行开关 | 默认 True | | **AreDevToolsEnabled** | DevTools 开关 | 默认 True，生产建议关闭 | | **IsStatusBarEnabled** | 状态栏显示 | 默认 False | | **IsZoomControlEnabled** | 用户缩放控制 | 默认 True | | **AreDefaultContextMenusEnabled** | 右键菜单 | 默认 True | | **UserAgent** | 自定义 UA | 设置后后续请求生效 | | **IsPinchZoomEnabled** | 捏合缩放 | 默认 True | | **IsSwipeNavigationEnabled** | 滑动导航 | 默认 True | | **AreBrowserAcceleratorKeysEnabled** | 浏览器快捷键 | 默认 True | | **ZoomFactor** | 缩放因子 | 默认 1.0，需要页面已加载 | | **EnableUserMouseEvents** | 内容区鼠标事件 | 默认 False，Ready 后设置并自动注入代理 | | **EnableUserMouseMove** | 内容区 mousemove | 需 EnableUserMouseEvents 为 True | | **EnableMouseMoveEvents** | 宿主 mousemove | 默认 False | **示例**： ```vb Private Sub wv_Ready() ' ★ 运行时设置属性 wv.IsPasswordAutoSaveEnabled = True wv.IsGeneralAutoFillEnabled = True wv.AreDevToolsEnabled = False ' 生产环境关闭 DevTools wv.UserAgent = "Mozilla/5.0 (MyApp)" ' 启用鼠标事件代理 wv.EnableUserMouseEvents = True End Sub ``` ### 🟢 任意时间可用（只读状态） 这些属性是只读的，随时可读取，但需要 Ready 后才有有效值。 | 属性 | 说明 | Ready 前值 | |------|------|------------| | **IsReady** | 是否就绪 | False → True | | **hWnd** | 子窗口句柄 | 0 → 有效句柄 | | **BrowserProcessId** | 进程 ID | 0 → 有效 ID | | **CanGoBack** | 可后退 | False | | **CanGoForward** | 可前进 | False | | **IsSuspended** | 是否挂起 | False | | **IsMuted** | 是否静音 | False | | **IsDocumentPlayingAudio** | 播放音频 | False | | **IsDefaultDownloadDialogOpen** | 下载对话框 | False | | **DocumentURL** | 当前 URL | "" → 有效 URL | | **DocumentTitle** | 当前标题 | "" → 有效标题 | | **SupportsWebView2~9** | 功能检测 | Ready 后才有准确值 | | **Cookies** | Cookie 对象 | Ready 后可用 | | **Script** | 脚本对象 | Ready 后可用 | | **HostAdapterName** | 适配器名称 | Initialize 时即有值 | *** ## 📋 方法使用时机总览 ### 🔴 仅 Create 事件 | 方法 | 说明 | |------|------| | — | 目前没有方法仅限 Create 事件使用 | > 注意：Create 事件中虽然可以调用某些方法，但底层 CoreWebView 对象尚未创建，大部分方法会静默失败（被 `If m_Core Is Nothing Then Exit Sub` 保护）。Create 事件的唯一用途是配置 **EnvironmentOptions** 和 **Security**。 ### 🟡 Ready 事件起可用 这些方法需要 CoreWebView 对象已创建，**从 `wv_Ready` 事件起才可调用**： | 方法 | 说明 | 注意 | |------|------|------| | **Navigate** | 导航到 URL | Ready 后调用，Create 中调用无效 | | **NavigateCustom** | 自定义请求导航 | 同上 | | **NavigateToString** | 加载 HTML 字符串 | 同上 | | **GoBack / GoForward / Reload** | 导航控制 | 需有导航历史 | | **ExecuteScript** | 异步执行 JS | 需页面已加载 | | **JsRun** | 同步调用 JS | 需页面已加载 | | **JsRunAsync** | 异步调用 JS | 需页面已加载 | | **JsProp** | 读取 JS 属性 | 需页面已加载 | | **PostWebMessage** | 发送字符串消息 | 需页面已加载 | | **PostWebMessageJSON** | 发送 JSON 消息 | 需页面已加载 | | **AddObject** | 注入 COM 对象 | Ready 后注入，页面 JS 才能访问 | | **RemoveObject** | 移除 COM 对象 | | | **AddScriptToExecuteOnDocumentCreated** | 注入脚本 | Ready 后注入，后续页面才执行 | | **AddWebResourceRequestedFilter** | 添加资源过滤器 | Ready 后注册才生效 | | **RemoveWebResourceRequestedFilter** | 移除过滤器 | | | **SetVirtualHostNameToFolderMapping** | 虚拟主机映射 | Ready 后设置，然后 Navigate | | **ClearVirtualHostNameToFolderMapping** | 清除映射 | | | **PrintToPdf** | 打印 PDF | 需页面已加载 | | **Suspend / Resume** | 挂起/恢复 | | | **OpenDevToolsWindow** | 打开 DevTools | | | **CallDevToolsProtocolMethod** | 异步 CDP | | | **CallDevToolsProtocolMethodSync** | 同步 CDP | | | **OpenDefaultDownloadDialog** | 打开下载对话框 | | | **CloseDefaultDownloadDialog** | 关闭下载对话框 | | | **OpenTaskManagerWindow** | 任务管理器 | | | **Resize** | 调整大小 | | | **SetFocus** | 设置焦点 | | | **BindUI** | DOM 事件绑定 | 需页面 DOM 存在 | | **UnbindUI** | 移除事件绑定 | | | **BindData** | 数据绑定 | 需页面 DOM 存在 | | **UnbindData** | 移除数据绑定 | | | **SetData** | 推送数据 | 需已 BindData | | **SetDataBatch** | 批量推送 | 需已 BindData | ### 🟢 任意时间可用（但建议 Ready 后） | 方法 | 说明 | |------|------| | **Initialize** | 初始化控件，是起点 | | **Cleanup** | 清理资源，随时可调用 | ### 🔵 建议在 DOMContentLoaded 后使用 以下方法依赖页面 DOM 已渲染，建议在 `wv_DOMContentLoaded` 或 `wv_NavigationComplete` 事件之后调用： | 方法 | 说明 | 原因 | |------|------|------| | **BindUI** | DOM 事件绑定 | 需元素已存在于 DOM | | **BindData** | 数据绑定 | 需元素已存在于 DOM | | **SetData / SetDataBatch** | 推送数据 | 需已完成 BindData | | **JsRun / JsProp** | 同步 JS 调用 | 需 JS 环境就绪 | | **Script.Eval** | 同步执行 JS | 需页面 JS 可执行 | **最佳实践**： ```vb Private Sub wv_DOMContentLoaded() ' ★ DOM 就绪后绑定 UI 和数据 wv.BindData "name", "#name-input", "value" wv.BindData "name", "#name-preview", "textContent" wv.BindUI Me, "OnNameInput", "#name-input", EventName:="input" wv.SetData "name", "初始值" End Sub ``` *** ## ⚠️ 常见错误场景 | 错误做法 | 问题 | 正确做法 | |----------|------|----------| | 在 Form\_Load 设置 `EnvironmentOptions.UserDataFolder` | Initialize 内部会覆盖默认值，但用户在 Create 之前的设置会被保留 | 在 `wv_Create` 事件中设置 | | 在 Create 事件中 `Navigate` | CoreWebView 尚未创建，静默失败 | 在 `wv_Ready` 事件中 Navigate | | 在 Ready 事件前 `AddObject` | 底层 CoreWebView 为 Nothing | 在 `wv_Ready` 事件中 AddObject | | 在 NavigationStarting 中 `BindData` | DOM 可能尚未加载 | 在 `wv_DOMContentLoaded` 中 BindData | | 在 Create 中设置 `IsPasswordAutoSaveEnabled` | Settings4 对象尚未创建，可能无效 | 在 `wv_Ready` 后设置 | *** ## 🗺️ 快速决策流程图 ``` 需要配置 EnvironmentOptions 或 Security？ → ★ wv_Create 事件 需要设置运行时属性（IsPasswordAutoSaveEnabled 等）？ → ★ wv_Ready 事件起 需要导航、注入脚本、注册过滤器？ → ★ wv_Ready 事件起 需要绑定 UI/数据、执行 JS？ → ★ wv_DOMContentLoaded 事件起（确保 DOM 就绪） 需要读取状态（URL、标题等）？ → ★ 任意时间（但 Ready 后才有有效值） ``` *** **最后更新**: 2026-06-26 --- --- url: /en/vbman2/webview2/overview.md --- # cWebView2Host Class Developer Documentation > 🚀 **cWebView2Host** - A VB6/twinBASIC embedded browser control wrapper based on [twinBASIC WebView2Package](https://docs.twinbasic.com/WebView2), developed by woeoio@qq.com (see [Credits](../CREDITS.md)) ## 📖 Table of Contents * [Overview](#overview) * [Core Highlights](#core-highlights) * [Quick Start](#quick-start) * [Architecture Design](#architecture-design) * [Documentation Index](#documentation-index) *** ## Overview `cWebView2Host` is a COM-creatable class that provides Microsoft Edge WebView2 embedded browser capabilities for VB6/VBA/twinBASIC applications. It encapsulates the full complexity of the WebView2 Win32 C API, providing a clean VB-style API, a complete event model, and a declarative data binding system. ### ✨ Key Features * 🌐 **Zero-Configuration Embedding** - Embed a full Chromium browser in a form with just two lines of code * 📡 **40+ Events** - Covering navigation, scripting, mouse, keyboard, downloads, PDF printing, and more * 🔗 **Declarative Data Binding** - BindUI/BindData two-way binding, zero glue code between VB6 and DOM * ⚡ **Synchronous JS Calls** - JsRun/JsProp execute JavaScript synchronously, no more async callback hell * 🔧 **Full CDP Support** - Synchronous/asynchronous Chrome DevTools Protocol calls for deep browser control * 🛡️ **Security Controls** - Certificate error bypass, HTTPS filtering, script toggle in one-stop configuration * 🍪 **Cookie Management** - Simple/full dual-mode Cookie retrieval, including HttpOnly support * 📦 **Local Resource Mapping** - Three local page loading methods: folder, resource file, and virtual host * 🖥️ **Multi-Host Adaptation** - VB6/Excel subclassing + Access message window dual-strategy auto-detection * 📑 **Session Isolation** - Multi-instance independent UserDataFolder, supporting multi-account parallelism *** ## Core Highlights ### 1️⃣ Two Lines to Embed a Browser 🌐 No configuration files or initialization steps needed — minimal usage requires just two calls: ```vb Dim wv As New cWebView2Host Private Sub Form_Load() wv.Initialize Me.hWnd, "https://vb6.pro" End Sub ``` One line of declaration, one line of initialization — a full Edge browser engine in your form instantly. *** ### 2️⃣ Declarative Two-Way Data Binding 🔗 Zero glue code two-way binding between VB6 and Web UI — declare instead of command: ```vb ' Host -> UI: Bind key to DOM attribute wv.BindData "name", "#name-input", "value" wv.BindData "name", "#name-preview", "textContent" ' UI -> Host: Bind DOM event to VB6 method wv.BindUI Me, "OnNameInput", "#name-input", EventName:="input" ' Push data to UI wv.SetData "name", "Zhang Wei" ``` *** ### 3️⃣ Synchronous JavaScript Execution ⚡ No callbacks needed — get JS return values synchronously in VB6: ```vb ' Synchronously call JS function and get return value Dim title As String title = wv.JsRun("document.title") ' Synchronously read JS property Dim url As String url = wv.JsProp("location.href") ' Synchronously execute CDP command Dim cookies As String cookies = wv.CallDevToolsProtocolMethodSync("Network.getCookies", "{}") ``` *** ### 4️⃣ Complete Event-Driven Model 📡 Covering all WebView2 lifecycle events — from creation to destruction, from navigation to interaction: ```vb Dim WithEvents wv As cWebView2Host ' Lifecycle Private Sub wv_Create(): ... Private Sub wv_Ready(): ... ' Navigation control Private Sub wv_NavigationStarting(ByVal Uri As String, ByRef Cancel As Boolean): ... Private Sub wv_NavigationComplete(ByVal IsSuccess As Boolean): ... ' Host mouse/keyboard Private Sub wv_HostMouseDown(ByVal Button As Long, ByVal Shift As Long, ByVal X As Long, ByVal Y As Long): ... ' JS messages Private Sub wv_JsMessage(ByVal Message As String): ... ``` *** ### 5️⃣ Multi-Host Auto-Adaptation 🖥️ The same API automatically adapts to three host environments: VB6, Excel UserForm, and Access OForm: ```vb ' All three hosts use exactly the same API wv.Initialize Me.hWnd, "https://vb6.pro" ' VB6 / Excel UserForm wv.Initialize Me, "https://vb6.pro" ' Pass Form object (auto-detected) ' Access forms auto-detect OForm class name, switching to MessageWindowAdapter ``` Internally detects the host window class name — VB6/Excel uses the subclassing adapter, Access uses the message window adapter. *** ## Quick Start ### Minimal Example ```vb Dim wv As New cWebView2Host Private Sub Form_Load() wv.Initialize Me.hWnd, "https://vb6.pro" End Sub ``` ### Example with Event Handling ```vb Dim WithEvents wv As cWebView2Host Private Sub Form_Load() Set wv = New cWebView2Host wv.Initialize Me.hWnd, "https://vb6.pro" End Sub Private Sub wv_Ready() Me.Caption = wv.DocumentTitle Debug.Print "Browser is ready" End Sub Private Sub wv_DocumentTitleChanged() Me.Caption = wv.DocumentTitle End Sub ``` ### Loading Local HTML Files ```vb ' Method 1: Folder path auto-mapping wv.Initialize Me.hWnd, App.Path & "\www" ' Method 2: Virtual host name mapping wv.Initialize Me.hWnd wv.SetVirtualHostNameToFolderMapping "myapp.local", App.Path & "\www" wv.Navigate "https://myapp.local/index.html" ' Method 3: Load from VB6 resource file wv.Initialize Me.hWnd ' In the wv_Ready event: wv.NavigateToString VBMAN2.Res(LoadResData("INDEX.HTML", "WWW")).ReturnString() ``` *** ## Architecture Design ### Class Hierarchy ``` cWebView2Host (Public COM class, direct user interaction) ├── m_Core: WebView2Core (Core engine, implements 21 COM callback interfaces) │ ├── ICoreWebView2 ~ ICoreWebView2_9 (Versioned interface cache) │ ├── ICoreWebView2Settings ~ Settings6 │ ├── ICoreWebView2Environment ~ _8 │ └── All event delegate Token management │ ├── m_Cookies: cWebView2Cookies (Cookie management business object) │ └── GetCookies / GetCookiesFull / GetCookiesFullAsync │ ├── m_Script: cWebView2Script (Script execution business object) │ └── Eval (Synchronous JS expression evaluation) │ ├── m_Security: cWebView2Security (Security/certificate management business object) │ └── CertificateErrorAction / AdditionalBrowserArguments │ ├── m_MouseProxy: WebView2MouseProxy (JS->Host mouse event COM proxy) │ └── Exposed as JS global object mouseProxy │ ├── m_BindUIProxy: WebView2BindUIProxy (Declarative binding COM proxy) │ ├── Exposed as JS global object bindUIProxy │ ├── BindUI event binding management │ ├── BindData data binding management │ └── Auto-rebuild bindings after navigation │ └── Adapter: IHostAdapter (Host adaptation abstraction layer) ├── HostSubclassAdapter (VB6/Excel, subclassing host window) └── MessageWindowAdapter (Access, message window + polling) ``` ### Object Relationship Diagram ``` User Code │ ▼ cWebView2Host ──────── Event Forwarding ──────── WebView2Core (WithEvents) │ │ ├── Cookies ──────────────────────────────┤ CDP / document.cookie ├── Script ───────────────────────────────┤ ExecuteScript / JsRun ├── Security ─────────────────────────────┤ AdditionalBrowserArguments │ │ ├── BindUIProxy ◄── AddObject ────────────┤ JS global object bindUIProxy └── MouseProxy ◄── AddObject ────────────┤ JS global object mouseProxy ──────────────────────────┘ │ IHostAdapter (Adapter Layer) ┌─────────┴─────────┐ HostSubclassAdapter MessageWindowAdapter (VB6/Excel subclassing) (Access message window) ``` ### Initialization Flow ``` 1. cWebView2Host.Initialize(HostOrHwnd, HttpOrDir) 2. Auto-detect host window class name ├── "OForm" → Create MessageWindowAdapter └── Other → Create HostSubclassAdapter 3. Adapter.Attach() → Subclass host window / Create message window 4. Create WebView2 Environment (with retry logic, up to 10 attempts) 5. Create WebView2 Controller 6. CacheWebViewObjects() → QI cache ICoreWebView2_1~9 7. CacheSettingsObjects() → QI cache Settings_1~6 8. Inject MouseProxy / BindUIProxy COM objects 9. Fire Create event 10. WebView2 control initialization complete → Fire Ready event 11. If URL specified → Auto-navigate ``` ### Three-Phase Initialization Pattern For scenarios requiring environment configuration before navigation, use the three-phase pattern: ``` Phase 1: Initialize (no URL) → Create WebView2 control Phase 2: wv_Create event → Configure EnvironmentOptions / Security Phase 3: wv_Ready event → Execute Navigate / NavigateToString ``` ```vb Private Sub Form_Load() Set wv = New cWebView2Host wv.Initialize Me.hWnd ' Phase 1: No URL End Sub Private Sub wv_Create() wv.EnvironmentOptions.UserDataFolder = App.Path & "\UserDir\account-001" wv.Security.CertificateErrorAction = CEA_AlwaysAllow ' Phase 2: Configure End Sub Private Sub wv_Ready() wv.Navigate "https://example.com" ' Phase 3: Navigate End Sub ``` *** ## Documentation Index | Document | Description | |----------|-------------| | [Methods Reference](./methods.md) | Complete public methods API reference for cWebView2Host | | [Properties Reference](./properties.md) | Complete public properties API reference for cWebView2Host | | [Events Reference](./events.md) | Detailed description of all cWebView2Host events | | [Data Binding Guide](./bindui.md) | BindUI/BindData/SetData two-way binding system | | [CDP Guide](./cdp.md) | Chrome DevTools Protocol calling guide | | [Host Adaptation Guide](./hosting.md) | VB6/Excel/Access multi-host integration guide | | [Usage Timing Reference](./usage-timing.md) | Best timing reference for methods and events | | [FAQ](./faq.md) | Common questions and solutions during development | *** ## Dependencies | Component | Description | |-----------|-------------| | **Microsoft Edge WebView2 Runtime** | Runtime dependency, must be installed on target machine | | **vbman2\_win32.dll** | VBMAN2 type library, provides COM registration | | **WebView2 Win32 C API** | Underlying COM interfaces, encapsulated by interface definitions in Abstract/ directory | *** ## Compatibility * **VB6** - Fully compatible, supports subclassing adapter * **VBA (Excel)** - Fully compatible, uses subclassing adapter in UserForms * **VBA (Access)** - Fully compatible, automatically uses message window adapter * **twinBASIC** - Fully compatible, native development language * **Windows** - Windows 10 and above (WebView2 Runtime requirement) * **WebView2 Runtime** - Version 86.0.616.0 and above *** ## License Based on the Microsoft WebView2 SDK *** ## Author **cWebView2Host**: woeoio@qq.com *** **Last Updated**: 2026-06-24 --- --- url: /en/vbman2/webview2/events.md --- # cWebView2Host Events Reference ## 📋 Events Overview cWebView2Host provides 40+ events covering the entire WebView2 lifecycle. To use events, declare the variable with `WithEvents`: ```vb Dim WithEvents wv As cWebView2Host ``` ### Event Category Index | Category | Event | Trigger Timing | |----------|-------|----------------| | **Lifecycle** | Create | WebView2 control creation completed | | | Ready | WebView2 control initialization completed, control ready | | | Error | Error during creation or runtime | | **Navigation** | NavigationStarting | Navigation starting (cancelable) | | | NavigationComplete | Navigation completed | | | SourceChanged | URL changed | | | DocumentTitleChanged | Document title changed | | | DOMContentLoaded | DOM loading completed | | **Permission/Dialog** | PermissionRequested | Page requests permission | | | ScriptDialogOpening | Script dialog appearing (alert/confirm/prompt) | | | AcceleratorKeyPressed | Accelerator key pressed | | | NewWindowRequested | Page requests opening new window | | **Resources** | WebResourceRequested | Web resource request intercepted | | | ProcessFailed | Browser process failed | | | DownloadStarting | Download about to start | | **Scripting** | JsAsyncResult | Async script execution completed | | | JsMessage | JS postMessage received | | | DevToolsProtocolResponse | CDP async response | | **Host Mouse** | HostMouseDown | Mouse down in host area | | | HostMouseUp | Mouse up in host area | | | HostMouseDblClick | Mouse double-click in host area | | | HostMouseMove | Mouse move in host area | | | HostMouseWheel | Mouse wheel in host area | | | HostContextMenu | Context menu in host area | | **Host Keyboard** | HostKeyDown | Key down in host area | | | HostKeyUp | Key up in host area | | | HostKeyPress | Key press in host area | | | HostFocus | WebView2 gained focus | | | HostBlur | WebView2 lost focus | | | HostResize | Host window size changed | | **User Mouse** | UserMouseDown | Mouse down in content area | | | UserMouseUp | Mouse up in content area | | | UserMouseMove | Mouse move in content area | | | UserMouseWheel | Mouse wheel in content area | | | UserContextMenu | Context menu in content area | | | UserDblClick | Mouse double-click in content area | | **Suspend** | SuspendCompleted | Suspend succeeded | | | SuspendFailed | Suspend failed | | **PDF** | PrintToPdfCompleted | PDF print succeeded | | | PrintToPdfFailed | PDF print failed | | **Business** | OnGetCookiesFull | Async cookie retrieval completed | *** ## 🔄 Lifecycle Events ### Create WebView2 control creation completed, but navigation has not yet started. ```vb Private Sub wv_Create() ``` **Trigger Timing**: After WebView2 Environment and Controller are successfully created. **Purpose**: This is the correct timing to configure EnvironmentOptions and Security, since the environment is created but navigation has not yet started. **Example**: ```vb Private Sub wv_Create() ' Configure user data directory wv.EnvironmentOptions.UserDataFolder = App.Path & "\UserDir\account-001" ' Configure security options wv.Security.CertificateErrorAction = CEA_AlwaysAllow End Sub ``` *** ### Ready WebView2 control initialization completed, control fully ready. ```vb Private Sub wv_Ready() ``` **Trigger Timing**: Fires once after the WebView2 control initialization completes. Does not trigger again. **Purpose**: Safely perform initialization operations such as binding events, registering data bindings, injecting scripts, etc. **Example**: ```vb Private Sub wv_Ready() Me.Caption = wv.DocumentTitle ' Set up data bindings wv.BindData "name", "#name-input", "value" wv.BindUI Me, "OnNameInput", "#name-input", EventName:="input" wv.SetData "name", "Default value" ' Inject script wv.AddScriptToExecuteOnDocumentCreated "window.__appReady = true;" End Sub ``` *** ### Error Error during creation or runtime. ```vb Private Sub wv_Error(ByVal Description As String) ``` **Parameters**: * `Description` - Error description message *** ## 🧭 Navigation Events ### NavigationStarting Navigation is about to start — can be canceled via the Cancel parameter. ```vb Private Sub wv_NavigationStarting(ByVal Uri As String, ByVal IsUserInitiated As Boolean, ByRef Cancel As Boolean) ``` **Parameters**: * `Uri` - Target URL * `IsUserInitiated` - Whether triggered by user action (e.g., clicking a link) * `Cancel` - Set to True to cancel navigation **Example**: ```vb Private Sub wv_NavigationStarting(ByVal Uri As String, ByVal IsUserInitiated As Boolean, ByRef Cancel As Boolean) ' Block navigation to specific domain If InStr(UCase(Uri), "ADS.EXAMPLE.COM") > 0 Then Cancel = True End If End Sub ``` *** ### NavigationComplete Navigation completed. ```vb Private Sub wv_NavigationComplete(ByVal IsSuccess As Boolean, ByVal ErrorStatus As wv2ErrorStatus) ``` **Parameters**: * `IsSuccess` - Whether navigation succeeded * `ErrorStatus` - Error status code (0 on success) *** ### SourceChanged URL changed. ```vb Private Sub wv_SourceChanged(ByVal IsNewDocument As Boolean) ``` **Parameters**: * `IsNewDocument` - Whether this is a new document (vs. same-page navigation) *** ### DocumentTitleChanged Document title changed. ```vb Private Sub wv_DocumentTitleChanged() ``` **Example**: ```vb Private Sub wv_DocumentTitleChanged() Me.Caption = wv.DocumentTitle End Sub ``` *** ### DOMContentLoaded DOM content loading completed (earlier than NavigationComplete). ```vb Private Sub wv_DOMContentLoaded() ``` **Purpose**: Perform operations when DOM is ready but resources (images, etc.) have not fully loaded. *** ## 🔐 Permission/Dialog Events ### PermissionRequested Page requests permission (geolocation, camera, microphone, etc.). ```vb Private Sub wv_PermissionRequested(ByVal Uri As String, ByVal PermissionKind As wv2PermissionKind, ByVal IsUserInitiated As Boolean, ByRef State As wv2PermissionState) ``` **Parameters**: * `Uri` - URL of the page requesting permission * `PermissionKind` - Permission type enum * `IsUserInitiated` - Whether triggered by user action * `State` - Permission state, can be set to `wv2PermissionState_Allow` or `wv2PermissionState_Deny` **Example**: ```vb Private Sub wv_PermissionRequested(ByVal Uri As String, ByVal PermissionKind As wv2PermissionKind, ByVal IsUserInitiated As Boolean, ByRef State As wv2PermissionState) ' Auto-allow geolocation from trusted domains If PermissionKind = wv2PermissionKind_Geolocation And InStr(Uri, "myapp.com") > 0 Then State = wv2PermissionState_Allow Else State = wv2PermissionState_Deny End If End Sub ``` *** ### ScriptDialogOpening JavaScript dialog about to appear (alert / confirm / prompt / beforeunload). ```vb Private Sub wv_ScriptDialogOpening(ByVal Kind As wv2ScriptDialogKind, ByVal Message As String, ByRef Accept As Boolean) ``` **Parameters**: * `Kind` - Dialog type * `Message` - Dialog message content * `Accept` - Set to True to accept the dialog (equivalent to clicking OK), False to cancel **Note**: Can be used to customize dialog appearance, replacing the browser's default dialogs. *** ### AcceleratorKeyPressed Accelerator key pressed event. ```vb Private Sub wv_AcceleratorKeyPressed(ByVal KeyEventKind As wv2KeyEventKind, ByVal VirtualKey As Long, ByRef Handled As Boolean) ``` **Parameters**: * `KeyEventKind` - Key event type (KeyDown/Up/SystemKeyDown/Up) * `VirtualKey` - Virtual key code * `Handled` - Set to True to prevent WebView2 from handling this key **Example**: ```vb Private Sub wv_AcceleratorKeyPressed(ByVal KeyEventKind As wv2KeyEventKind, ByVal VirtualKey As Long, ByRef Handled As Boolean) ' Intercept F5 refresh If VirtualKey = vbKeyF5 Then Handled = True ' Custom refresh logic End If End Sub ``` *** ### NewWindowRequested Page requests opening a new window (target="\_blank" or window.open). ```vb Private Sub wv_NewWindowRequested(ByVal Uri As String, ByVal IsUserInitiated As Boolean, ByRef Handled As Boolean) ``` **Parameters**: * `Uri` - Target URL of the new window * `IsUserInitiated` - Whether triggered by user action * `Handled` - Set to True to prevent opening a new window **Example**: ```vb Private Sub wv_NewWindowRequested(ByVal Uri As String, ByVal IsUserInitiated As Boolean, ByRef Handled As Boolean) ' Navigate in current window (block popup) Handled = True wv.Navigate Uri End Sub ``` *** ## 📦 Resource Events ### WebResourceRequested Web resource request intercepted by AddWebResourceRequestedFilter. ```vb Private Sub wv_WebResourceRequested(ByVal Request As WebView2Request, ByVal Response As WebView2Response) ``` **Parameters**: * `Request` - Request object, can read Method, Uri, Headers, Content * `Response` - Response object; after setting values, WebView2 uses this response instead of the actual network request **Note**: Must call `AddWebResourceRequestedFilter` to register a filter before this event will fire. *** ### ProcessFailed Browser process failed. ```vb Private Sub wv_ProcessFailed(ByVal FailedKind As wv2ProcessFailedKind) ``` **Parameters**: * `FailedKind` - Process failure type enum *** ### DownloadStarting Download about to start. ```vb Private Sub wv_DownloadStarting(ByVal ResultFilePath As String, ByRef Cancel As Boolean, ByRef Handled As Boolean) ``` **Parameters**: * `ResultFilePath` - Download file path * `Cancel` - Set to True to cancel download * `Handled` - Set to True to indicate handled *** ## ⚡ Script Events ### JsAsyncResult Async script execution completed (callback for ExecuteScript / JsRunAsync). ```vb Private Sub wv_JsAsyncResult(ByVal Token As Long, ByVal Result As String, ByVal ErrorCode As Long) ``` **Parameters**: * `Token` - Token specified at call time * `Result` - JSON string of JS execution result * `ErrorCode` - Error code, 0 indicates success **Example**: ```vb wv.ExecuteScript "document.title", 1001 wv.JsRunAsync "fetch('/api').then(r=>r.json())" ' Returns auto token Private Sub wv_JsAsyncResult(ByVal Token As Long, ByVal Result As String, ByVal ErrorCode As Long) If ErrorCode = 0 Then Debug.Print "Token " & Token & " => " & Result End If End Sub ``` *** ### JsMessage Message received from JS via `window.chrome.webview.postMessage()`. ```vb Private Sub wv_JsMessage(ByVal Message As String) ``` **Parameters**: * `Message` - Message string sent from JS **Example**: ```vb ' VB6 side Private Sub wv_JsMessage(ByVal Message As String) Debug.Print "JS message: " & Message End Sub ' JS side window.chrome.webview.postMessage("Hello from JS"); ``` *** ### DevToolsProtocolResponse CDP async call response. ```vb Private Sub wv_DevToolsProtocolResponse(ByVal CustomEventId As Variant, ByVal JsonResponse As String) ``` **Parameters**: * `CustomEventId` - Custom event ID specified at call time * `JsonResponse` - JSON string of CDP response **Example**: ```vb wv.CallDevToolsProtocolMethod "Page.captureScreenshot", "{}", "screenshot" Private Sub wv_DevToolsProtocolResponse(ByVal CustomEventId As Variant, ByVal JsonResponse As String) If CustomEventId = "screenshot" Then ' Process screenshot data End If End Sub ``` *** ## 🖱️ Host Mouse Events Host mouse events are captured by subclassing the host window and reflect mouse operations in the host window area (not the WebView2 content area). ### HostMouseDown ```vb Private Sub wv_HostMouseDown(ByVal Button As wv2MouseButton, ByVal Shift As wv2ShiftState, ByVal X As Long, ByVal Y As Long) ``` **Parameters**: * `Button` - Mouse button (1=Left, 2=Right, 4=Middle, bitmask) * `Shift` - Modifier key state (1=Shift, 2=Ctrl, 4=Alt, bitmask) * `X`, `Y` - Mouse coordinates (client area pixels) *** ### HostMouseUp ```vb Private Sub wv_HostMouseUp(ByVal Button As wv2MouseButton, ByVal Shift As wv2ShiftState, ByVal X As Long, ByVal Y As Long) ``` *** ### HostMouseDblClick ```vb Private Sub wv_HostMouseDblClick(ByVal Button As wv2MouseButton, ByVal Shift As wv2ShiftState, ByVal X As Long, ByVal Y As Long) ``` *** ### HostMouseMove ```vb Private Sub wv_HostMouseMove(ByVal Button As wv2MouseButton, ByVal Shift As wv2ShiftState, ByVal X As Long, ByVal Y As Long) ``` **Note**: Requires `EnableMouseMoveEvents = True` to fire; disabled by default to avoid performance issues. *** ### HostMouseWheel ```vb Private Sub wv_HostMouseWheel(ByVal Delta As Long, ByVal Shift As wv2ShiftState, ByVal X As Long, ByVal Y As Long) ``` **Parameters**: * `Delta` - Wheel delta, positive for scroll up, negative for scroll down *** ### HostContextMenu ```vb Private Sub wv_HostContextMenu(ByVal X As Long, ByVal Y As Long) ``` *** ## ⌨️ Host Keyboard Events ### HostKeyDown / HostKeyUp / HostKeyPress ```vb Private Sub wv_HostKeyDown(ByVal KeyCode As Long, ByVal Shift As wv2ShiftState) Private Sub wv_HostKeyUp(ByVal KeyCode As Long, ByVal Shift As wv2ShiftState) Private Sub wv_HostKeyPress(ByVal KeyAscii As Long) ``` *** ### HostFocus / HostBlur ```vb Private Sub wv_HostFocus() Private Sub wv_HostBlur() ``` *** ### HostResize ```vb Private Sub wv_HostResize() ``` **Note**: Fires when host window size changes; can call `wv.Resize()` here to manually adjust WebView2 size (e.g., when using MessageWindowAdapter). *** ## 🎯 User Mouse Events User mouse events are synchronously called back from the WebView2 content area to the host via the `mouseProxy` COM proxy. Requires `EnableUserMouseEvents = True`. ### UserMouseDown / UserMouseUp ```vb Private Sub wv_UserMouseDown(ByVal Button As Long, ByVal X As Long, ByVal Y As Long, ByVal Shift As Long, ByRef Handled As Boolean) Private Sub wv_UserMouseUp(ByVal Button As Long, ByVal X As Long, ByVal Y As Long, ByVal Shift As Long, ByRef Handled As Boolean) ``` **Parameters**: * `Button` - Mouse button (1=Left, 2=Right, 4=Middle) * `X`, `Y` - Pixel coordinates within content area * `Shift` - Modifier key state * `Handled` - Set to True to prevent event from propagating to WebView2 *** ### UserMouseMove ```vb Private Sub wv_UserMouseMove(ByVal X As Long, ByVal Y As Long, ByVal Shift As Long, ByRef Handled As Boolean) ``` **Note**: Requires additional `EnableUserMouseMove = True`; disabled by default to avoid performance issues. *** ### UserMouseWheel ```vb Private Sub wv_UserMouseWheel(ByVal Delta As Long, ByVal X As Long, ByVal Y As Long, ByVal Shift As Long, ByRef Handled As Boolean) ``` *** ### UserContextMenu ```vb Private Sub wv_UserContextMenu(ByVal X As Long, ByVal Y As Long, ByRef Handled As Boolean) ``` *** ### UserDblClick ```vb Private Sub wv_UserDblClick(ByVal Button As Long, ByVal X As Long, ByVal Y As Long, ByVal Shift As Long, ByRef Handled As Boolean) ``` *** ## 🔌 Suspend/PDF/Business Events ### SuspendCompleted / SuspendFailed ```vb Private Sub wv_SuspendCompleted() Private Sub wv_SuspendFailed(ByVal ErrorCode As Long) ``` *** ### PrintToPdfCompleted / PrintToPdfFailed ```vb Private Sub wv_PrintToPdfCompleted(ByVal ResultFilePath As String) Private Sub wv_PrintToPdfFailed(ByVal ErrorCode As Long) ``` *** ### OnGetCookiesFull Async full cookie retrieval completed. ```vb Private Sub wv_OnGetCookiesFull(ByVal CookiesJson As String) ``` **Trigger Timing**: When async result returns after calling `wv.Cookies.GetCookiesFullAsync()`. *** ## 📐 Enum Reference ### wv2MouseButton | Constant | Value | Description | |----------|-------|-------------| | Left | 1 | Left mouse button | | Right | 2 | Right mouse button | | Middle | 4 | Middle mouse button | Bitmask combination, can include multiple values simultaneously. ### wv2ShiftState | Constant | Value | Description | |----------|-------|-------------| | Shift | 1 | Shift key | | Ctrl | 2 | Ctrl key | | Alt | 4 | Alt key | Bitmask combination. Detection method: `If Shift And 2 Then ' Ctrl is pressed` ### wv2ScriptDialogKind | Constant | Description | |----------|-------------| | Alert | alert() dialog | | Confirm | confirm() dialog | | Prompt | prompt() dialog | | BeforeUnload | beforeunload dialog | ### wv2PermissionKind | Constant | Description | |----------|-------------| | Unknown | Unknown permission | | Microphone | Microphone | | Camera | Camera | | Geolocation | Geolocation | | Notifications | Notifications | | OtherSensors | Other sensors | | ClipboardRead | Clipboard read | ### wv2PermissionState | Constant | Description | |----------|-------------| | Default | Default (browser decides) | | Allow | Allow | | Deny | Deny | ### EnumCertificateErrorAction | Constant | Value | Description | |----------|-------|-------------| | CEA\_Default | 0 | Default behavior (deny) | | CEA\_Cancel | 1 | Cancel request | | CEA\_AlwaysAllow | 2 | Always allow (injects command-line argument) | *** **Last Updated**: 2026-06-24 --- --- url: /en/vbman2/webview2/methods.md --- # cWebView2Host Methods Reference ## 📋 Methods Overview | Category | Method | Description | |----------|--------|-------------| | **Lifecycle** | Initialize | Initialize WebView2 control | | **Navigation** | Navigate | Navigate to specified URL | | | NavigateCustom | Custom request navigation (supports POST/PUT) | | | NavigateToString | Load HTML string | | | GoBack | Go backward | | | GoForward | Go forward | | | Reload | Reload page | | **Scripting** | ExecuteScript | Execute JavaScript asynchronously | | | JsRun | Call JS function synchronously | | | JsRunAsync | Call JS function asynchronously (returns token) | | | JsProp | Read JS property synchronously | | **Messaging** | PostWebMessage | Send string message to WebView | | | PostWebMessageJSON | Send JSON message to WebView | | **COM Objects** | AddObject | Inject COM host object into JS global | | | RemoveObject | Remove injected COM host object | | **Script Injection** | AddScriptToExecuteOnDocumentCreated | Auto-execute script on page creation | | **Resource Filtering** | AddWebResourceRequestedFilter | Add web resource request filter | | | RemoveWebResourceRequestedFilter | Remove web resource request filter | | **DevTools** | OpenDevToolsWindow | Open DevTools window | | | CallDevToolsProtocolMethod | Call CDP method asynchronously | | | CallDevToolsProtocolMethodSync | Call CDP method synchronously | | **Virtual Host** | SetVirtualHostNameToFolderMapping | Map virtual host name to local folder | | | ClearVirtualHostNameToFolderMapping | Clear virtual host name mapping | | **PDF** | PrintToPdf | Print current page to PDF | | **Suspend/Resume** | Suspend | Suspend WebView2 process | | | Resume | Resume suspended WebView2 process | | **Download** | OpenDefaultDownloadDialog | Open default download dialog | | | CloseDefaultDownloadDialog | Close default download dialog | | **Window** | Resize | Resize WebView2 control | | | SetFocus | Set focus to WebView2 control | | | OpenTaskManagerWindow | Open browser task manager | | **Data Binding** | BindUI | Declarative DOM event → host method binding | | | UnbindUI | Remove DOM event binding | | | BindData | Declarative host data → DOM attribute binding | | | UnbindData | Remove data binding | | | SetData | Push single data value to DOM | | | SetDataBatch | Batch push data to DOM | *** ## 🌐 Lifecycle Methods ### Initialize Initialize the WebView2 control, create environment and controller, and optionally navigate to a specified URL. ```vb Public Function Initialize(HostOrHwnd As Variant, Optional HttpOrDir As String) As cWebView2Host ``` **Parameters**: * `HostOrHwnd` - Host window handle (Long/LongPtr) or VBA object (e.g., Form/Frame). When passing a Form object, hWnd is automatically obtained. * `HttpOrDir` - Optional. URL address (e.g., `"https://vb6.pro"`) or local folder path (e.g., `App.Path & "\www"`). When a folder path is provided, it auto-maps to `http://vbman2.com/index.html`. Omit to skip auto-navigation. **Returns**: Returns Me (self), supporting chained calls. **Notes**: * Auto-detects host window class name — OForm uses message window adapter, others use subclassing adapter * Environment creation has retry logic, up to 10 attempts (auto-incrementing UserDataFolder path) * Passing a Form object is equivalent to passing `Form.hWnd` **Example**: ```vb ' Minimal two-parameter form: window handle + URL wv.Initialize Me.hWnd, "https://vb6.pro" ' Pass Form object wv.Initialize Me, "https://vb6.pro" ' Load local folder wv.Initialize Me.hWnd, App.Path & "\www" ' Deferred navigation (omit second parameter) wv.Initialize Me.hWnd ' Manually navigate in wv_Ready event ``` *** *** ## 🧭 Navigation Methods ### Navigate Navigate to the specified URL. ```vb Public Sub Navigate(ByVal Url As String) ``` **Parameters**: * `Url` - Target URL address **Example**: ```vb wv.Navigate "https://example.com" ``` *** ### NavigateCustom Navigate using custom HTTP method and request body. ```vb Public Sub NavigateCustom(ByVal Url As String, ByVal Method As String, ByVal Body As String, Optional ByVal Headers As String) ``` **Parameters**: * `Url` - Target URL address * `Method` - HTTP method (e.g., `"POST"`, `"PUT"`, `"DELETE"`) * `Body` - Request body content (UTF-8 encoded) * `Headers` - Optional. Custom request headers in JSON format **Example**: ```vb ' POST request wv.NavigateCustom "https://api.example.com/data", "POST", "{""key"":""value""}", "{""Content-Type"":""application/json""}" ``` *** ### NavigateToString Load an HTML string into WebView2 for rendering. ```vb Public Sub NavigateToString(ByVal HtmlContent As String) ``` **Parameters**: * `HtmlContent` - Complete HTML string **Example**: ```vb wv.NavigateToString "

    Hello WebView2

    " ' Load from VB6 resource file wv.NavigateToString VBMAN2.Res(LoadResData("INDEX.HTML", "WWW")).ReturnString() ``` *** ### GoBack / GoForward / Reload Browser navigation controls. ```vb Public Sub GoBack() Public Sub GoForward() Public Sub Reload() ``` **Example**: ```vb If wv.CanGoBack Then wv.GoBack If wv.CanGoForward Then wv.GoForward wv.Reload ``` *** ## ⚡ Script Methods ### ExecuteScript Execute JavaScript code asynchronously — results returned via JsAsyncResult event. ```vb Public Sub ExecuteScript(ByVal JavaScript As String, Optional ByVal Token As Long = 0) ``` **Parameters**: * `JavaScript` - JavaScript code to execute * `Token` - Optional. Custom token for identifying the call in the JsAsyncResult event **Note**: Executes asynchronously, does not block the VB6 thread. Results are obtained in the `JsAsyncResult` event. **Example**: ```vb wv.ExecuteScript "document.title", 1001 Private Sub wv_JsAsyncResult(ByVal Token As Long, ByVal Result As String, ByVal ErrorCode As Long) If Token = 1001 Then Debug.Print "Page title: " & Result End If End Sub ``` *** ### JsRun Synchronously call a JavaScript function and return the result. Blocks the current thread until JS execution completes. ```vb Public Function JsRun(ByVal Expression As String, Optional ByVal TimeoutMs As Long = 5000) As String ``` **Parameters**: * `Expression` - JavaScript expression or function call * `TimeoutMs` - Optional. Timeout in milliseconds, default 5000 **Returns**: JSON string of JS execution result **Note**: Uses Sleep + DoEvents internally for synchronous waiting, does not affect VB6 form message loop. **Example**: ```vb Dim title As String title = wv.JsRun("document.title") Dim result As String result = wv.JsRun("JSON.stringify({name:'test', value:42})") ``` *** ### JsRunAsync Asynchronously call a JavaScript function, returning a token for tracking the result in an event. ```vb Public Function JsRunAsync(ByVal Expression As String) As Long ``` **Parameters**: * `Expression` - JavaScript expression **Returns**: Token, used in the `JsAsyncResult` event to match the corresponding call **Example**: ```vb Dim token As Long token = wv.JsRunAsync("fetch('https://api.example.com/data').then(r=>r.json())") Private Sub wv_JsAsyncResult(ByVal Token As Long, ByVal Result As String, ByVal ErrorCode As Long) Debug.Print "Async result token=" & Token & ": " & Result End Sub ``` *** ### JsProp Synchronously read a JavaScript property value. ```vb Public Function JsProp(ByVal Expression As String, Optional ByVal TimeoutMs As Long = 5000) As String ``` **Parameters**: * `Expression` - JavaScript property expression * `TimeoutMs` - Optional. Timeout in milliseconds, default 5000 **Returns**: JSON string of the property value **Example**: ```vb Dim url As String url = wv.JsProp("location.href") Dim userAgent As String userAgent = wv.JsProp("navigator.userAgent") ``` *** ## 📨 Messaging Methods ### PostWebMessage Send a string message to the WebView2 page. The page receives it via `window.chrome.webview.addEventListener('message', ...)`. ```vb Public Sub PostWebMessage(ByVal Message As String) ``` **Parameters**: * `Message` - Message string to send **Example**: ```vb wv.PostWebMessage "Hello from VB6" ``` *** ### PostWebMessageJSON Send a JSON-formatted message to the WebView2 page. ```vb Public Sub PostWebMessageJSON(ByVal JsonMessage As String) ``` **Parameters**: * `JsonMessage` - JSON-formatted message string **Example**: ```vb wv.PostWebMessageJSON "{""type"":""update"",""data"":{""name"":""test""}}" ``` *** ## 🔗 COM Object Methods ### AddObject Inject a COM object into WebView2's JavaScript global namespace. ```vb Public Sub AddObject(ByVal Name As String, ByVal Object As Object) ``` **Parameters**: * `Name` - Global object name in JavaScript * `Object` - COM object instance **Note**: After injection, JS can access the object's methods and properties via `window.chrome.webview.hostObjects.`. JS calls to COM methods are asynchronous by default (returning Promises); use `hostObjects.sync.` for synchronous calls. **Example**: ```vb Dim myObj As New MyComClass wv.AddObject "myApi", myObj ' In JS: ' const result = await window.chrome.webview.hostObjects.myApi.DoSomething("param"); ' const result = window.chrome.webview.hostObjects.sync.myApi.DoSomething("param"); ``` *** ### RemoveObject Remove an injected COM host object. ```vb Public Sub RemoveObject(ByVal Name As String) ``` **Parameters**: * `Name` - Previously injected object name *** ## 💉 Script Injection Methods ### AddScriptToExecuteOnDocumentCreated Script that auto-executes when a page document is created, applies to all subsequent navigated pages. ```vb Public Sub AddScriptToExecuteOnDocumentCreated(ByVal JavaScript As String) ``` **Parameters**: * `JavaScript` - JavaScript code to inject **Note**: Script executes before DOM has finished loading — suitable for injecting global variables, overriding native methods, etc. Must be called after WebView2 is created. **Example**: ```vb ' Inject global debug flag wv.AddScriptToExecuteOnDocumentCreated "window.__vb6Debug = true;" ' Intercept console.log wv.AddScriptToExecuteOnDocumentCreated _ "window.console.log = function(msg) { window.chrome.webview.postMessage('[LOG] ' + msg); };" ``` *** ## 🔍 Resource Filtering Methods ### AddWebResourceRequestedFilter Add a web resource request filter. Matching requests trigger the `WebResourceRequested` event. ```vb Public Sub AddWebResourceRequestedFilter(ByVal Uri As String, ByVal ResourceContext As wv2WebResourceContext) ``` **Parameters**: * `Uri` - URI match pattern (supports wildcards) * `ResourceContext` - Resource context type (e.g., `wv2WebResourceContext_Document`) **Example**: ```vb ' Intercept all image requests wv.AddWebResourceRequestedFilter "*", wv2WebResourceContext_Image ' Intercept scripts from specific domain wv.AddWebResourceRequestedFilter "https://ads.example.com/*", wv2WebResourceContext_Script ``` *** ### RemoveWebResourceRequestedFilter Remove a previously added resource request filter. ```vb Public Sub RemoveWebResourceRequestedFilter(ByVal Uri As String, ByVal ResourceContext As wv2WebResourceContext) ``` *** ## 🔧 DevTools Methods ### OpenDevToolsWindow Open WebView2's developer tools window. ```vb Public Sub OpenDevToolsWindow() ``` *** ### CallDevToolsProtocolMethod Asynchronously call a Chrome DevTools Protocol method. ```vb Public Sub CallDevToolsProtocolMethod(ByVal MethodName As String, ByVal ParametersAsJson As String, ByVal CustomEventId As String) ``` **Parameters**: * `MethodName` - CDP method name (e.g., `"Runtime.evaluate"`, `"Network.getCookies"`) * `ParametersAsJson` - Method parameters as JSON string * `CustomEventId` - Custom event ID for matching in the `DevToolsProtocolResponse` event **Note**: Results are returned asynchronously via the `DevToolsProtocolResponse` event. **Example**: ```vb wv.CallDevToolsProtocolMethod "Runtime.evaluate", _ "{""expression"":""document.title""}", "getTitle" Private Sub wv_DevToolsProtocolResponse(ByVal CustomEventId As Variant, ByVal JsonResponse As String) If CustomEventId = "getTitle" Then Debug.Print "CDP Title: " & JsonResponse End If End Sub ``` *** ### CallDevToolsProtocolMethodSync Synchronously call a Chrome DevTools Protocol method, blocking until the result is returned. ```vb Public Function CallDevToolsProtocolMethodSync(ByVal MethodName As String, ByVal ParametersAsJson As String) As String ``` **Parameters**: * `MethodName` - CDP method name * `ParametersAsJson` - Method parameters as JSON string **Returns**: JSON string of CDP response **Note**: Uses Sleep + DoEvents for synchronous waiting, does not affect VB6 form message loop. **Example**: ```vb Dim cookies As String cookies = wv.CallDevToolsProtocolMethodSync("Network.getCookies", "{}") Dim version As String version = wv.CallDevToolsProtocolMethodSync("Browser.getVersion", "{}") ``` *** ## 🗂️ Virtual Host Methods ### SetVirtualHostNameToFolderMapping Map a virtual host name to a local folder, allowing WebView2 to access local files via https://. ```vb Public Sub SetVirtualHostNameToFolderMapping(ByVal HostName As String, ByVal FolderPath As String, Optional ByVal AccessKind As wv2HostResourceAccessKind = wv2HostResourceAccessKind_Allow) ``` **Parameters**: * `HostName` - Virtual host name (e.g., `"myapp.local"`) * `FolderPath` - Absolute path to the local folder * `AccessKind` - Optional. Access permission, default is Allow **Example**: ```vb wv.SetVirtualHostNameToFolderMapping "myapp.local", App.Path & "\www" wv.Navigate "https://myapp.local/index.html" ``` *** ### ClearVirtualHostNameToFolderMapping Clear a virtual host name mapping. ```vb Public Sub ClearVirtualHostNameToFolderMapping(ByVal HostName As String) ``` *** ## 📑 PDF Methods ### PrintToPdf Print the current page to a PDF file. ```vb Public Sub PrintToPdf(ByVal ResultFilePath As String, _ Optional ByVal Orientation As wv2PrintOrientation = wv2PrintOrientation_Portrait, _ Optional ByVal ScaleFactor As Single = 1.0, _ Optional ByVal PageWidth As Single = 0, _ Optional ByVal PageHeight As Single = 0, _ Optional ByVal MarginTop As Single = 0, _ Optional ByVal MarginBottom As Single = 0, _ Optional ByVal MarginLeft As Single = 0, _ Optional ByVal MarginRight As Single = 0, _ Optional ByVal ShouldPrintHeader As Boolean = False, _ Optional ByVal ShouldPrintFooter As Boolean = False) ``` **Parameters**: * `ResultFilePath` - PDF output file path * `Orientation` - Optional. Print orientation, default is portrait * `ScaleFactor` - Optional. Scale factor, default 1.0 * Remaining parameters are page size and margin settings **Note**: Fires `PrintToPdfCompleted` event on success, `PrintToPdfFailed` event on failure. *** ## 🔌 Suspend/Resume Methods ### Suspend Suspend the WebView2 rendering process to save resources. ```vb Public Sub Suspend() ``` **Note**: Fires `SuspendCompleted` or `SuspendFailed` event when complete. *** ### Resume Resume a suspended WebView2 process. ```vb Public Sub Resume() ``` *** ## 📥 Download Methods ### OpenDefaultDownloadDialog / CloseDefaultDownloadDialog Open/close the default download dialog. ```vb Public Sub OpenDefaultDownloadDialog() Public Sub CloseDefaultDownloadDialog() ``` *** ## 🪟 Window Methods ### Resize Resize the WebView2 control to fit the host window. ```vb Public Sub Resize() ``` **Note**: Call when the host window size changes — internally reads the host window client area dimensions. *** ### SetFocus Set focus to the WebView2 control. ```vb Public Sub SetFocus() ``` *** ### OpenTaskManagerWindow Open the browser's built-in task manager window. ```vb Public Sub OpenTaskManagerWindow() ``` *** ## 🔗 Data Binding Methods ### BindUI Declaratively bind a DOM event to a host VB method. When the specified element triggers the event, the specified method on the host object is automatically called. ```vb Public Function BindUI(ByVal HostInst As Object, ByVal HostFunction As String, ByVal QuerySelector As String, Optional ByVal IsOverWrite As Boolean = False, Optional ByVal EventName As String = "click") As String ``` **Parameters**: * `HostInst` - Host object instance (typically pass `Me`, i.e., the Form itself) * `HostFunction` - Public method name on the host object * `QuerySelector` - CSS selector to locate the DOM element * `IsOverWrite` - Optional. Whether to overwrite same-name bindings, default False * `EventName` - Optional. DOM event name, default `"click"` **Returns**: BindId, for identifying this binding **Note**: Host method signature must be `Public Sub MethodName(ByVal EventName As String, ByVal Detail As String)`, where Detail is a JSON-formatted event detail. **Example**: ```vb Dim bindId As String bindId = wv.BindUI(Me, "OnButtonClick", "#submit-btn") ' With custom event name wv.BindUI Me, "OnNameInput", "#name-input", EventName:="input" ' Callback method Public Sub OnButtonClick(ByVal EventName As String, ByVal Detail As String) Debug.Print "Button clicked! Detail: " & Detail End Sub ``` *** ### UnbindUI Remove a DOM event binding. ```vb Public Sub UnbindUI(ByVal QuerySelector As String, Optional ByVal EventName As String = "") ``` **Parameters**: * `QuerySelector` - CSS selector used when binding * `EventName` - Optional. Specify a particular event to remove; empty removes all bindings for that element *** ### BindData Declaratively bind a data key to a DOM attribute. When SetData updates the key, all bound DOM attributes are automatically updated. ```vb Public Sub BindData(ByVal Key As String, ByVal QuerySelector As String, Optional ByVal Attr As String = "textContent") ``` **Parameters**: * `Key` - Data key name (custom identifier) * `QuerySelector` - CSS selector to locate the DOM element * `Attr` - Optional. DOM attribute name, default `"textContent"`. Supports `value`, `textContent`, `innerHTML`, `src`, `class`, `checked`, `visible` (custom), etc. **Note**: The same Key can be bound to multiple elements and different attributes. **Example**: ```vb ' Same data bound to input value and preview text wv.BindData "name", "#name-input", "value" wv.BindData "name", "#name-preview", "textContent" ' Bind to checkbox checked attribute wv.BindData "enabled", "#toggle-enabled", "checked" ' Bind to custom visible attribute (control show/hide) wv.BindData "enabled", "#settings-panel", "visible" ' Bind to image src wv.BindData "avatar", "#avatar-img", "src" ' Bind to CSS class wv.BindData "statusOnline", "#status-dot", "class" ``` *** ### UnbindData Remove a data binding. ```vb Public Sub UnbindData(ByVal Key As String) ``` **Parameters**: * `Key` - Data key name to remove *** ### SetData Push a single data value to all bound DOM elements. ```vb Public Sub SetData(ByVal Key As String, ByVal Value As Variant) ``` **Parameters**: * `Key` - Data key name * `Value` - Data value, supports String, Boolean, Number **Example**: ```vb wv.SetData "name", "Zhang Wei" wv.SetData "enabled", True wv.SetData "count", 42 wv.SetData "avatar", "https://example.com/img.png" ``` *** ### SetDataBatch Batch push data to DOM; parameter is a JSON object string. ```vb Public Sub SetDataBatch(ByVal Json As String) ``` **Parameters**: * `Json` - JSON object string where keys are data key names and values are data values **Example**: ```vb wv.SetDataBatch "{""name"":""Zhang Wei"",""enabled"":true,""count"":42}" ``` *** **Last Updated**: 2026-06-24 --- --- url: /en/vbman2/webview2/properties.md --- # cWebView2Host Properties Reference ## 📋 Properties Overview | Category | Property | Type | Access | Description | |----------|----------|------|--------|-------------| | **State** | IsReady | Boolean | Read-only | Whether WebView2 is ready | | | hWnd | LongPtr | Read-only | WebView2 child window handle | | | BrowserProcessId | Long | Read-only | Browser process ID | | | CanGoBack | Boolean | Read-only | Whether backward navigation is available | | | CanGoForward | Boolean | Read-only | Whether forward navigation is available | | | IsSuspended | Boolean | Read-only | Whether process is suspended | | | IsMuted | Boolean | Read-only | Whether page is muted | | | IsDocumentPlayingAudio | Boolean | Read-only | Whether page is playing audio | | | IsDefaultDownloadDialogOpen | Boolean | Read-only | Whether download dialog is open | | **Document** | DocumentURL | String | Read-only | Current document URL | | | DocumentTitle | String | Read-only | Current document title | | | ZoomFactor | Double | Read/Write | Zoom factor | | **Settings** | IsScriptEnabled | Boolean | Read/Write | Whether JavaScript is enabled | | | AreDevToolsEnabled | Boolean | Read/Write | Whether DevTools is enabled | | | IsStatusBarEnabled | Boolean | Read/Write | Whether status bar is visible | | | IsZoomControlEnabled | Boolean | Read/Write | Whether user zoom is allowed | | | AreDefaultContextMenusEnabled | Boolean | Read/Write | Whether context menus are enabled | | | UserAgent | String | Read/Write | Custom User-Agent | | | IsPinchZoomEnabled | Boolean | Read/Write | Whether pinch zoom is enabled | | | IsSwipeNavigationEnabled | Boolean | Read/Write | Whether swipe navigation is enabled | | | IsPasswordAutoSaveEnabled | Boolean | Read/Write | Whether password auto-save is enabled | | | IsGeneralAutoFillEnabled | Boolean | Read/Write | Whether auto-fill is enabled | | | AreBrowserAcceleratorKeysEnabled | Boolean | Read/Write | Whether browser accelerator keys are enabled | | **Feature Detection** | Supports\* (8) | Boolean | Read-only | Interface version support status | | **Sub-objects** | Cookies | cWebView2Cookies | Read-only | Cookie management object | | | Script | cWebView2Script | Read-only | Script execution object | | | Security | cWebView2Security | Read-only | Security management object | | | EnvironmentOptions | cWebView2EnvironmentOptions | Read-only | Environment options object | | **Adapter** | HostAdapterName | String | Read-only | Current host adapter name | | **Mouse Events** | EnableUserMouseEvents | Boolean | Read/Write | Whether content area mouse events are enabled | | | EnableUserMouseMove | Boolean | Read/Write | Whether mousemove events are enabled | | | EnableMouseMoveEvents | Boolean | Read/Write | Whether host mousemove events are enabled | *** ## 📊 State Properties ### IsReady Whether the WebView2 control is fully ready and can accept API calls. **Type**: `Boolean`\ **Access**: Read-only **Example**: ```vb If wv.IsReady Then wv.Navigate "https://example.com" End If ``` *** ### hWnd The handle of the WebView2 child window (Chrome\_WidgetWin\_0). **Type**: `LongPtr`\ **Access**: Read-only *** ### BrowserProcessId The ID of the browser rendering process. **Type**: `Long`\ **Access**: Read-only *** ### CanGoBack / CanGoForward Whether backward/forward navigation is available. **Type**: `Boolean`\ **Access**: Read-only **Example**: ```vb If wv.CanGoBack Then wv.GoBack ``` *** ### IsSuspended Whether the WebView2 rendering process is suspended. **Type**: `Boolean`\ **Access**: Read-only *** ### IsMuted Whether page audio is muted. **Type**: `Boolean`\ **Access**: Read-only *** ### IsDocumentPlayingAudio Whether the current page is playing audio. **Type**: `Boolean`\ **Access**: Read-only *** ### IsDefaultDownloadDialogOpen Whether the default download dialog is open. **Type**: `Boolean`\ **Access**: Read-only *** ## 📝 Document Properties ### DocumentURL The URL of the current document. **Type**: `String`\ **Access**: Read-only **Example**: ```vb Debug.Print "Current URL: " & wv.DocumentURL ``` *** ### DocumentTitle The title of the current document. **Type**: `String`\ **Access**: Read-only **Note**: Typically read in the `DocumentTitleChanged` event to update the form caption. **Example**: ```vb Private Sub wv_DocumentTitleChanged() Me.Caption = wv.DocumentTitle End Sub ``` *** ### ZoomFactor Page zoom factor. **Type**: `Double`\ **Access**: Read/Write **Note**: Default value is 1.0. Setting to 0.5 means 50%, 2.0 means 200%. **Example**: ```vb wv.ZoomFactor = 1.5 ' 150% zoom Debug.Print "Current zoom: " & wv.ZoomFactor ``` *** ## ⚙️ Settings Properties ### IsScriptEnabled Whether JavaScript execution is enabled. **Type**: `Boolean`\ **Access**: Read/Write\ **Default**: `True` **Note**: When disabled, all JavaScript on the page will not execute. *** ### AreDevToolsEnabled Whether users can open DevTools (F12). **Type**: `Boolean`\ **Access**: Read/Write\ **Default**: `True` **Note**: Set to False in production to prevent users from debugging pages. *** ### IsStatusBarEnabled Whether the browser status bar is visible. **Type**: `Boolean`\ **Access**: Read/Write\ **Default**: `False` *** ### IsZoomControlEnabled Whether users can zoom the page via Ctrl+scroll wheel, etc. **Type**: `Boolean`\ **Access**: Read/Write\ **Default**: `True` *** ### AreDefaultContextMenusEnabled Whether WebView2's default right-click context menu is enabled. **Type**: `Boolean`\ **Access**: Read/Write\ **Default**: `True` **Note**: Set to False if you handle the context menu yourself. *** ### UserAgent Custom User-Agent string. **Type**: `String`\ **Access**: Read/Write **Note**: Once set, all subsequent requests will use this User-Agent. Set to empty string to restore default. **Example**: ```vb wv.UserAgent = "Mozilla/5.0 (Custom App)" ``` *** ### IsPinchZoomEnabled Whether touchscreen pinch zoom is enabled. **Type**: `Boolean`\ **Access**: Read/Write\ **Default**: `True` *** ### IsSwipeNavigationEnabled Whether touchscreen swipe navigation (forward/backward) is enabled. **Type**: `Boolean`\ **Access**: Read/Write\ **Default**: `True` *** ### IsPasswordAutoSaveEnabled Whether password auto-save prompts are enabled. **Type**: `Boolean`\ **Access**: Read/Write\ **Default**: `False` *** ### IsGeneralAutoFillEnabled Whether form auto-fill is enabled. **Type**: `Boolean`\ **Access**: Read/Write\ **Default**: `False` *** ### AreBrowserAcceleratorKeysEnabled Whether browser accelerator keys (e.g., Ctrl+F search, Ctrl+P print) are enabled. **Type**: `Boolean`\ **Access**: Read/Write\ **Default**: `True` **Note**: Set to False if you don't want users to trigger browser built-in features via keyboard shortcuts. *** ## 🔍 Feature Detection Properties 8 `Supports*` read-only properties for detecting whether the current WebView2 Runtime supports specific version interfaces: | Property | Corresponding Interface | Description | |----------|------------------------|-------------| | `SupportsWebView2` | ICoreWebView2 | Base interface (always True) | | `SupportsWebView3` | ICoreWebView2\_3 | DOMContentLoaded, etc. | | `SupportsWebView4` | ICoreWebView2\_4 | Suspend/Resume | | `SupportsWebView5` | ICoreWebView2\_5 | Folder mapping | | `SupportsWebView6` | ICoreWebView2\_6 | DownloadStarting | | `SupportsWebView7` | ICoreWebView2\_7 | PrintToPdf | | `SupportsWebView8` | ICoreWebView2\_8 | Audio | | `SupportsWebView9` | ICoreWebView2\_9 | DownloadDialog | **Type**: `Boolean`\ **Access**: Read-only **Example**: ```vb If wv.SupportsWebView5 Then wv.SetVirtualHostNameToFolderMapping "myapp.local", App.Path & "\www" End If ``` *** ## 🔗 Sub-Object Properties ### Cookies Cookie management business object. **Type**: `cWebView2Cookies`\ **Access**: Read-only **Note**: Provides `GetCookies` and `GetCookiesFull` methods. **Example**: ```vb Dim simple As String simple = wv.Cookies.GetCookies ' Simple cookie list Dim full As String full = wv.Cookies.GetCookiesFull ' Full cookie details (including HttpOnly) ``` *** ### Script Script execution business object. **Type**: `cWebView2Script`\ **Access**: Read-only **Note**: Provides the `Eval` method for synchronous JavaScript expression evaluation. **Example**: ```vb Dim html As String html = wv.Script.Eval("return document.querySelector('.title').innerHTML") ``` *** ### Security Security/certificate management business object. **Type**: `cWebView2Security`\ **Access**: Read-only **Note**: Provides the `CertificateErrorAction` property to control certificate error handling behavior. **Must be set before Initialize takes effect.** **Example**: ```vb ' Must be configured in the wv_Create event Private Sub wv_Create() wv.Security.CertificateErrorAction = CEA_AlwaysAllow End Sub ``` *** ### EnvironmentOptions WebView2 environment options object. **Type**: `cWebView2EnvironmentOptions`\ **Access**: Read-only **Properties**: | Sub-property | Type | Description | |-------------|------|-------------| | `BrowserExecutableFolder` | String | Browser executable folder | | `UserDataFolder` | String | User data folder path | | `AdditionalBrowserArguments` | String | Additional browser command-line arguments | | `Language` | String | Browser language | | `TargetCompatibleBrowserVersion` | String | Target compatible browser version | | `AllowSingleSignOnUsingOSPrimaryAccount` | Boolean | Whether to allow OS primary account SSO | | `ExclusiveUserDataFolderAccess` | Boolean | Whether to exclusively access the user data folder | | `EnableTrackingPrevention` | Boolean | Whether to enable tracking prevention | **Note**: `UserDataFolder` and `AdditionalBrowserArguments` must be set in the `wv_Create` event. **Example**: ```vb Private Sub wv_Create() wv.EnvironmentOptions.UserDataFolder = App.Path & "\UserDir\account-001" End Sub ``` *** ## 🖥️ Adapter Properties ### HostAdapterName The name of the currently used host adapter. **Type**: `String`\ **Access**: Read-only **Values**: * `"HostSubclassAdapter"` - Subclassing adapter (VB6/Excel) * `"MessageWindowAdapter"` - Message window adapter (Access) **Example**: ```vb Debug.Print "Adapter: " & wv.HostAdapterName ``` *** ## 🖱️ Mouse Event Properties ### EnableUserMouseEvents Whether to enable content area user mouse events (UserMouse\* events triggered via JS proxy). **Type**: `Boolean`\ **Access**: Read/Write\ **Default**: `False` **Note**: When enabled, mouse events in the WebView2 content area are synchronously called back to the host via the `mouseProxy` COM object, triggering `UserMouseDown`, `UserMouseUp`, `UserMouseMove`, `UserMouseWheel`, `UserContextMenu`, `UserDblClick` events. *** ### EnableUserMouseMove Whether to enable content area mousemove events (only effective when EnableUserMouseEvents is True). **Type**: `Boolean`\ **Access**: Read/Write\ **Default**: `False` **Note**: mousemove events fire at extremely high frequency and are disabled by default to avoid performance issues. Enable only when needed (e.g., drag operations). *** ### EnableMouseMoveEvents Whether to enable host window mousemove events (HostMouseMove). **Type**: `Boolean`\ **Access**: Read/Write\ **Default**: `False` **Note**: Host mouse move events fire at extremely high frequency and are disabled by default to avoid performance issues. *** **Last Updated**: 2026-06-24 --- --- url: /en/vbman2/webview2/usage-timing.md --- # cWebView2Host Property & Method Usage Timing Reference > Different APIs have different availability timings within the WebView2 lifecycle. This document categorizes all properties and methods by **earliest available timing**, helping developers avoid calling them at incorrect stages where they may fail or have no effect. ## Lifecycle Stage Overview The WebView2 complete lifecycle includes an **Initialization Phase** and a **Runtime Phase**, with all events as follows: ### Initialization Phase (one-time, sequential) ``` User calls Initialize() ↓ ① Create event ─── Configure EnvironmentOptions / Security (only available in this event) ↓ ② Internally creates Environment (reads EnvironmentOptions configuration) ↓ ③ Internally creates Controller + CoreWebView (reads Settings configuration) ↓ ④ Ready event ─── Control fully ready, all APIs become available ↓ ⑤ First Navigate (if InitialURL is specified) ``` ### Runtime Phase (triggered per navigation cycle) ``` Navigate / NavigateCustom / NavigateToString / GoBack / GoForward / Reload ↓ ⑥ NavigationStarting ─── Can Cancel to block navigation ↓ ⑦ SourceChanged ─── URL change (IsNewDocument indicates new page) ↓ ┌─ ContentLoading (internal event, not exposed) │ ⑧ DOMContentLoaded ─── DOM ready, can BindUI / BindData / execute JS ↓ │ ⑨ DocumentTitleChanged ─── Title change │ ⑩ NavigationComplete ─── Page fully loaded (including images and other resources) └────────────────────────────────────────┘ Each navigation re-triggers ⑥→⑩ ``` ### Runtime Phase (interaction events that may fire at any time) ``` ┌─ Permissions/Dialogs ───────────────────────────────┐ │ PermissionRequested Page requests permission (geo/camera etc.)│ │ ScriptDialogOpening JS dialogs (alert/confirm) │ │ NewWindowRequested Page requests new window │ │ AcceleratorKeyPressed Shortcut key pressed │ └──────────────────────────────────────────────────────┘ ┌─ Resources/Downloads ───────────────────────────────┐ │ WebResourceRequested Resource request intercepted (must register first) │ │ DownloadStarting Download about to start (can Cancel) │ │ ProcessFailed Browser process crashed │ └──────────────────────────────────────────────────────┘ ┌─ Script Callbacks ──────────────────────────────────┐ │ JsAsyncResult Async JS execution complete │ │ JsMessage JS postMessage to host │ │ DevToolsProtocolResponse CDP async response │ └──────────────────────────────────────────────────────┘ ┌─ Host Interaction ──────────────────────────────────┐ │ HostMouseDown/Up/DblClick/Move/Wheel/ContextMenu│ │ HostKeyDown/Up/Press Keyboard events │ │ HostFocus / HostBlur Focus in/out │ │ HostResize Host window size change │ └──────────────────────────────────────────────────────┘ ┌─ Content Area Mouse (requires EnableUserMouseEvents=True)────┐ │ UserMouseDown/Up/Move/Wheel/ContextMenu/DblClick│ └──────────────────────────────────────────────────────┘ ┌─ Async Operation Callbacks ──────────────────────────┐ │ SuspendCompleted / SuspendFailed │ │ PrintToPdfCompleted / PrintToPdfFailed │ │ OnGetCookiesFull │ └──────────────────────────────────────────────────────┘ ┌─ Errors ─────────────────────────────────────────────┐ │ Error Creation/runtime error │ └──────────────────────────────────────────────────────┘ ``` ### Stage & API Availability Reference | Stage | Timing | What you can do | |-------|--------|-----------------| | **Before Initialize call** | Object just created | Only set EnvironmentOptions sub-properties | | **Create event** | Before Environment creation | Set EnvironmentOptions, Security configuration | | **Ready event** | Control fully ready | Navigate, register bindings, inject scripts, set runtime properties | | **DOMContentLoaded** | DOM ready | BindUI, BindData, execute JS (ensure elements exist) | | **NavigationComplete** | Page fully loaded | All runtime APIs unrestricted | | **Any time at runtime** | After Ready | All APIs unrestricted | *** ## Property Usage Timing Overview ### 🔴 Only in Create Event (pre-creation configuration) These properties affect WebView2 Environment creation parameters and **must be set in the `wv_Create` event**. Changes after this have no effect. | Property | Sub-property | Description | |----------|-------------|-------------| | **EnvironmentOptions** | `UserDataFolder` | User data directory, read when Environment is created, changes afterwards have no effect | | | `BrowserExecutableFolder` | Browser executable folder | | | `AdditionalBrowserArguments` | Additional command-line arguments (e.g., `--ignore-certificate-errors`) | | | `Language` | Browser default language | | | `TargetCompatibleBrowserVersion` | Target compatible version | | | `AllowSingleSignOnUsingOSPrimaryAccount` | SSO configuration | | | `ExclusiveUserDataFolderAccess` | Exclusive data folder | | | `EnableTrackingPrevention` | Tracking prevention | | **Security** | `CertificateErrorAction` | Certificate error handling policy, must be set before Create | **Example**: ```vb Private Sub wv_Create() ' ★ These can ONLY be set in the Create event! wv.EnvironmentOptions.UserDataFolder = App.Path & "\UserDir\account-001" wv.EnvironmentOptions.AdditionalBrowserArguments = "--ignore-certificate-errors" wv.Security.CertificateErrorAction = CEA_AlwaysAllow End Sub ``` ### 🟡 Available from Ready Event (runtime settings) These properties require the CoreWebView2 Controller/Settings object to be created and **can be set from the `wv_Ready` event onwards**. Setting them in the Create event may have no effect (the underlying Settings object has not been created yet). | Property | Description | Note | |----------|-------------|------| | **IsPasswordAutoSaveEnabled** | Password auto-save | Default False, only effective after Ready | | **IsGeneralAutoFillEnabled** | Form auto-fill | Default False, only effective after Ready | | **IsScriptEnabled** | JS execution toggle | Default True | | **AreDevToolsEnabled** | DevTools toggle | Default True, recommended off for production | | **IsStatusBarEnabled** | Status bar display | Default False | | **IsZoomControlEnabled** | User zoom control | Default True | | **AreDefaultContextMenusEnabled** | Right-click menus | Default True | | **UserAgent** | Custom UA | Takes effect for subsequent requests after setting | | **IsPinchZoomEnabled** | Pinch zoom | Default True | | **IsSwipeNavigationEnabled** | Swipe navigation | Default True | | **AreBrowserAcceleratorKeysEnabled** | Browser shortcut keys | Default True | | **ZoomFactor** | Zoom factor | Default 1.0, requires page loaded | | **EnableUserMouseEvents** | Content area mouse events | Default False, set after Ready and auto-injects proxy | | **EnableUserMouseMove** | Content area mousemove | Requires EnableUserMouseEvents to be True | | **EnableMouseMoveEvents** | Host mousemove | Default False | **Example**: ```vb Private Sub wv_Ready() ' ★ Runtime property settings wv.IsPasswordAutoSaveEnabled = True wv.IsGeneralAutoFillEnabled = True wv.AreDevToolsEnabled = False ' Disable DevTools in production wv.UserAgent = "Mozilla/5.0 (MyApp)" ' Enable mouse event proxy wv.EnableUserMouseEvents = True End Sub ``` ### 🟢 Available any time (read-only state) These properties are read-only and can be read at any time, but only have valid values after Ready. | Property | Description | Value before Ready | |----------|-------------|-------------------| | **IsReady** | Whether ready | False → True | | **hWnd** | Child window handle | 0 → Valid handle | | **BrowserProcessId** | Process ID | 0 → Valid ID | | **CanGoBack** | Can go back | False | | **CanGoForward** | Can go forward | False | | **IsSuspended** | Whether suspended | False | | **IsMuted** | Whether muted | False | | **IsDocumentPlayingAudio** | Playing audio | False | | **IsDefaultDownloadDialogOpen** | Download dialog | False | | **DocumentURL** | Current URL | "" → Valid URL | | **DocumentTitle** | Current title | "" → Valid title | | **SupportsWebView2~9** | Feature detection | Accurate values only after Ready | | **Cookies** | Cookie object | Available after Ready | | **Script** | Script object | Available after Ready | | **HostAdapterName** | Adapter name | Has value at Initialize time | *** ## Method Usage Timing Overview ### 🔴 Only in Create Event | Method | Description | |--------|-------------| | — | No methods are currently restricted to only the Create event | > Note: Although some methods can be called in the Create event, the underlying CoreWebView object has not been created yet, and most methods will silently fail (protected by `If m_Core Is Nothing Then Exit Sub`). The sole purpose of the Create event is to configure **EnvironmentOptions** and **Security**. ### 🟡 Available from Ready Event These methods require the CoreWebView object to be created and **can only be called from the `wv_Ready` event onwards**: | Method | Description | Note | |--------|-------------|------| | **Navigate** | Navigate to URL | Call after Ready, calling in Create has no effect | | **NavigateCustom** | Custom request navigation | Same as above | | **NavigateToString** | Load HTML string | Same as above | | **GoBack / GoForward / Reload** | Navigation control | Requires navigation history | | **ExecuteScript** | Async execute JS | Requires page loaded | | **JsRun** | Sync call JS | Requires page loaded | | **JsRunAsync** | Async call JS | Requires page loaded | | **JsProp** | Read JS property | Requires page loaded | | **PostWebMessage** | Send string message | Requires page loaded | | **PostWebMessageJSON** | Send JSON message | Requires page loaded | | **AddObject** | Inject COM object | Inject after Ready, page JS can access | | **RemoveObject** | Remove COM object | | | **AddScriptToExecuteOnDocumentCreated** | Inject script | Inject after Ready, subsequent pages execute | | **AddWebResourceRequestedFilter** | Add resource filter | Register after Ready to take effect | | **RemoveWebResourceRequestedFilter** | Remove filter | | | **SetVirtualHostNameToFolderMapping** | Virtual host mapping | Set after Ready, then Navigate | | **ClearVirtualHostNameToFolderMapping** | Clear mapping | | | **PrintToPdf** | Print to PDF | Requires page loaded | | **Suspend / Resume** | Suspend/Resume | | | **OpenDevToolsWindow** | Open DevTools | | | **CallDevToolsProtocolMethod** | Async CDP | | | **CallDevToolsProtocolMethodSync** | Sync CDP | | | **OpenDefaultDownloadDialog** | Open download dialog | | | **CloseDefaultDownloadDialog** | Close download dialog | | | **OpenTaskManagerWindow** | Task manager | | | **Resize** | Resize | | | **SetFocus** | Set focus | | | **BindUI** | DOM event binding | Requires page DOM to exist | | **UnbindUI** | Remove event binding | | | **BindData** | Data binding | Requires page DOM to exist | | **UnbindData** | Remove data binding | | | **SetData** | Push data | Requires BindData already done | | **SetDataBatch** | Batch push | Requires BindData already done | ### 🟢 Available any time (but recommended after Ready) | Method | Description | |--------|-------------| | **Initialize** | Initialize control, the starting point | | **Cleanup** | Clean up resources, can be called anytime | ### 🔵 Recommended after DOMContentLoaded The following methods depend on the page DOM being rendered. It is recommended to call them after the `wv_DOMContentLoaded` or `wv_NavigationComplete` event: | Method | Description | Reason | |--------|-------------|--------| | **BindUI** | DOM event binding | Requires elements already in DOM | | **BindData** | Data binding | Requires elements already in DOM | | **SetData / SetDataBatch** | Push data | Requires BindData completed | | **JsRun / JsProp** | Sync JS calls | Requires JS environment ready | | **Script.Eval** | Sync execute JS | Requires page JS executable | **Best Practice**: ```vb Private Sub wv_DOMContentLoaded() ' ★ Bind UI and data after DOM is ready wv.BindData "name", "#name-input", "value" wv.BindData "name", "#name-preview", "textContent" wv.BindUI Me, "OnNameInput", "#name-input", EventName:="input" wv.SetData "name", "Initial value" End Sub ``` *** ## ⚠️ Common Error Scenarios | Wrong approach | Problem | Correct approach | |----------------|---------|-----------------| | Setting `EnvironmentOptions.UserDataFolder` in Form\_Load | Initialize internally overwrites defaults, but user settings before Create are preserved | Set in `wv_Create` event | | Calling `Navigate` in Create event | CoreWebView not yet created, silently fails | Navigate in `wv_Ready` event | | Calling `AddObject` before Ready | Underlying CoreWebView is Nothing | AddObject in `wv_Ready` event | | Calling `BindData` in NavigationStarting | DOM may not yet be loaded | BindData in `wv_DOMContentLoaded` | | Setting `IsPasswordAutoSaveEnabled` in Create | Settings4 object not yet created, may have no effect | Set after `wv_Ready` | *** ## 🗺️ Quick Decision Flowchart ``` Need to configure EnvironmentOptions or Security? → ★ wv_Create event Need to set runtime properties (IsPasswordAutoSaveEnabled etc.)? → ★ From wv_Ready event onwards Need to navigate, inject scripts, register filters? → ★ From wv_Ready event onwards Need to bind UI/data, execute JS? → ★ From wv_DOMContentLoaded event onwards (ensure DOM is ready) Need to read state (URL, title, etc.)? → ★ Any time (but valid values only after Ready) ``` *** **Last Updated**: 2026-06-26 --- --- url: /zh/vbman/winsock/encoding.md --- # cWinsock 编码指南 ## 📖 目录 * [概述](#概述) * [编码类型](#编码类型) * [默认编码](#默认编码) * [编码选择建议](#编码选择建议) * [常见问题](#常见问题) *** ## 概述 `cWinsock` 支持多种文本编码方式，以适应不同的应用场景。正确使用编码对于确保数据传输的准确性和兼容性至关重要。 *** ## 编码类型 ### 🇨🇳 ScpAcp (ACP/GBK) **值**: `0` **说明**: 系统默认代码页（ANSI Code Page） **特点**: * 中文 Windows 上通常为 GBK 编码 * 与 VB6 内部字符串存储方式一致 * 单字节字符 1 字节，中文字符 2 字节 * 适合中文环境下的本地应用 **使用场景**: * 传统 VB6 应用 * 中文字符为主的应用 * 与现有 VB6 系统兼容 **示例**: ```vb ' 默认使用 ACP/GBK 编码 m_oClient.SendData "中文测试" m_oClient.GetData sData ``` *** ### 🌐 ScpUtf8 (UTF-8) **值**: `65001` **说明**: UTF-8 编码 **特点**: * 国际标准，支持所有 Unicode 字符 * 兼容 ASCII * 单字节字符 1 字节，中文字符 3 字节 * 网络传输的首选编码 **使用场景**: * Web 应用 * 国际化应用 * 与现代系统交互 * 需要支持多语言 **示例**: ```vb ' 使用 UTF-8 编码 m_oClient.SendData "中文测试", ScpUtf8 m_oClient.GetData sData, , , ScpUtf8 ``` *** ### 🌟 ScpUnicode (Unicode) **值**: `-1` **说明**: Unicode 编码（不进行转换） **特点**: * 保持字符串为宽字符（UTF-16） * 不进行编码转换 * 每个字符 2 字节（大部分字符） **使用场景**: * 内部数据传输 * 需要保持原始字符串格式 * 不想进行编码转换 **示例**: ```vb ' 使用 Unicode（不转换） m_oClient.SendData "中文测试", ScpUnicode m_oClient.GetData sData, , , ScpUnicode ``` *** ## 默认编码 ### SendData 默认编码 ```vb Public Sub SendData(Data As Variant, Optional ByVal CodePage As EnumScpCodePage = ScpAcp) ``` **默认值**: `ScpAcp` (0) - ACP/GBK ### GetData/PeekData 默认编码 ```vb Public Sub GetData(Data As Variant, Optional ByVal VarType_ As Long, Optional ByVal MaxLen As Long = -1, Optional ByVal CodePage As EnumScpCodePage = ScpAcp) Public Sub PeekData(Data As Variant, Optional ByVal VarType_ As Long, Optional ByVal MaxLen As Long = -1, Optional ByVal CodePage As EnumScpCodePage = ScpAcp) ``` **默认值**: `ScpAcp` (0) - ACP/GBK ### 设计原因 * 与 VB6 传统编码方式一致 * 与大多数 VB6 应用兼容 * 避免编码不一致导致的乱码问题 *** ## 编码选择建议 ### 🎯 场景 1: 新建网络应用 **建议**: 使用 UTF-8 ```vb ' 发送 m_oClient.SendData "Hello 世界", ScpUtf8 ' 接收 Private Sub m_oClient_DataArrival(Client As cWinsock, ByVal bytesTotal As Long) Dim sData As String Client.GetData sData, , , ScpUtf8 Debug.Print sData ' "Hello 世界" End Sub ``` **优点**: * 国际化支持 * 与现代系统兼容 * Web 标准编码 *** ### 🏢 场景 2: 传统 VB6 应用 **建议**: 使用默认 ACP/GBK ```vb ' 发送（默认 ACP） m_oClient.SendData "中文测试" ' 接收（默认 ACP） Private Sub m_oClient_DataArrival(Client As cWinsock, ByVal bytesTotal As Long) Dim sData As String Client.GetData sData Debug.Print sData ' "中文测试" End Sub ``` **优点**: * 与 VB6 内部编码一致 * 无需额外编码设置 * 与现有代码兼容 *** ### 🌍 场景 3: 混合编码环境 **建议**: 根据对方编码动态选择 ```vb ' 发送前检测对方编码 Private Sub SendDataAdaptive(ByVal sText As String) If m_oRemoteEncoding = "UTF8" Then m_oClient.SendData sText, ScpUtf8 Else m_oClient.SendData sText, ScpAcp End If End Sub ' 接收时检测编码 Private Sub m_oClient_DataArrival(Client As cWinsock, ByVal bytesTotal As Long) Dim sData As String If m_oRemoteEncoding = "UTF8" Then Client.GetData sData, , , ScpUtf8 Else Client.GetData sData End If ProcessData sData End Sub ``` *** ### 🔧 场景 4: 协议协商编码 **建议**: 在连接建立时协商编码 ```vb ' 连接成功后发送编码协商 Private Sub m_oClient_Connect(Client As cWinsock) ' 发送支持的编码列表 Client.SendData "ENCODING:SUPPORT:ACP,UTF8", ScpUtf8 End Sub ' 服务器响应 Private Sub m_oServer_DataArrival(Client As cWinsock, ByVal bytesTotal As Long) Dim sData As String Client.GetData sData, , , ScpUtf8 If Left$(sData, 21) = "ENCODING:SUPPORT:" Then ' 选择编码 Dim sEncodings() As String sEncodings = Split(Mid$(sData, 22), ",") ' 优先选择 UTF-8 Dim sSelected As String If InStr("UTF8", sEncodings(0)) > 0 Then sSelected = "UTF8" Else sSelected = "ACP" End If ' 响应选择的编码 Client.SendData "ENCODING:SELECT:" & sSelected, ScpUtf8 ' 保存客户端使用的编码 Client.UserData = sSelected End If End Sub ``` *** ## 常见问题 ### ❓ 问题 1: 中文乱码 **现象**: 接收到的中文显示为乱码 **原因**: 发送和接收使用了不同的编码 **解决方案**: ```vb ' ✅ 正确：发送和接收使用相同编码 m_oClient.SendData "中文测试", ScpUtf8 ' 接收时 Client.GetData sData, , , ScpUtf8 ' ❌ 错误：编码不一致 m_oClient.SendData "中文测试", ScpUtf8 ' 使用 UTF-8 ' 接收时 Client.GetData sData ' 使用默认 ACP → 乱码 ``` *** ### ❓ 问题 2: UTF-8 字节长度错误 **现象**: 统计字节数时与预期不符 **原因**: UTF-8 是变长编码，中文字符占用 3 字节 **解决方案**: ```vb ' 计算实际字节数 Function GetByteCount(ByVal sText As String, ByVal eCodePage As EnumScpCodePage) As Long Dim oSocket As New cAsyncSocket Dim baData() As Byte baData = oSocket.ToTextArray(sText, eCodePage) GetByteCount = UBound(baData) + 1 End Function ' 使用 Dim lLen As Long lLen = GetByteCount("中文测试", ScpUtf8) Debug.Print lLen ' 12 (每个中文字符 3 字节) ``` *** ### ❓ 问题 3: 与 Web 服务器通信 **现象**: Web 服务器返回的内容显示不正确 **原因**: Web 服务器通常使用 UTF-8，但客户端使用了默认编码 **解决方案**: ```vb ' 发送 HTTP 请求（使用 UTF-8） m_oClient.SendData "GET / HTTP/1.1" & vbCrLf & "Host: example.com" & vbCrLf & vbCrLf, ScpUtf8 ' 接收响应（使用 UTF-8） Private Sub m_oClient_DataArrival(Client As cWinsock, ByVal bytesTotal As Long) Dim sData As String Client.GetData sData, , , ScpUtf8 ' 解析响应 Debug.Print sData End Sub ``` *** ### ❓ 问题 4: 数据库编码冲突 **现象**: 从数据库读取的字符串通过网络传输后显示异常 **原因**: 数据库编码与网络传输编码不一致 **解决方案**: ```vb ' 从数据库读取（假设数据库使用 UTF-8） Dim sData As String sData = GetFromDatabase() ' 直接发送（数据库已经是 UTF-8） ' 不需要转换 m_oClient.SendData sData, ScpUtf8 ' 或者转换为 ACP 再发送 Dim baUtf8() As Byte Dim sAcp As String ' 先转 UTF-8 字节数组 baUtf8 = ConvertToUtf8Bytes(sData) ' 再转为 ACP 字符串 sAcp = ConvertFromUtf8Bytes(baUtf8) m_oClient.SendData sAcp ``` *** ### ❓ 问题 5: 文件传输编码 **现象**: 传输文本文件后内容乱码 **原因**: 文件编码与网络传输编码不一致 **解决方案**: ```vb ' 读取文本文件 Private Function ReadFile(ByVal sFilePath As String, ByVal eCodePage As EnumScpCodePage) As String Dim iFileNum As Integer iFileNum = FreeFile Open sFilePath For Binary As #iFileNum Dim baData() As Byte ReDim baData(0 To LOF(iFileNum) - 1) As Byte Get #iFileNum, , baData Close #iFileNum Dim oSocket As New cAsyncSocket ReadFile = oSocket.FromTextArray(baData, eCodePage) End Function ' 发送文件 Private Sub SendFile(ByVal sFilePath As String) Dim sContent As String ' 假设文件是 UTF-8 编码 sContent = ReadFile(sFilePath, ScpUtf8) ' 使用 UTF-8 发送 m_oClient.SendData sContent, ScpUtf8 End Sub ``` *** ## 编码转换工具函数 ### 编码检测 ```vb ' 简单的 UTF-8 检测 Function IsLikelyUtf8(ByVal sText As String) As Boolean ' 检查是否包含高字节字符 Dim i As Long For i = 1 To Len(sText) If AscW(Mid$(sText, i, 1)) > 255 Then IsLikelyUtf8 = True Exit Function End If Next IsLikelyUtf8 = False End Function ``` ### 编码转换 ```vb ' ACP 转换为 UTF-8 Function AcpToUtf8(ByVal sText As String) As String Dim oSocket As New cAsyncSocket Dim baAcp() As Byte Dim baUtf8() As Byte ' ACP → 字节数组 baAcp = oSocket.ToTextArray(sText, ScpAcp) ' 字节数组 → UTF-8 字符串（这里需要额外处理） ' VB6 中需要使用 Win32 API 进行转换 ' 这里简化演示 AcpToUtf8 = sText ' 实际实现需要调用 MultiByteToWideChar End Function ``` *** ## 最佳实践 ### ✅ 推荐做法 1. **统一编码**: 发送和接收使用相同编码 2. **明确指定**: 始终显式指定编码参数，不依赖默认值 3. **文档记录**: 记录每个连接使用的编码 4. **编码协商**: 在协议层面协商编码 5. **错误处理**: 处理编码转换错误 ```vb ' 示例：封装的网络类 Public Sub SendText(ByVal oSocket As cWinsock, ByVal sText As String) On Error GoTo EH ' 使用配置的编码 Select Case m_eEncoding Case eEncoding.UTF8 oSocket.SendData sText, ScpUtf8 Case eEncoding.ACP oSocket.SendData sText, ScpAcp Case eEncoding.Unicode oSocket.SendData sText, ScpUnicode End Select Exit Sub EH: Debug.Print "发送数据失败: " & Err.Description End Sub ``` ### ❌ 避免的做法 1. **混合编码**: 同一连接使用不同编码 2. **依赖默认**: 不指定编码参数，依赖默认值 3. **忽略检测**: 不检测对方使用的编码 4. **盲目转换**: 不验证就直接转换编码 *** **最后更新**: 2026-01-09 --- --- url: /zh/vbman/winsock/methods.md --- # cWinsock 方法参考 ## 📋 方法列表 | 方法名 | 返回类型 | 说明 | |--------|----------|------| | `Connect` | Sub | 连接到远程服务器 | | `Listen` | Sub | 开始监听端口 | | `Bind` | Sub | 绑定本地端口（UDP） | | `SendData` | Sub | 发送数据（协议模式下自动封包） | | `GetData` | Sub | 接收数据 | | `GetDataText` | String | 获取数据为文本（ACP/GBK） | | `GetDataTextUTF8` | String | 获取数据为 UTF-8 文本 | | `GetDataTextUnicode` | String | 获取数据为 Unicode 文本 | | `GetDataHex` | String | 获取数据为十六进制字符串 | | `GetDataByteArray` | Byte() | 获取数据为字节数组 | | `GetDataToString` | String | 获取数据为文本（兼容旧版） | | `PeekData` | Sub | 查看数据但不移除 | | `Close_` | Sub | 关闭连接 | | `GetErrorDescription` | String | 获取错误描述 | | `BindUser` | Sub | 绑定用户到客户端（详见 [binding.md](./binding.md)） | | `ExistsUser` | Boolean | 检查用户是否存在（详见 [binding.md](./binding.md)） | | `UnbindUser` | Sub | 解绑用户（详见 [binding.md](./binding.md)） | | `SendToUser` | Sub | 向指定用户发送数据（详见 [binding.md](./binding.md)） | | `BindGroup` | Sub | 绑定用户到组（详见 [binding.md](./binding.md)） | | `ExistsGroup` | Boolean | 检查组是否存在（详见 [binding.md](./binding.md)） | | `UnbindGroup` | Sub | 从组中解绑用户（详见 [binding.md](./binding.md)） | | `GetGroupMembers` | String() | 获取组成员列表（详见 [binding.md](./binding.md)） | | `SendToGroup` | Sub | 向组内所有成员发送数据（详见 [binding.md](./binding.md)） | | `GetUserGroups` | String() | 获取用户所属的所有组（详见 [binding.md](./binding.md)） | | `DeleteGroup` | Sub | 解散组（详见 [binding.md](./binding.md)） | | `CloseUser` | Sub | 下线指定用户（详见 [binding.md](./binding.md)） | | `AcceptFrom` | Sub | 接受连接（内部方法） | | `SetUdpClientInfo` | Sub | 设置 UDP 客户端信息（内部方法） | | `RemoveClient` | Sub | 移除客户端（内部方法） | | `RaiseDataArrivalEvent` | Sub | 触发数据到达事件（内部方法） | | `UnbindUserFromAllGroups` | Sub | 从所有组中解绑用户（内部方法） | *** ## 🔗 Connect 方法 ### 说明 连接到指定的远程服务器（TCP 客户端模式）。 ### 语法 ```vb Public Sub Connect(Optional RemoteHost As String, Optional ByVal RemotePort As Long) ``` ### 参数 | 参数 | 类型 | 说明 | |------|------|------| | `RemoteHost` | String（可选） | 远程主机名或 IP 地址。如果不提供，使用 `RemoteHost` 属性的值 | | `RemotePort` | Long（可选） | 远程端口号。如果不提供，使用 `RemotePort` 属性的值 | ### 使用示例 ```vb ' 使用参数连接 m_oClient.Connect "127.0.0.1", 8080 ' 使用属性连接 m_oClient.RemoteHost = "example.com" m_oClient.RemotePort = 80 m_oClient.Connect ' 连接到特定主机 m_oClient.RemoteHost = "192.168.1.100" m_oClient.Connect , 8080 ' 只指定端口，使用已设置的 RemoteHost ``` ### 连接流程 ``` 1. 调用 Connect() 2. 关闭现有连接（如果有） 3. 解析主机名 → sckResolvingHost 4. 主机名解析完成 → sckHostResolved 5. 开始连接 → sckConnecting 6. 连接成功 → sckConnected 7. 触发 Connect 事件 ``` ### 错误处理 ```vb Private Sub cmdConnect_Click() On Error GoTo EH m_oClient.Connect "example.com", 8080 Exit Sub EH: Debug.Print "连接错误: " & Err.Description Select Case Err.Number Case 10060 MsgBox "连接超时，请检查网络" Case 10061 MsgBox "服务器拒绝连接，请检查端口" Case Else MsgBox "连接失败: " & Err.Description End Select End Sub ``` *** ## 🎧 Listen 方法 ### 说明 开始监听指定端口，等待客户端连接（TCP 服务器模式）。 ### 语法 ```vb Public Sub Listen(Optional ByVal Port As Long) ``` ### 参数 | 参数 | 类型 | 说明 | |------|------|------| | `Port` | Long（可选） | 要监听的端口号。如果不提供，使用 `LocalPort` 属性的值 | ### 使用示例 ```vb ' 使用参数监听 m_oServer.Listen 8080 ' 使用属性监听 m_oServer.LocalPort = 8080 m_oServer.Listen ' 监听多个端口（需要多个 cWinsock 对象） Dim oServer1 As New cWinsock Dim oServer2 As New cWinsock oServer1.Listen 8080 oServer2.Listen 8081 ``` ### 服务器启动流程 ```vb Private Sub StartServer() On Error GoTo EH ' 设置协议 m_oServer.Protocol = sckTCPProtocol ' 开始监听 m_oServer.Listen 8080 Debug.Print "服务器已启动，监听端口: " & m_oServer.LocalPort ' 更新 UI btnStart.Enabled = False btnStop.Enabled = True lblStatus.Caption = "监听中..." Exit Sub EH: Debug.Print "启动服务器失败: " & Err.Description MsgBox "无法启动服务器: " & Err.Description, vbExclamation End Sub ``` ### ⚠️ 注意事项 * 调用 `Listen()` 前必须设置 `Protocol = sckTCPProtocol` * 端口必须未被占用 * `State` 将变为 `sckListening` *** ## 📌 Bind 方法 ### 说明 绑定本地端口（UDP 服务器模式）。 ### 语法 ```vb Public Sub Bind(Optional ByVal LocalPort As Long, Optional LocalIP As String) ``` ### 参数 | 参数 | 类型 | 说明 | |------|------|------| | `LocalPort` | Long（可选） | 要绑定的本地端口号 | | `LocalIP` | String（可选） | 要绑定的本地 IP 地址（可选） | ### 使用示例 ```vb ' 绑定端口 m_oUdp.Protocol = sckUDPProtocol m_oUdp.Bind 8888 ' 绑定到特定 IP m_oUdp.Bind 8888, "192.168.1.100" ``` ### UDP 服务器启动 ```vb Private Sub StartUdpServer() On Error GoTo EH ' 设置协议 m_oUdp.Protocol = sckUDPProtocol ' 绑定端口 m_oUdp.Bind 8888 Debug.Print "UDP 服务器已启动，绑定端口: " & m_oUdp.LocalPort Exit Sub EH: Debug.Print "UDP 绑定失败: " & Err.Description MsgBox "无法绑定 UDP 端口: " & Err.Description, vbExclamation End Sub ``` *** ## 📤 SendData 方法 ### 说明 发送数据到远程主机。当设置了 `PacketProtocol` 时，`SendData` 会自动调用协议的 `Encode` 方法进行封包，无需手动处理。 ### 语法 ```vb Public Sub SendData(Data As Variant, Optional ByVal CodePage As EnumScpCodePage = ScpAcp) ``` ### 参数 | 参数 | 类型 | 说明 | |------|------|------| | `Data` | Variant | 要发送的数据，可以是字符串或字节数组 | | `CodePage` | EnumScpCodePage（可选） | 文本编码，默认 `ScpAcp`（GBK/ACP） | ### 编码选项 | 常量 | 值 | 说明 | |------|-----|------| | `ScpAcp` | 0 | 系统默认代码页（中文 Windows 上为 GBK） | | `ScpOem` | 1 | OEM 代码页 | | `ScpUtf8` | 65001 | UTF-8 编码 | | `ScpUnicode` | -1 | Unicode，不进行编码转换 | ### 发送字符串 ```vb ' 默认使用 ACP/GBK 编码 m_oClient.SendData "中文测试" ' 使用 UTF-8 编码 m_oClient.SendData "中文测试", ScpUtf8 ' 使用 Unicode（不转换） m_oClient.SendData "中文测试", ScpUnicode ``` ### 发送字节数组 ```vb ' 发送字节数组 Dim baData() As Byte baData = GetBinaryData() m_oClient.SendData baData ``` ### UDP 服务器发送 ```vb ' UDP 服务器模式下，需要指定远程地址 Private Sub cmdUdpSend_Click() ' 设置目标 m_oUdp.RemoteHost = "127.0.0.1" m_oUdp.RemotePort = 9999 ' 发送数据 m_oUdp.SendData "Hello, UDP!" End Sub ' 向特定客户端回复（虚拟客户端） Private Sub m_oUdp_DataArrival(Client As cWinsock, ByVal bytesTotal As Long) Dim sData As String Client.GetData sData ' 直接通过 Client 对象回复 ' cWinsock 会自动使用正确的远程地址:端口 Client.SendData "Reply: " & sData ``` ### 协议模式自动封包 ```vb ' 设置分隔符协议后，SendData 自动追加分隔符 m_oServer.PacketProtocol = ppDelimiter m_oServer.Delimiter = vbCrLf ' 发送时自动封包（追加 vbCrLf） Client.SendData "Hello" ' 实际发送: "Hello" + vbCrLf ' 长度头协议也自动处理 m_oServer.PacketProtocol = ppLengthHeader Client.SendData "Hello" ' 实际发送: [4字节长度头] + "Hello" ' 字节数组同样自动封包 Dim baData() As Byte baData = GetBinaryData() Client.SendData baData ' 自动封包 ``` ### 大数据发送 ```vb ' 分块发送大数据 Private Sub SendLargeFile(ByVal sFilePath As String) Dim baChunk() As Byte Dim lChunkSize As Long lChunkSize = 8192 ' 8KB 每块 ' 打开文件... ' 循环读取并发送 Do While Not EOF ' 读取数据块 ReadChunk baChunk, lChunkSize ' 发送 m_oClient.SendData baChunk ' 等待发送完成（通过 SendComplete 事件） Do While m_bSending DoEvents Loop Loop End Sub ``` *** ## 📥 GetData 方法 ### 说明 从接收缓冲区读取数据。 ### 语法 ```vb Public Sub GetData(Data As Variant, Optional ByVal VarType_ As Long, Optional ByVal MaxLen As Long = -1, Optional ByVal CodePage As EnumScpCodePage = ScpAcp) ``` ### 参数 | 参数 | 类型 | 说明 | |------|------|------| | `Data` | Variant | 用于接收数据的变量 | | `VarType_` | Long（可选） | 期望的数据类型（如 `vbString`, `vbByte + vbArray`） | | `MaxLen` | Long（可选） | 最大读取字节数，-1 表示读取全部 | | `CodePage` | EnumScpCodePage（可选） | 文本编码，默认 `ScpAcp` | ### 读取字符串 ```vb Private Sub m_oClient_DataArrival(Client As cWinsock, ByVal bytesTotal As Long) Dim sData As String ' 读取所有数据 Client.GetData sData Debug.Print "收到: " & sData End Sub ``` ### 读取字节数组 ```vb Private Sub m_oClient_DataArrival(Client As cWinsock, ByVal bytesTotal As Long) Dim baData() As Byte ' 读取字节数组 Client.GetData baData Debug.Print "收到 " & bytesTotal & " 字节" End Sub ``` ### 部分读取 ```vb Private Sub m_oClient_DataArrival(Client As cWinsock, ByVal bytesTotal As Long) Dim sHeader As String Dim sBody As String ' 读取前 10 字节作为头部 Client.GetData sHeader, vbString, 10 Debug.Print "头部: " & sHeader ' 读取剩余数据 Client.GetData sBody Debug.Print "正文: " & sBody End Sub ``` ### 指定编码读取 ```vb Private Sub m_oClient_DataArrival(Client As cWinsock, ByVal bytesTotal As Long) Dim sData As String ' 使用 UTF-8 编码读取 Client.GetData sData, vbString, -1, ScpUtf8 Debug.Print "UTF-8 数据: " & sData End Sub ``` ### 协议解析 ```vb Private Type tPacketHeader Magic As Long ' 魔数 Length As Long ' 数据长度 Type As Long ' 数据类型 End Type Private Sub m_oServer_DataArrival(Client As cWinsock, ByVal bytesTotal As Long) Dim tHeader As tPacketHeader Dim baBody() As Byte ' 读取头部 Client.GetData tHeader ' 验证魔数 If tHeader.Magic = &H12345678 Then ' 读取数据体 ReDim baBody(0 To tHeader.Length - 1) As Byte Client.GetData baBody Debug.Print "数据类型: " & tHeader.Type Debug.Print "数据长度: " & tHeader.Length End If End Sub ``` *** ## 👁️ PeekData 方法 ### 说明 查看数据但不从缓冲区移除。 ### 语法 ```vb Public Sub PeekData(Data As Variant, Optional ByVal VarType_ As Long, Optional ByVal MaxLen As Long = -1, Optional ByVal CodePage As EnumScpCodePage = ScpAcp) ``` ### 参数 与 `GetData` 相同。 ### 使用示例 ```vb Private Sub m_oClient_DataArrival(Client As cWinsock, ByVal bytesTotal As Long) Dim sPeek As String Dim sActual As String ' 先查看数据 Client.PeekData sPeek Debug.Print "查看数据: " & sPeek ' 然后读取数据 Client.GetData sActual Debug.Print "实际数据: " & sActual End Sub ``` ### 协议检测 ```vb Private Sub m_oServer_DataArrival(Client As cWinsock, ByVal bytesTotal As Long) Dim sPeek As String ' 先查看前几个字符以检测协议 Client.PeekData sPeek, vbString, 4 If Left$(sPeek, 4) = "HTTP" Then Debug.Print "HTTP 请求" HandleHttpRequest Client ElseIf Left$(sPeek, 4) = "CHAT" Then Debug.Print "聊天协议" HandleChatMessage Client Else Debug.Print "未知协议" End If End Sub ``` *** ## 🎯 GetDataText 方法 ### 说明 将接收缓冲区数据作为文本返回（默认 ACP/GBK 编码）。返回值风格，一行代码即可使用。 ### 语法 ```vb Public Function GetDataText(Optional ByVal maxLen As Long = -1, Optional ByVal CodePage As EnumScpCodePage = wcpAcp) As String ``` ### 使用示例 ```vb ' 一行代码获取文本 Private Sub m_oServer_MessageArrival(Client As cWinsock, ByVal bytesTotal As Long) Debug.Print "消息: " & Client.GetDataText() ' 条件判断 If Client.GetDataText() = "PING" Then Client.SendData "PONG" End If End Sub ``` *** ## 🎯 GetDataTextUTF8 方法 ### 说明 将接收缓冲区数据作为 UTF-8 文本返回。 ### 语法 ```vb Public Function GetDataTextUTF8(Optional ByVal maxLen As Long = -1) As String ``` ### 使用示例 ```vb Debug.Print "UTF-8 数据: " & Client.GetDataTextUTF8() ``` *** ## 🎯 GetDataTextUnicode 方法 ### 说明 将接收缓冲区数据作为 Unicode 文本返回。 ### 语法 ```vb Public Function GetDataTextUnicode(Optional ByVal maxLen As Long = -1) As String ``` *** ## 🎯 GetDataHex 方法 ### 说明 将接收缓冲区数据以空格分隔的十六进制字符串返回。适合调试和日志记录。 ### 语法 ```vb Public Function GetDataHex(Optional ByVal maxLen As Long = -1) As String ``` ### 使用示例 ```vb Private Sub m_oServer_DataArrival(Client As cWinsock, ByVal bytesTotal As Long) ' 调试：查看原始字节 Debug.Print "原始数据: " & Client.GetDataHex() ' 输出: "48 65 6C 6C 6F" (Hello) End Sub ``` *** ## 🎯 GetDataByteArray 方法 ### 说明 将接收缓冲区数据作为字节数组返回。 ### 语法 ```vb Public Function GetDataByteArray(Optional ByVal maxLen As Long = -1) As Byte() ``` ### 使用示例 ```vb Private Sub m_oServer_DataArrival(Client As cWinsock, ByVal bytesTotal As Long) Dim baData() As Byte baData = Client.GetDataByteArray() ' 处理二进制数据 ProcessBinary baData End Sub ``` *** ## 🎯 GetDataToString 方法 ### 说明 兼容旧版的文本获取方法，等同于 `GetDataText`。 ### 语法 ```vb Public Function GetDataToString(Optional ByVal maxLen As Long = -1, Optional ByVal CodePage As EnumScpCodePage = wcpAcp) As String ``` *** ## 🔒 Close\_ 方法 ### 说明 关闭连接或停止监听。 ### 语法 ```vb Public Sub Close_() ``` ### 使用示例 ```vb ' 关闭客户端连接 Private Sub cmdDisconnect_Click() m_oClient.Close_ Debug.Print "已断开连接" End Sub ' 停止服务器 Private Sub cmdStopServer_Click() m_oServer.Close_ Debug.Print "服务器已停止" End Sub ' 关闭特定客户端 Private Sub DisconnectClient(ByVal oClient As cWinsock) oClient.Close_ m_oServer.RemoveClient oClient End Sub ``` ### 自动关闭 ```vb ' 窗体卸载时自动关闭 Private Sub Form_Unload(Cancel As Integer) On Error Resume Next m_oClient.Close_ m_oServer.Close_ m_oUdp.Close_ End Sub ``` *** ## 📝 GetErrorDescription 方法 ### 说明 获取错误代码的描述信息。 ### 语法 ```vb Public Function GetErrorDescription(ByVal ErrorCode As Long) As String ``` ### 使用示例 ```vb Private Sub m_oClient_Error(Client As cWinsock, ByVal Number As Long, Description As String, ByVal Scode As Long) ' 使用参数中的描述 Debug.Print "错误: " & Description ' 或使用 GetErrorDescription 获取 Debug.Print "错误描述: " & Client.GetErrorDescription(Number) End Sub ' 独立使用 Dim sDesc As String sDesc = m_oClient.GetErrorDescription(10060) Debug.Print sDesc ' "连接超时" ``` *** ## 🤝 Friend 方法 以下方法是内部使用的方法，通常不需要直接调用： ### AcceptFrom 接受新的连接（由 `OnAccept` 事件调用）。 ### SetUdpClientInfo 设置 UDP 虚拟客户端的信息（由 `OnReceive` 事件调用）。 ### RemoveClient 移除客户端（由 `CloseEvent` 或手动调用）。此方法会自动解绑用户并从所有组中移除。 ### RaiseDataArrivalEvent 触发数据到达事件（由客户端对象调用，通过父服务器触发）。 ### UnbindUserFromAllGroups 将用户从所有组中解绑（由 `Class_Terminate` 调用，用户断开连接时自动触发）。 *** > **提示**：用户绑定和组管理功能的详细文档请参考 [binding.md](./binding.md) ## 📌 方法使用场景总结 ### TCP 客户端流程 ```vb 1. m_oClient.Connect("127.0.0.1", 8080) 2. 等待 m_oClient_Connect 事件 3. m_oClient.SendData("Hello") 4. 等待 m_oClient_DataArrival 事件 5. Client.GetData sData 6. m_oClient.Close_() ``` ### TCP 服务器流程 ```vb 1. m_oServer.Listen(8080) 2. 等待 m_oServer_ConnectionRequest 事件 3. 设置 DisConnect = False 接受连接 4. 等待 m_oServer_DataArrival 事件 5. Client.GetData sData 6. Client.SendData("Reply") 7. 等待 m_oServer_CloseEvent 事件 ``` ### UDP 流程 ```vb 1. m_oUdp.Bind(8888) 2. 等待 m_oUdp_DataArrival 事件 3. Client.GetData sData 4. Client.SendData("Reply") 5. m_oUdp.Close_() ``` *** **最后更新**: 2026-05-25 --- --- url: /zh/vbman/winsock/roadmap.md --- # cWinsock 开发计划 > 📋 项目开发进度跟踪文档 ## 📖 目录 * [已完成功能](#已完成功能) * [待开发功能](#待开发功能) * [开发优先级](#开发优先级) * [技术路线图](#技术路线图) *** ## ✅ 已完成功能 ### 核心功能 #### 1. 基础网络通信 * \[x] TCP 客户端/服务器通信 * \[x] UDP 客户端/服务器通信 * \[x] 异步 socket 封装（基于 VbAsyncSocket） * \[x] 连接状态管理 * \[x] 异常处理机制 #### 2. 事件驱动模型 * \[x] Connect 事件（连接成功） * \[x] CloseEvent 事件（连接关闭） * \[x] ConnectionRequest 事件（新连接请求） * \[x] DataArrival 事件（数据到达） * \[x] SendProgress 事件（发送进度） * \[x] SendComplete 事件（发送完成） * \[x] Error 事件（错误处理） #### 3. 对象模型设计 * \[x] 纯类实现，无需控件 * \[x] 直接对象引用传递（无需索引查找） * \[x] 自动客户端集合管理（Clients 集合） * \[x] 服务器-客户端父子关系维护 * \[x] 事件代理机制（服务器统一处理客户端事件） #### 4. TCP 客户端事件代理 * \[x] 自动通过父服务器触发客户端事件 * \[x] 统一数据到达处理 * \[x] 统一连接断开处理 * \[x] 统一错误处理 #### 5. UDP 虚拟客户端管理 * \[x] 为每个远程地址:端口创建虚拟客户端对象 * \[x] 模拟 TCP 连接行为 * \[x] 支持 ConnectionRequest 事件 * \[x] 自动维护虚拟客户端集合 #### 6. 连接请求拦截 * \[x] ConnectionRequest 事件中的 DisConnect 参数 * \[x] 黑名单机制 * \[x] 白名单机制 * \[x] 端口范围限制 * \[x] 自动断开和资源清理 #### 7. 文本编码支持 * \[x] ScpAcp（系统默认代码页，GBK） * \[x] ScpUtf8（UTF-8 编码） * \[x] ScpUnicode（Unicode 宽字符） * \[x] 字符串/字节数组灵活转换 #### 8. 数据缓冲区管理 * \[x] TCP 接收缓冲区（m\_baRecvBuffer） * \[x] UDP 虚拟客户端缓冲区（UserData） * \[x] 部分读取支持 * \[x] 自动缓冲剩余数据 #### 9. 远程地址解析 * \[x] 域名自动解析 * \[x] IP 和域名智能选择 * \[x] RemoteHost/RemoteHostIP/RemotePort 属性 #### 10. 应用场景 * \[x] TCP 服务器模式 * \[x] TCP 客户端模式 * \[x] UDP 服务器模式 * \[x] UDP 客户端模式 * \[x] 双向通信 * \[x] 广播/多播基础支持 #### 11. 数据封包协议 ✅ (2025-05-25, 优化 2026-06-09) * \[x] 字符分隔符协议（ppDelimiter）- 支持自定义分隔符 * \[x] 定长协议（ppFixedLength） * \[x] 长度头协议（ppLengthHeader）- 支持 2/4 字节头，大小端 * \[x] 独立协议类 cPacketProtocol - 每个客户端独立实例 * \[x] 自动封包（SendData 调用 Encode） * \[x] 自动解包（OnReceive 调用 Decode） * \[x] MessageArrival 事件（完整消息到达） * \[x] 协议配置继承（新客户端继承服务器配置） * \[x] MaxPacketSize 属性（默认1MB）- 单包最大限制，防恶意超大包 * \[x] MaxBufferSize 属性（默认4MB）- 缓冲区累积上限，防内存耗尽 * \[x] 心跳走协议编码，不污染协议状态机 * \[x] UDP 客户端支持分包协议 * \[x] 协议模式只触发 MessageArrival（移除 DataArrival 双触发） * \[x] FixedLength 超长报错（不静默截断） * \[x] 2字节头 Encode 溢出修复 * \[x] 大端4字节解析溢出修复 #### 12. TCP 智能心跳 ✅ (2025-05-25, 优化 2026-06-09) * \[x] 独立心跳类 cHeartbeat * \[x] 服务端超时检测（默认 2 分钟） * \[x] 客户端自动心跳（默认 50 秒间隔） * \[x] 智能跳过（有数据收发时跳过心跳） * \[x] 内嵌 cTimer 自动驱动（无需外部 PollHeartbeat） * \[x] ClientTimeout 事件 * \[x] HeartbeatSent 事件 * \[x] 收发自动更新 LastActivityTime * \[x] 心跳发送走协议编码（修复心跳绕过协议的 Bug） #### 13. GetData 增强方法 ✅ (2025-05-25) * \[x] GetDataText() - 返回值型文本获取 * \[x] GetDataTextUTF8() - UTF-8 文本 * \[x] GetDataTextUnicode() - Unicode 文本 * \[x] GetDataHex() - 十六进制字符串 * \[x] GetDataByteArray() - 字节数组 *** ## 🚧 待开发功能 ### 1. 性能优化（中优先级） #### 4.1 批量发送 ```vb ' 批量发送多条消息，减少系统调用 Public Sub SendBatch(vData As Variant) ``` #### 4.2 数据压缩 * 可选的压缩算法支持 * 大数据自动压缩 * 透明压缩/解压 #### 4.3 连接池 * 复用 TCP 连接 * 减少 Connect 开销 * 自动负载均衡 *** ### 5. 高级功能（低优先级） #### 5.1 SSL/TLS 加密 * 支持 HTTPS/WSS * 证书验证 * 安全握手 #### 5.2 WebSocket 协议 * 完整的 WebSocket 支持 * 握手和帧处理 * 自动 Ping/Pong #### 5.3 断线重连 * 自动重连机制 * 指数退避算法 * 最大重试次数 #### 5.4 限流控制 * 发送速率限制 * 接收速率限制 * 流量统计 *** ## 📊 开发优先级 ### ~~P0 - 核心功能（必须实现）~~ ✅ 已完成 1. \~~**数据封包协议**~~ ✅ (2025-05-25, 优化 2026-06-09) * 三种内置协议 + 安全限制 + UDP 支持 + 7 项优化修复 * 详见 [分包协议与心跳机制](./packet-protocol.md) 2. \~~**TCP 智能心跳**~~ ✅ (2025-05-25, 优化 2026-06-09) * 内嵌 cTimer 自动驱动 + 心跳走协议编码 * 详见 [分包协议与心跳机制](./packet-protocol.md) ### ~~P1 - 增强功能（重要）~~ ✅ 已完成 1. \~~**GetData 增强方法**~~ ✅ (2025-05-25) * GetDataText/GetDataHex/GetDataByteArray 等返回值风格方法 ### P2 - 优化功能（可选） 1. **性能优化** * 批量发送 * 数据压缩 * 连接池 ### P3 - 高级功能（长期规划） 1. **SSL/TLS 加密** 2. **WebSocket 协议** 3. **断线重连** 4. **限流控制** *** ## 🗺️ 技术路线图 ### ~~阶段一：封包协议实现~~ ✅ 已完成 (2025-05-25) * Day 1-2: 设计协议接口和数据结构 * Day 3-4: 实现内置协议（CRLF、定长、长度头） * Day 5: 实现自定义协议接口和测试 ### ~~阶段二：心跳机制实现~~ ✅ 已完成 (2025-05-25) * Day 1-2: 实现服务端超时检测 * Day 3: 实现客户端心跳保活 ### ~~阶段三：GetData 增强~~ ✅ 已完成 (2025-05-25) * Day 1: 实现 4 个新方法和测试 ### ~~阶段三.五：协议安全加固与优化~~ ✅ 已完成 (2026-06-09) * 修复 2 个严重 Bug（心跳绕过协议编码、2字节头溢出） * 修复 1 个大端解析 Bug * 新增 MaxPacketSize/MaxBufferSize 安全属性 * UDP 支持分包协议 * 移除 DataArrival 双触发 * FixedLength 超长改为报错 * 详见 [分包协议与心跳机制](./packet-protocol.md) ### 阶段四：性能优化（待开发） * Day 1: 批量发送实现 * Day 2: 数据压缩实现 * Day 3: 连接池设计 ### 阶段五：高级功能（长期） * 根据用户需求和反馈逐步实现 *** ## 📝 使用建议 ### 开发期间 * 保持向后兼容性 * 不影响现有功能 * 提供充分的单元测试 * 更新文档和示例 ### 发布策略 * 分阶段发布 * 收集用户反馈 * 持续优化改进 *** ## 🔗 相关文档 * [总览](./overview.md) - 项目概览和核心特性 * [属性参考](./properties.md) - 属性详细说明 * [方法参考](./methods.md) - 方法详细说明 * [TCP编程](./tcp.md) - TCP 开发指南 *** **最后更新**: 2026-06-09 --- --- url: /zh/vbman/demo/14.Winsock.md --- # cWinsock 开发文档 ## 目录 * [概述](#概述) * [快速开始](#快速开始) * [TCP 客户端](#tcp-客户端) * [TCP 服务器](#tcp-服务器) * [UDP 通信](#udp-通信) * [API 参考](#api-参考) * [事件说明](#事件说明) * [高级特性](#高级特性) * [常见问题](#常见问题) *** ## 概述 cWinsock 是一个基于 Windows Socket API 的高级封装类，提供了简单易用的 VB6 网络编程接口。它支持 TCP 和 UDP 协议，可以轻松创建客户端和服务器端应用程序。 ### 主要特性 * **多协议支持**: 支持 TCP 和 UDP 协议 * **异步非阻塞**: 使用异步 I/O 模型，不阻塞 UI 线程 * **多客户端管理**: 服务器端自动管理多个客户端连接 * **事件驱动**: 通过事件机制处理网络事件 * **错误处理**: 完善的错误处理机制 ### 项目结构 ``` Winsock/ ├── Form1.frm # 主窗体（服务器 + UDP 示例） ├── Client.frm # 客户端窗体 ├── Module1.bas # 模块文件 ├── Project1.vbp # 项目文件 └── README.md # 示例说明 ``` *** ## 快速开始 ### 环境要求 * Visual Basic 6.0 或更高版本 * VBMAN.dll 库文件（位于 `..\..\vbman\dist\DLL\`） ### 引用库 1. 打开项目 `Project1.vbp` 2. 确保已引用 `VBMANLIB` 库 3. 检查引用路径是否正确：`..\..\vbman\dist\DLL\VBMAN.dll` ### 基础代码结构 ```vb ' 声明 cWinsock 对象（带事件） Private WithEvents m_oSocket As cWinsock ' 初始化对象 Set m_oSocket = New cWinsock ' 设置协议类型 m_oSocket.Protocol = sckTCPProtocol ' 或 sckUDPProtocol ``` *** ## TCP 客户端 TCP 客户端用于连接到远程服务器，建立可靠的连接后进行双向通信。 ![客户端](/images/vbman/socket/1.png) ### 创建 TCP 客户端 ```vb Private WithEvents m_oClient As cWinsock Private Sub InitializeClient() If m_oClient Is Nothing Then Set m_oClient = New cWinsock m_oClient.Protocol = sckTCPProtocol End If End Sub ``` ### 连接到服务器 ```vb Private Sub ConnectToServer(ByVal sHost As String, ByVal lPort As Long) On Error GoTo EH InitializeClient() m_oClient.Connect sHost, lPort LogMessage "正在连接到 " & sHost & ":" & lPort & "..." Exit Sub EH: LogMessage "连接错误: " & Err.Description End Sub ``` **参数说明:** * `sHost`: 服务器 IP 地址或主机名（如 "127.0.0.1" 或 "example.com"） * `lPort`: 服务器端口号（如 8080） ### 发送数据 ```vb Private Sub SendData(sData As String) On Error GoTo EH If Not m_oClient Is Nothing And m_oClient.State = sckConnected Then m_oClient.SendData sData LogMessage "已发送数据: " & sData Else LogMessage "未连接到服务器" End If Exit Sub EH: LogMessage "发送错误: " & Err.Description End Sub ``` ### 断开连接 ```vb Private Sub Disconnect() If Not m_oClient Is Nothing Then m_oClient.Close_ LogMessage "客户端已断开连接" End If End Sub ``` ### 完整示例 参考 `Client.frm` 文件，这是一个完整的 TCP 客户端实现： ```vb Private Sub cmdClientConnect_Click() On Error GoTo EH If m_oClient Is Nothing Then Set m_oClient = New cWinsock m_oClient.Protocol = sckTCPProtocol End If m_oClient.Connect txtClientHost.Text, CLng(txtClientPort.Text) LogMessage "正在连接到 " & txtClientHost.Text & ":" & txtClientPort.Text & "..." Exit Sub EH: LogMessage "连接错误: " & Err.Description End Sub Private Sub cmdClientDisconnect_Click() If Not m_oClient Is Nothing Then m_oClient.Close_ LogMessage "客户端已断开连接" End If cmdClientConnect.Enabled = True cmdClientDisconnect.Enabled = False cmdClientSend.Enabled = False End Sub Private Sub cmdClientSend_Click() On Error GoTo EH If Not m_oClient Is Nothing And m_oClient.State = sckConnected Then m_oClient.SendData txtClientData.Text LogMessage "已发送数据: " & txtClientData.Text End If Exit Sub EH: LogMessage "发送错误: " & Err.Description End Sub ``` *** ## TCP 服务器 TCP 服务器监听指定端口，接受多个客户端连接，并可以与每个客户端进行独立通信。 ![服务器](/images/vbman/socket/2.png) ### 创建 TCP 服务器 ```vb Private WithEvents m_oServer As cWinsock Private Sub InitializeServer() If m_oServer Is Nothing Then Set m_oServer = New cWinsock End If m_oServer.Protocol = sckTCPProtocol End Sub ``` ### 开始监听 ```vb Private Sub StartListening(ByVal lPort As Long) On Error GoTo EH InitializeServer() m_oServer.Listen lPort LogMessage "服务器开始监听端口 " & lPort Exit Sub EH: LogMessage "监听错误: " & Err.Description End Sub ``` ### 停止监听 ```vb Private Sub StopListening() If Not m_oServer Is Nothing Then m_oServer.Close_ LogMessage "服务器已停止监听" End If End Sub ``` ### 处理客户端连接 ```vb Private Sub m_oServer_ConnectionRequest(Client As VBMANLIB.cWinsock, DisConnect As Boolean) ' 压测模式下不显示连接日志 If Not m_bStressTestMode Then LogMessage "新客户端连接: " & Client.RemoteHostIP & ":" & Client.RemotePort & " (Tag: " & Client.Tag & ")" End If ' 将 Tag 内容写入 listbox lstClients.AddItem Client.Tag & " " & Client.RemoteHostIP & ":" & Client.RemotePort End Sub ``` ### 压测模式 压测模式用于性能测试，在高并发场景下只统计数据而不显示详细日志： ```vb ' 压测模式变量 Private m_bStressTestMode As Boolean Private m_lMsgCount As Long ' 当前周期消息数 Private m_lBytesCount As Long ' 当前周期字节数 Private m_lTotalMsgCount As Long ' 累计消息数 Private m_lTotalBytesCount As Long ' 累计字节数 Private m_lCurrentClientCount As Long ' 当前客户端数量 Private m_dLastStatsTime As Double ' 上次统计时间 Private WithEvents tmrStats As VB.Timer ' 切换压测模式 Private Sub chkStressTest_Click() m_bStressTestMode = (chkStressTest.Value = vbChecked) If m_bStressTestMode Then LogMessage "压测模式已启用 - 仅统计，不显示消息内容" ResetStats Else LogMessage "压测模式已关闭 - 显示所有消息内容" End If End Sub ' 接收数据时（压测模式） Private Sub m_oServer_DataArrival(Client As cWinsock, ByVal bytesTotal As Long) Dim sData As String Dim sResponse As String On Error GoTo EH If m_bStressTestMode Then ' 压测模式：只统计，不获取内容 Client.GetData sData, vbString, bytesTotal ' 累计统计 m_lMsgCount = m_lMsgCount + 1 m_lBytesCount = m_lBytesCount + bytesTotal m_lTotalMsgCount = m_lTotalMsgCount + 1 m_lTotalBytesCount = m_lTotalBytesCount + bytesTotal ' 回显数据 sResponse = "OK" Client.SendData sResponse Else ' 普通模式：显示内容 Client.GetData sData LogMessage "从客户端 " & Client.Tag & " 收到数据 (" & bytesTotal & " 字节): " & sData sResponse = "Echo: " & sData Client.SendData sResponse LogMessage "已向客户端 " & Client.Tag & " 发送回显: " & sResponse End If Exit Sub EH: LogMessage "服务器接收数据错误: " & Err.Description End Sub ' 统计定时器（每秒更新一次） Private Sub tmrStats_Timer() Dim dCurrentTime As Double Dim dElapsedTime As Double Dim lMsgPerSec As Long Dim lBytesPerSec As Long Dim sStats As String If m_bStressTestMode Then dCurrentTime = Timer dElapsedTime = dCurrentTime - m_dLastStatsTime If dElapsedTime > 0 Then lMsgPerSec = CLng(m_lMsgCount / dElapsedTime) lBytesPerSec = CLng(m_lBytesCount / dElapsedTime) ' 构建统计信息（每项一行） sStats = vbCrLf & _ "========================================" & vbCrLf & _ Format$(Now, "hh:mm:ss") & " - [统计信息]" & vbCrLf & _ "----------------------------------------" & vbCrLf & _ "当前周期消息数: " & m_lMsgCount & vbCrLf & _ "当前周期字节数: " & m_lBytesCount & vbCrLf & _ "消息速率: " & lMsgPerSec & " msg/s" & vbCrLf & _ "数据速率: " & Format$(lBytesPerSec / 1024, "0.00") & " KB/s" & vbCrLf & _ "----------------------------------------" & vbCrLf & _ "当前客户端数量: " & m_lCurrentClientCount & vbCrLf & _ "累计消息数: " & m_lTotalMsgCount & vbCrLf & _ "累计字节数: " & Format$(m_lTotalBytesCount / 1024 / 1024, "0.00") & " MB" & vbCrLf & _ "========================================" & vbCrLf ' 直接替换文本框内容 txtLog.Text = sStats txtLog.SelStart = Len(txtLog.Text) ' 重置当前周期统计 m_lMsgCount = 0 m_lBytesCount = 0 m_dLastStatsTime = dCurrentTime End If End If End Sub ``` ### 接收和发送数据 ```vb Private Sub m_oServer_DataArrival(Client As cWinsock, ByVal bytesTotal As Long) Dim sData As String Dim sResponse As String On Error GoTo EH ' 获取数据 Client.GetData sData LogMessage "从客户端 " & Client.Tag & " 收到数据 (" & bytesTotal & " 字节): " & sData ' 处理数据并返回 sResponse = "Echo: " & sData Client.SendData sResponse LogMessage "已向客户端 " & Client.Tag & " 发送回显: " & sResponse Exit Sub EH: LogMessage "服务器接收数据错误: " & Err.Description End Sub ``` ### 处理客户端断开 ```vb Private Sub m_oServer_CloseEvent(Client As cWinsock) Dim i As Long ' 压测模式下不显示日志 If Not m_bStressTestMode Then LogMessage "客户端 " & Client.RemoteHostIP & ":" & Client.RemotePort & " 已断开连接" End If ' 用 Tag 去 listbox 遍历删除匹配项 For i = 0 To lstClients.ListCount - 1 If InStr(lstClients.List(i), Client.Tag) > 0 Then lstClients.RemoveItem i Exit For End If Next End Sub ``` ### 完整示例 参考 `Form1.frm` 中的服务器实现： ```vb Private Sub cmdServerListen_Click() On Error GoTo EH If m_oServer Is Nothing Then Set m_oServer = New cWinsock End If m_oServer.Protocol = sckTCPProtocol m_oServer.Listen CLng(txtServerPort.Text) LogMessage "服务器开始监听端口 " & txtServerPort.Text cmdServerListen.Enabled = False cmdServerStop.Enabled = True Exit Sub EH: LogMessage "监听错误: " & Err.Description End Sub Private Sub m_oServer_ConnectionRequest(Client As VBMANLIB.cWinsock, DisConnect As Boolean) LogMessage "新客户端连接: " & Client.RemoteHostIP & ":" & Client.RemotePort & " (Tag: " & Client.Tag & ")" lstClients.AddItem Client.Tag & " - " & Client.RemoteHostIP & ":" & Client.RemotePort End Sub ``` *** ## UDP 通信 UDP（User Datagram Protocol）是无连接的协议，适合发送少量数据或对可靠性要求不高的场景。 ### 创建 UDP Socket ```vb Private WithEvents m_oUdp As cWinsock Private Sub InitializeUdp() If m_oUdp Is Nothing Then Set m_oUdp = New cWinsock m_oUdp.Protocol = sckUDPProtocol End If End Sub ``` ### 绑定本地端口 ```vb Private Sub BindUdpPort(ByVal lPort As Long) On Error GoTo EH InitializeUdp() m_oUdp.Bind lPort LogMessage "UDP Socket 已绑定到端口 " & lPort Exit Sub EH: LogMessage "UDP 绑定错误: " & Err.Description End Sub ``` ### 发送 UDP 数据 ```vb Private Sub SendUdpData(sHost As String, lPort As Long, sData As String) On Error GoTo EH With m_oUdp .RemoteHost = sHost .RemotePort = lPort .SendData sData LogMessage "UDP 已发送数据到 " & sHost & ":" & lPort & ": " & sData End With Exit Sub EH: LogMessage "UDP 发送错误: " & Err.Description End Sub ``` ### 接收 UDP 数据 ```vb Private Sub m_oUdp_DataArrival(Client As cWinsock, ByVal bytesTotal As Long) Dim sData As String On Error GoTo EH Client.GetData sData LogMessage "UDP 收到数据 (" & bytesTotal & " 字节) 来自 " & Client.RemoteHostIP & ":" & Client.RemotePort & ": " & sData Exit Sub EH: LogMessage "UDP 接收数据错误: " & Err.Description End Sub ``` ### 完整示例 参考 `Form1.frm` 中的 UDP 实现： ```vb Private Sub cmdUdpBind_Click() If m_oUdp Is Nothing Then Set m_oUdp = New cWinsock m_oUdp.Protocol = sckUDPProtocol End If m_oUdp.Bind CLng(txtUdpPort.Text) LogMessage "UDP Socket 已绑定到端口 " & txtUdpPort.Text End Sub Private Sub cmdUdpSend_Click() On Error GoTo EH With m_oUdp .RemoteHost = txtUdpHost.Text .RemotePort = CLng(txtUdpPort.Text) .SendData txtUdpData.Text LogMessage "UDP 已发送数据到 " & txtUdpHost.Text & ":" & txtUdpPort.Text & ": " & txtUdpData.Text End With Exit Sub EH: LogMessage "UDP 发送错误: " & Err.Description End Sub ``` *** ## API 参考 ### 属性 | 属性名 | 类型 | 说明 | |--------|------|------| | `Protocol` | Integer | 协议类型：`sckTCPProtocol` (0) 或 `sckUDPProtocol` (1) | | `State` | Integer | 连接状态，参见下方状态常量 | | `RemoteHost` | String | 远程主机地址 | | `RemoteHostIP` | String | 远程主机 IP 地址（只读） | | `RemotePort` | Long | 远程端口号 | | `LocalPort` | Long | 本地端口号（只读） | | `Tag` | Variant | 用于存储自定义数据的标签 | ### 方法 #### Connect ```vb oSocket.Connect RemoteHost, RemotePort ``` 连接到指定的服务器。 **参数:** * `RemoteHost`: 服务器地址（IP 或主机名） * `RemotePort`: 服务器端口 #### Listen ```vb oSocket.Listen Port ``` 开始监听指定端口（仅 TCP 服务器模式）。 **参数:** * `Port`: 监听端口号 #### Bind ```vb oSocket.Bind Port ``` 绑定本地端口（仅 UDP 模式）。 **参数:** * `Port`: 绑定端口号 #### SendData ```vb oSocket.SendData Data ``` 发送数据到远程端点。 **参数:** * `Data`: 要发送的数据（字符串或字节数组） #### GetData ```vb oSocket.GetData Data, [Type], [MaxLen] ``` 从缓冲区获取接收到的数据。 **参数:** * `Data`: 存储接收数据的变量 * `Type`: 可选，数据类型（默认为字符串） * `MaxLen`: 可选，最大读取长度 #### Close\_ ```vb oSocket.Close_ ``` 关闭连接或停止监听。 ### 状态常量 | 常量 | 值 | 说明 | |------|-----|------| | `sckClosed` | 0 | 连接已关闭 | | `sckOpen` | 1 | Socket 已打开 | | `sckListening` | 2 | 正在监听 | | `sckConnectionPending` | 3 | 连接正在建立 | | `sckResolvingHost` | 4 | 正在解析主机 | | `sckHostResolved` | 5 | 主机已解析 | | `sckConnecting` | 6 | 正在连接 | | `sckConnected` | 7 | 已连接 | | `sckClosing` | 8 | 正在关闭 | | `sckError` | 9 | 发生错误 | *** ## 事件说明 ### Connect ```vb Private Sub oSocket_Connect(Client As cWinsock) ``` 客户端成功连接到服务器时触发。 **参数:** * `Client`: 触发事件的 cWinsock 对象 ### CloseEvent ```vb Private Sub oSocket_CloseEvent(Client As cWinsock) ``` 连接关闭时触发。 **参数:** * `Client`: 触发事件的 cWinsock 对象 ### ConnectionRequest ```vb Private Sub oSocket_ConnectionRequest(Client As cWinsock, DisConnect As Boolean) ``` 服务器收到新客户端连接请求时触发（仅 TCP 服务器）。 **参数:** * `Client`: 新连接的客户端对象 * `DisConnect`: 设置为 True 拒绝连接，False 接受连接 ### DataArrival ```vb Private Sub oSocket_DataArrival(Client As cWinsock, ByVal bytesTotal As Long) ``` 收到数据时触发。 **参数:** * `Client`: 接收数据的客户端对象 * `bytesTotal`: 接收到的数据字节数 ### Error ```vb Private Sub oSocket_Error(Client As cWinsock, ByVal Number As Long, Description As String, ByVal Scode As Long) ``` 发生错误时触发。 **参数:** * `Client`: 发生错误的客户端对象 * `Number`: 错误代码 * `Description`: 错误描述 * `Scode`: 系统 Scode 错误码 *** ## 高级特性 ### 多客户端管理 服务器端会自动为每个连接创建独立的客户端对象，通过 `Tag` 属性可以识别不同的客户端： ```vb Private Sub m_oServer_ConnectionRequest(Client As cWinsock, DisConnect As Boolean) ' 分配唯一标识 Client.Tag = "Client_" & GetNextId() ' 存储到集合中管理 colClients.Add Client, Client.Tag LogMessage "新客户端: " & Client.Tag End Sub ``` ### 客户端认证 在 `ConnectionRequest` 事件中实现简单的认证： ```vb Private Sub m_oServer_ConnectionRequest(Client As cWinsock, DisConnect As Boolean) ' 检查 IP 白名单 If Not IsAllowedIP(Client.RemoteHostIP) Then DisConnect = True LogMessage "拒绝连接: " & Client.RemoteHostIP Exit Sub End If LogMessage "接受连接: " & Client.RemoteHostIP End Sub ``` ### 数据分包处理 处理大量数据时的分包传输： ```vb Private Sub m_oServer_DataArrival(Client As cWinsock, ByVal bytesTotal As Long) Static sBuffer As String Dim sData As String Dim lPos As Long Client.GetData sData sBuffer = sBuffer & sData ' 查找消息结束标记（如换行符） Do lPos = InStr(sBuffer, vbCrLf) If lPos > 0 Then ProcessMessage Client, Left(sBuffer, lPos - 1) sBuffer = Mid(sBuffer, lPos + 2) Else Exit Do End If Loop End Sub ``` ### 错误重连机制 实现自动重连： ```vb Private Sub m_oClient_CloseEvent(Client As cWinsock) LogMessage "连接已断开，尝试重连..." ' 延迟重连 Dim i As Integer For i = 1 To 3 If TryReconnect() Then Exit Sub End If Sleep 2000 Next i LogMessage "重连失败" End Sub ``` *** ## 常见问题 ### Q1: 连接超时如何处理？ A: 可以使用定时器监控连接状态： ```vb Private WithEvents tmrConnect As Timer Private Sub StartConnectTimer() Set tmrConnect = New Timer tmrConnect.Interval = 10000 ' 10秒超时 tmrConnect.Enabled = True End Sub Private Sub tmrConnect_Timer() If m_oClient.State <> sckConnected Then m_oClient.Close_ LogMessage "连接超时" tmrConnect.Enabled = False End If End Sub ``` ### Q2: 如何发送二进制数据？ A: 使用字节数组： ```vb Dim byData() As Byte byData = StrConv("Hello", vbFromUnicode) m_oClient.SendData byData ``` ### Q3: UDP 模式下如何区分不同的发送者？ A: 通过 `RemoteHostIP` 和 `RemotePort` 属性： ```vb Private Sub m_oUdp_DataArrival(Client As cWinsock, ByVal bytesTotal As Long) Dim sSender As String sSender = Client.RemoteHostIP & ":" & Client.RemotePort LogMessage "收到来自 " & sSender & " 的数据" End Sub ``` ### Q4: 如何限制客户端连接数？ A: 使用计数器管理： ```vb Private lClientCount As Long Private Sub m_oServer_ConnectionRequest(Client As cWinsock, DisConnect As Boolean) If lClientCount >= 100 Then DisConnect = True LogMessage "拒绝连接：达到最大客户端数" Exit Sub End If lClientCount = lClientCount + 1 LogMessage "客户端连接数: " & lClientCount End Sub Private Sub m_oServer_CloseEvent(Client As cWinsock) lClientCount = lClientCount - 1 End Sub ``` ### Q5: 如何调试网络通信问题？ A: 使用日志记录所有关键事件： ```vb Private Sub LogMessage(sMessage As String) txtLog.Text = txtLog.Text & Format$(Now, "hh:mm:ss") & " - " & sMessage & vbCrLf txtLog.SelStart = Len(txtLog.Text) Debug.Print sMessage ' 输出到立即窗口 End Sub ``` *** ## 最佳实践 1. **始终检查连接状态**：在发送数据前检查 `State = sckConnected` 2. **错误处理**：所有网络操作都应包含错误处理 3. **资源清理**：窗体卸载时调用 `Close_` 释放资源 4. **日志记录**：记录关键事件便于调试 5. **超时处理**：设置合理的连接和操作超时 6. **数据校验**：接收数据时进行格式和长度验证 *** ## 相关资源 * 项目目录: `Winsock/` * 示例代码: `Client.frm`, `Form1.frm` * 依赖库: `VBMAN.dll` *** ## 更新日志 * v1.0 - 初始版本，包含 TCP 客户端、TCP 服务器和 UDP 示例 --- --- url: /zh/vbman/winsock/overview.md --- # cWinsock 类开发文档 > 🚀 **cWinsock** - 简化版 VB6 Winsock 封装库，由 woeoio@qq.com 基于 VbAsyncSocket（作者：wqweto@gmail.com）开发 ## 📖 目录 * [概述](#概述) * [核心亮点](#核心亮点) * [与原生 Winsock 控件的对比](#与原生-winsock-控件的对比) * [快速开始](#快速开始) * [架构设计](#架构设计) * [文档索引](#文档索引) *** ## 概述 `cWinsock` 是一个为 VB6 设计的轻量级网络通信类，提供了与经典 Winsock 控件相似的事件驱动编程模型，但具有更简洁的 API 和更强大的功能。 ### ✨ 主要特性 * 🔌 **纯类实现** - 无需控件，直接使用对象编程 * 🎯 **直接对象引用** - 事件参数直接传递客户端对象，无需通过索引查找 * 🌐 **双协议支持** - 同时支持 TCP 和 UDP 通信 * 🏢 **自动客户端管理** - 服务器模式自动管理所有连接的客户端 * 📦 **智能数据编码** - 支持多种文本编码（GBK/ACP、UTF-8、Unicode） * 🛡️ **连接拦截能力** - 通过 `ConnectionRequest` 事件的黑名单/白名单机制 * 🔄 **事件代理机制** - 服务器客户端数据统一通过服务器事件触发 * 💾 **灵活数据类型** - 支持字符串和字节数组两种数据格式 * 📦 **数据封包协议** - 三种内置协议解决 TCP 分包粘包，自动封包/解包 * 💓 **智能心跳机制** - 内嵌定时器自动驱动，服务端超时检测，客户端智能保活 * 🔒 **TLS/SSL 支持** - 链式函数配置 TLS，客户端和服务端均可加密通信 * 🎯 **GetData 增强** - 返回值风格便捷方法，一行代码获取文本/Hex/字节数组 *** ## 核心亮点 ### 1️⃣ 直接对象引用事件模型 🔗 **传统 Winsock 控件的问题：** ```vb ' 需要通过索引管理客户端 Private Sub Winsock1_ConnectionRequest(Index As Integer, ByVal requestID As Long) Dim i As Integer ' 找到空闲的索引或动态加载控件... End Sub ' 处理数据时需要知道是哪个客户端 Private Sub Winsock1_DataArrival(Index As Integer, ByVal bytesTotal As Long) Winsock1(Index).GetData strData End Sub ``` **cWinsock 的优雅解决方案：** ```vb ' 事件直接传递客户端对象！ Private Sub m_oServer_ConnectionRequest(Client As cWinsock, ByRef DisConnect As Boolean) ' 直接操作 Client 对象，无需索引 Debug.Print "新客户端: " & Client.RemoteHostIP ' 拒绝黑名单 IP If IsBlacklisted(Client.RemoteHostIP) Then DisConnect = True End If End Sub ' 数据事件也是直接传递客户端对象 Private Sub m_oServer_DataArrival(Client As cWinsock, ByVal bytesTotal As Long) Dim sData As String Client.GetData sData ' 直接从 Client 对象读取数据，无需索引查找 End Sub ``` *** ### 2️⃣ 智能的 TCP 客户端事件代理 📡 **问题场景：** 服务器接受新连接后创建的客户端对象，其数据接收事件无法被宿主订阅。 **cWinsock 的解决方案：** 自动通过父服务器对象触发事件 ```vb ' 在服务器对象的 DataArrival 事件中 ' 可以接收到所有客户端的数据！ Private Sub m_oServer_DataArrival(Client As cWinsock, ByVal bytesTotal As Long) Dim sData As String Client.GetData sData ' Client 参数就是具体的客户端对象 ' 可以直接向该客户端回复 Client.SendData "Echo: " & sData End Sub ``` **工作原理：** 1. 服务器接受新连接，创建独立的客户端 socket 对象 2. 客户端接收数据后，通过父服务器的 `RaiseDataArrivalEvent` 方法触发事件 3. 宿主只需订阅服务器对象的事件，即可处理所有客户端的数据 *** ### 3️⃣ UDP 服务器虚拟客户端管理 🎭 UDP 是无连接协议，但 `cWinsock` 为每个不同的远程地址:端口创建虚拟客户端对象，模拟连接行为： ```vb ' UDP 服务器模式 Private Sub m_oUdp_ConnectionRequest(Client As cWinsock, ByRef DisConnect As Boolean) ' 每个首次通信的远程地址:端口组合 ' 都会自动创建一个虚拟 Client 对象 Debug.Print "UDP 客户端: " & Client.RemoteHostIP & ":" & Client.RemotePort End Sub Private Sub m_oUdp_DataArrival(Client As cWinsock, ByVal bytesTotal As Long) Dim sData As String Client.GetData sData ' 可以向特定的虚拟客户端回复 ' cWinsock 会自动使用正确的目标地址:端口 Client.SendData "Reply: " & sData End Sub ``` *** ### 4️⃣ 连接请求拦截机制 🚦 在 `ConnectionRequest` 事件中通过 `DisConnect` 参数实现连接拦截： ```vb Private Sub m_oServer_ConnectionRequest(Client As cWinsock, ByRef DisConnect As Boolean) ' 黑名单检查 If IsInBlacklist(Client.RemoteHostIP) Then Debug.Print "拒绝黑名单 IP: " & Client.RemoteHostIP DisConnect = True ' 设置为 True，自动断开并清理资源 Exit Sub End If ' 端口范围限制 If Client.RemotePort < 1024 Then Debug.Print "拒绝特权端口连接: " & Client.RemotePort DisConnect = True Exit Sub End If ' 白名单模式 If m_bWhitelistMode And Not IsInWhitelist(Client.RemoteHostIP) Then Debug.Print "不在白名单中，拒绝连接" DisConnect = True Exit Sub End If ' DisConnect 保持 False，接受连接 Debug.Print "接受连接: " & Client.RemoteHostIP & ":" & Client.RemotePort End Sub ``` *** ### 5️⃣ 灵活的文本编码支持 🔤 支持多种编码方式，适应不同场景： ```vb ' 默认使用 ACP/GBK 编码（与 VB6 兼容） Client.SendData "中文测试" Client.GetData sData ' 默认 ACP ' 使用 UTF-8 编码（推荐用于网络传输） Client.SendData "中文测试", ucsScpUtf8 Client.GetData sData, , , ucsScpUtf8 ' 使用 Unicode（不转换，保持宽字符） Client.SendData "中文测试", ScpUnicode Client.GetData sData, , , ScpUnicode ' 发送字节数组（不涉及编码） Dim baData() As Byte baData = GetByteArray() Client.SendData baData ``` **编码枚举：** * `ScpAcp` (0) - 系统默认代码页（中文 Windows 上为 GBK） * `ScpUtf8` (65001) - UTF-8 编码 * `ScpUnicode` (-1) - Unicode，不进行编码转换 *** ### 6️⃣ 自动客户端集合管理 📚 服务器模式下，自动维护所有连接的客户端： ```vb ' 启动服务器时自动初始化客户端集合 m_oServer.Listen 8080 ' 遍历所有客户端 Dim oClient As cWinsock For Each oClient In m_oServer.Clients Debug.Print "客户端: " & oClient.ClientId & " - " & oClient.RemoteHostIP Next ' 获取客户端数量 Debug.Print "当前连接数: " & m_oServer.ClientCount ' 手动移除客户端（通常由 CloseEvent 自动处理） m_oServer.RemoveClient oClient ``` *** ### 7️⃣ 智能的远程地址解析 🌐 UDP 服务器模式支持域名解析： ```vb ' 设置远程地址（可以是 IP 或域名） m_oUdp.RemoteHost = "example.com" m_oUdp.RemotePort = 8888 ' 发送时自动解析域名 m_oUdp.SendData "Hello" ``` **内部逻辑：** ```vb ' SendData 方法中的智能选择 If LenB(m_sRemoteHostIP) <> 0 Then ' 如果已解析的 IP 存在，优先使用 m_oSocket.SendText Data, m_sRemoteHostIP, m_lRemotePort, CodePage ElseIf LenB(m_sRemoteHost) <> 0 Then ' 否则使用主机名，底层自动解析域名 m_oSocket.SendText Data, m_sRemoteHost, m_lRemotePort, CodePage End If ``` *** ### 8️⃣ 数据缓冲区管理 📊 内置数据缓冲区，支持部分读取： ```vb ' 接收数据时只读取前 100 字节 Dim sPartial As String Client.GetData sPartial, vbString, 100 ' 剩余数据自动保存在内部缓冲区 ' 下次读取时会继续返回剩余数据 ``` **内部缓冲区机制：** * TCP 和客户端模式：使用 `m_baRecvBuffer` 私有成员 * UDP 服务器虚拟客户端：使用 `UserData` 属性临时存储 *** ### 9️⃣ 数据封包协议 📦 **问题场景**：TCP 是流式协议，存在数据分包和粘包问题 ```vb ' 发送方连续发送 Client.SendData "Hello" Client.SendData "World" ' 接收方可能收到 "HelloWorld" ' 粘包 "Hel" ' 分包 "loWorld" ``` **cWinsock 内置三种协议解决**： * **字符分隔符协议** (`ppDelimiter`) - 支持自定义分隔符（如 `\r\n`、`|`、`\0` 等） * **定长协议** (`ppFixedLength`) - 适用于固定长度消息 * **长度头协议** (`ppLengthHeader`) - 支持 2/4 字节头，大小端可配 **使用示例**： ```vb ' 设置字符分隔符协议 Server.PacketProtocol = ppDelimiter Server.Delimiter = vbCrLf ' 或设置长度头协议 Server.PacketProtocol = ppLengthHeader Server.HeaderBytes = 4 ' 4字节长度头 Server.HeaderEndian = eeLittleEndian ' 发送自动封包 Client.SendData "Hello World" ' 自动追加协议标记 ' 接收自动解包 - 使用 MessageArrival 事件 Private Sub Server_MessageArrival(Client As cWinsock, ByVal bytesTotal As Long) Dim sData As String Client.GetDataText sData ' 获取完整消息 End Sub ``` **关键特性**： * 每个客户端独立协议实例，缓冲区相互隔离 * 新客户端自动继承服务器协议配置 * 协议模式下**只触发 `MessageArrival`**，不触发 `DataArrival`，避免重复读取 * 心跳数据走协议编码，不会污染协议状态机 * `MaxPacketSize`/`MaxBufferSize` 安全限制，防恶意包和内存耗尽 * UDP 客户端同样支持分包协议 **详细说明**：参见 [分包协议与心跳机制](./packet-protocol.md)、[属性参考](./properties.md)、[事件详解](./events.md) *** ### 🔟 TCP 智能心跳 💓 **问题场景**：TCP 连接可能因网络问题静默断开，需要保活机制 **cWinsock 内置心跳管理器**，内嵌 `cTimer` 自动驱动，无需外部定时器： ```vb ' 服务端：超时检测（默认120秒） Server.HeartbeatTimeout = 120 Server.AutoHeartbeat = True ' 客户端：心跳保活（默认50秒间隔） Client.HeartbeatInterval = 50 Client.AutoHeartbeat = True ' 事件 Private Sub Server_ClientTimeout(Client As cWinsock) Debug.Print "客户端超时: " & Client.RemoteHostIP ' 已自动断开，可做清理 End Sub Private Sub Client_HeartbeatSent(Client As cWinsock) Debug.Print "心跳已发送" End Sub ``` **关键特性**： * 内嵌 `cTimer`（10秒间隔），`AutoHeartbeat = True` 即全自动运行 * 服务端：轮询客户端空闲时间，超时自动断开僵尸连接 * 客户端：智能跳过 - 有数据收发时跳过心跳，节省带宽 * 每次收发数据自动更新 `LastActivityTime` * 新客户端自动继承服务器心跳配置 * 心跳数据走协议编码，不会污染分包协议状态机 **详细说明**：参见 [分包协议与心跳机制](./packet-protocol.md)、[属性参考](./properties.md)、[事件详解](./events.md) *** ### 1️⃣1️⃣ GetData 增强方法 🎯 **问题场景**：获取数据需要手动转换格式，代码繁琐 **cWinsock 提供返回值风格的便捷方法**，一行代码即可使用： ```vb ' 直接返回文本 Debug.Print Client.GetDataText() ' ACP/GBK Debug.Print Client.GetDataTextUTF8() ' UTF-8 Debug.Print Client.GetDataTextUnicode() ' Unicode ' 直接返回十六进制 Debug.Print Client.GetDataHex() ' "48 65 6C 6C 6F" ' 直接返回字节数组 Dim baData() As Byte baData = Client.GetDataByteArray() ' 条件判断 If Client.GetDataText() = "Hello" Then Debug.Print "收到 Hello" End If ' 兼容旧方法 Dim sData As String sData = Client.GetDataToString() ' 等同于 GetDataText() ``` **详细说明**：参见 [方法参考](./methods.md) *** ## 与原生 Winsock 控件的对比 | 特性 | 原生 Winsock 控件 | cWinsock 类 | |------|-------------------|-------------| | **对象模型** | 控件数组，通过索引管理 | 纯类对象，直接引用 | | **事件参数** | 传递索引，需反查对象 | 直接传递客户端对象 | | **客户端管理** | 需要手动维护索引和控件 | 自动管理 Clients 集合 | | **UDP 服务器** | 无连接，无客户端概念 | 虚拟客户端对象 | | **连接拦截** | 需要在 Accept 后手动关闭 | 事件参数控制，自动清理 | | **编码支持** | 固定编码 | 多种编码可选 | | **数据类型** | 字符串/字节数组 | 字符串/字节数组 + 灵活转换 + 返回值便捷方法 | | **事件统一** | 每个客户端独立事件 | 服务器统一触发所有客户端事件 | | **封包协议** | 需手动处理粘包 | 内置三种协议，自动封包/解包 | | **心跳保活** | 需手动实现 | 内置心跳管理器，全自动驱动 | | **资源管理** | 需要手动 Unload 控件 | 自动清理和垃圾回收 | *** ## 快速开始 ### TCP 客户端示例 ```vb Private WithEvents m_oClient As cWinsock Private Sub Form_Load() Set m_oClient = New cWinsock m_oClient.Protocol = sckTCPProtocol m_oClient.Connect "127.0.0.1", 8080 End Sub Private Sub m_oClient_Connect(Client As cWinsock) Debug.Print "已连接到服务器" Client.SendData "Hello, Server!" End Sub Private Sub m_oClient_DataArrival(Client As cWinsock, ByVal bytesTotal As Long) Dim sData As String Client.GetData sData Debug.Print "收到数据: " & sData End Sub Private Sub Form_Unload(Cancel As Integer) m_oClient.Close_ End Sub ``` ### TCP 服务器示例 ```vb Private WithEvents m_oServer As cWinsock Private Sub Form_Load() Set m_oServer = New cWinsock m_oServer.Protocol = sckTCPProtocol m_oServer.Listen 8080 End Sub Private Sub m_oServer_ConnectionRequest(Client As cWinsock, ByRef DisConnect As Boolean) Debug.Print "新客户端连接: " & Client.RemoteHostIP ' DisConnect = False 表示接受连接 End Sub Private Sub m_oServer_DataArrival(Client As cWinsock, ByVal bytesTotal As Long) Dim sData As String Client.GetData sData Debug.Print "来自客户端 " & Client.ClientId & " 的数据: " & sData ' 回显 Client.SendData "Echo: " & sData End Sub Private Sub m_oServer_CloseEvent(Client As cWinsock) Debug.Print "客户端断开: " & Client.ClientId End Sub Private Sub Form_Unload(Cancel As Integer) m_oServer.Close_ End Sub ``` ### UDP 通信示例 ```vb Private WithEvents m_oUdp As cWinsock Private Sub Form_Load() Set m_oUdp = New cWinsock m_oUdp.Protocol = sckUDPProtocol m_oUdp.Bind 8888 End Sub Private Sub cmdSend_Click() m_oUdp.RemoteHost = "127.0.0.1" m_oUdp.RemotePort = 9999 m_oUdp.SendData "Hello, UDP!" End Sub Private Sub m_oUdp_DataArrival(Client As cWinsock, ByVal bytesTotal As Long) Dim sData As String Client.GetData sData Debug.Print "收到 UDP 数据 (" & Client.RemoteHostIP & ":" & Client.RemotePort & "): " & sData End Sub ``` *** ## 架构设计 ### 类层次结构 ``` cWinsock (公开类) ├── m_oSocket: cTlsSocket (内部封装，支持 TLS) ├── m_cClients: Collection (客户端集合) ├── m_oParentServer: cWinsock (父服务器引用，仅客户端) ├── m_oPacketProtocol: cPacketProtocol (封包协议处理器) ├── m_oHeartbeat: cHeartbeat (心跳管理器，内嵌 cTimer) └── 事件：Connect, CloseEvent, ConnectionRequest, DataArrival, MessageArrival, SendProgress, SendComplete, Error, ClientTimeout, HeartbeatSent, ServerCertificateVerify ``` ### 子模块类 | 类名 | 文件 | 职责 | |------|------|------| | `cPacketProtocol` | `cPacketProtocol.cls` | 数据封包协议：分隔符/定长/长度头，解决TCP分包粘包 | | `cHeartbeat` | `cHeartbeat.cls` | 心跳管理：内嵌 cTimer 自动驱动，超时检测，心跳保活 | ### 对象关系图 ``` 服务器对象 ├── Socket (监听套接字) ├── Clients 集合 │ ├── 客户端对象 1 (cWinsock) │ │ ├── Socket (独立连接) │ │ └── ParentServer → 服务器对象 │ ├── 客户端对象 2 (cWinsock) │ │ ├── Socket (独立连接) │ │ └── ParentServer → 服务器对象 │ └── ... └── 事件处理器 └── 所有客户端数据通过此触发 ``` ### 状态机 ``` sckClosed (0) ├─ Connect() → sckResolvingHost → sckHostResolved → sckConnecting → sckConnected (7) ├─ Listen() → sckListening (2) └─ Bind() → sckOpen (1) sckListening (2) └─ OnAccept → 创建客户端 → sckConnected sckConnected (7) └─ OnClose → sckClosed Error → sckError (9) ``` *** ## 文档索引 | 文档 | 描述 | |------|------| | [分包协议与心跳机制](./packet-protocol.md) | 分包协议、心跳机制详细说明和完整示例 | | [事件详解](./events.md) | 所有事件的详细说明和使用示例 | | [属性参考](./properties.md) | 所有属性的说明、类型和用途 | | [方法参考](./methods.md) | 所有方法的参数、返回值和使用示例 | | [编码指南](./encoding.md) | 文本编码的使用说明和最佳实践 | | [TCP编程](./tcp.md) | TCP 客户端和服务器编程指南 | | [UDP编程](./udp.md) | UDP 通信编程指南 | | [最佳实践](./best-practices.md) | 常见场景的解决方案和性能优化建议 | | [TLS/SSL 支持](./tls.md) | TLS 加密通信的配置和使用说明 | | [证书模式详解](../tls/overview.md) | 三种证书来源（文件/Windows存储/内存）的详细介绍 | | [开发计划](./roadmap.md) | 项目开发进度跟踪和未来功能规划 | *** ## 许可证 基于 VbAsyncSocket (wqweto@gmail.com) 开发 *** ## 作者 **cWinsock**: woeoio@qq.com\ **VbAsyncSocket**: wqweto@gmail.com *** **最后更新**: 2026-06-09 --- --- url: /zh/vbman/winsock/events.md --- # cWinsock 事件详解 ## 📋 事件列表 | 事件名 | 说明 | 触发时机 | |--------|------|----------| | `Connect` | 客户端连接成功 | TCP 客户端成功连接到服务器 | | `CloseEvent` | 连接关闭 | TCP 连接被关闭 | | `ConnectionRequest` | 新连接请求 | 服务器收到新的连接请求 | | `DataArrival` | 数据到达 | 接收到新数据 | | `MessageArrival` | 完整消息到达 | 协议解析后的完整消息到达（仅设置 PacketProtocol 时触发） | | `SendProgress` | 发送进度 | 数据发送过程中触发 | | `SendComplete` | 发送完成 | 数据发送完成 | | `Error` | 发生错误 | 发生 Socket 错误 | | `ClientTimeout` | 客户端超时 | 服务端检测到客户端空闲超时 | | `HeartbeatSent` | 心跳已发送 | 客户端心跳包已发送 | *** ## 🔗 Connect 事件 ### 说明 当 TCP 客户端成功连接到服务器时触发。 ### 语法 ```vb Private Sub object_Connect(Client As cWinsock) ``` ### 参数 | 参数 | 类型 | 说明 | |------|------|------| | `Client` | cWinsock | 触发事件的客户端对象（即 Me） | ### 使用示例 ```vb Private WithEvents m_oClient As cWinsock Private Sub m_oClient_Connect(Client As cWinsock) Debug.Print "已连接到服务器" Debug.Print "远程地址: " & Client.RemoteHostIP Debug.Print "远程端口: " & Client.RemotePort ' 连接成功后发送登录请求 Client.SendData "LOGIN|user|password" End Sub ``` *** ## 🚪 CloseEvent 事件 ### 说明 当 TCP 连接被关闭时触发。 ### 语法 ```vb Private Sub object_CloseEvent(Client As cWinsock) ``` ### 参数 | 参数 | 类型 | 说明 | |------|------|------| | `Client` | cWinsock | 触发事件的客户端对象 | ### 重要说明 对于服务器接受的客户端，`CloseEvent` 触发时会自动： 1. 从服务器的 `Clients` 集合中移除该客户端 2. 清理相关资源 ### 使用示例 ```vb Private Sub m_oClient_CloseEvent(Client As cWinsock) Debug.Print "连接已关闭" ' 可以在这里尝试重连 If m_bAutoReconnect Then Debug.Print "3 秒后尝试重连..." tmrReconnect.Enabled = True End If End Sub ``` **服务器端示例：** ```vb Private Sub m_oServer_CloseEvent(Client As cWinsock) Debug.Print "客户端 " & Client.Tag & " 已断开连接" ' 更新 UI Dim i As Long For i = 0 To lstClients.ListCount - 1 If lstClients.List(i) = Client.Tag Then lstClients.RemoveItem i Exit For End If Next ' 更新统计 UpdateClientCount End Sub ``` *** ## 🔔 ConnectionRequest 事件 ### 说明 服务器收到新的连接请求时触发。支持通过 `DisConnect` 参数拦截连接。 ### 语法 ```vb Private Sub object_ConnectionRequest(Client As cWinsock, ByRef DisConnect As Boolean) ``` ### 参数 | 参数 | 类型 | 说明 | |------|------|------| | `Client` | cWinsock | 新的客户端对象 | | `DisConnect` | Boolean | 设置为 `True` 可拒绝连接并清理资源 | ### 连接拦截机制 ```vb Private Sub m_oServer_ConnectionRequest(Client As cWinsock, ByRef DisConnect As Boolean) ' 默认接受连接（DisConnect = False） ' 1. IP 黑名单检查 If IsInBlacklist(Client.RemoteHostIP) Then Debug.Print "拒绝黑名单 IP: " & Client.RemoteHostIP DisConnect = True Exit Sub End If ' 2. 端口范围限制 If Client.RemotePort < 1024 Then Debug.Print "拒绝特权端口: " & Client.RemotePort DisConnect = True Exit Sub End If ' 3. 白名单模式 If m_bWhitelistMode Then If Not IsInWhitelist(Client.RemoteHostIP) Then Debug.Print "IP 不在白名单中: " & Client.RemoteHostIP DisConnect = True Exit Sub End If End If ' 4. 连接数限制 If m_oServer.ClientCount >= m_lMaxClients Then Debug.Print "达到最大连接数限制" DisConnect = True Exit Sub End If ' 接受连接 Debug.Print "接受新客户端: " & Client.RemoteHostIP & ":" & Client.RemotePort DisConnect = False End Sub ``` ### 高级示例：动态白名单 ```vb Private Sub m_oServer_ConnectionRequest(Client As cWinsock, ByRef DisConnect As Boolean) ' 从数据库或配置文件加载白名单 Dim sWhitelist() As String sWhitelist = LoadWhitelistFromDatabase() Dim bAllowed As Boolean bAllowed = False Dim i As Long For i = LBound(sWhitelist) To UBound(sWhitelist) If sWhitelist(i) = Client.RemoteHostIP Then bAllowed = True Exit For End If Next If Not bAllowed Then Debug.Print "拒绝未授权 IP: " & Client.RemoteHostIP DisConnect = True End If End Sub ``` ### TCP vs UDP 中的触发 | 协议 | 触发时机 | |------|----------| | TCP | 收到新的连接请求（`accept` 系统调用） | | UDP | 首次收到来自新地址:端口的数据包 | *** ## 📨 DataArrival 事件 ### 说明 当接收到新数据时触发。**这是最常用的事件之一**。 ### 语法 ```vb Private Sub object_DataArrival(Client As cWinsock, ByVal bytesTotal As Long) ``` ### 参数 | 参数 | 类型 | 说明 | |------|------|------| | `Client` | cWinsock | 接收数据的客户端对象 | | `bytesTotal` | Long | 可用数据字节数 | ### 基本使用 ```vb Private Sub m_oServer_DataArrival(Client As cWinsock, ByVal bytesTotal As Long) Dim sData As String ' 读取字符串数据 Client.GetData sData Debug.Print "收到 " & bytesTotal & " 字节: " & sData ' 处理数据... ProcessData Client, sData End Sub ``` ### 读取字节数组 ```vb Private Sub m_oClient_DataArrival(Client As cWinsock, ByVal bytesTotal As Long) Dim baData() As Byte ' 读取字节数组 Client.GetData baData Debug.Print "收到 " & bytesTotal & " 字节数据" ' 处理二进制数据... ProcessBinaryData baData End Sub ``` ### 部分读取数据 ```vb Private Sub m_oServer_DataArrival(Client As cWinsock, ByVal bytesTotal As Long) Dim sHeader As String Dim sBody As String ' 先读取前 10 字节作为头部 Client.GetData sHeader, vbString, 10 Debug.Print "头部: " & sHeader ' 读取剩余数据（仍在缓冲区中） Client.GetData sBody Debug.Print "正文: " & sBody End Sub ``` ### 指定编码读取 ```vb Private Sub m_oClient_DataArrival(Client As cWinsock, ByVal bytesTotal As Long) Dim sData As String ' 使用 UTF-8 编码读取 Client.GetData sData, vbString, -1, ucsScpUtf8 Debug.Print "UTF-8 数据: " & sData End Sub ``` ### 事件代理机制 **重要：** 服务器接受的客户端对象，其 `DataArrival` 事件会通过父服务器对象触发。 ```vb ' 只需订阅服务器的事件，即可处理所有客户端的数据 Private WithEvents m_oServer As cWinsock Private Sub m_oServer_DataArrival(Client As cWinsock, ByVal bytesTotal As Long) ' Client 参数就是具体的客户端对象 Debug.Print "来自 " & Client.Tag & " 的数据" Dim sData As String Client.GetData sData ' 可以直接向该客户端回复 Client.SendData "Echo: " & sData End Sub ``` *** ## 📊 SendProgress 事件 ### 说明 数据发送过程中定期触发，用于显示发送进度。 ### 语法 ```vb Private Sub object_SendProgress(Client As cWinsock, ByVal bytesSent As Long, ByVal bytesRemaining As Long) ``` ### 参数 | 参数 | 类型 | 说明 | |------|------|------| | `Client` | cWinsock | 发送数据的客户端对象 | | `bytesSent` | Long | 已发送的字节数 | | `bytesRemaining` | Long | 剩余待发送的字节数 | ### 使用示例 ```vb Private Sub m_oClient_SendProgress(Client As cWinsock, ByVal bytesSent As Long, ByVal bytesRemaining As Long) Dim lTotal As Long lTotal = bytesSent + bytesRemaining Dim dPercent As Double dPercent = (bytesSent / lTotal) * 100 Debug.Print "发送进度: " & Format$(dPercent, "0.00") & "% (" & bytesSent & "/" & lTotal & ")" ' 更新进度条 If Not prgProgress Is Nothing Then prgProgress.Value = CInt(dPercent) End If End Sub ``` ### 实际应用：文件传输进度 ```vb Private Sub m_oClient_SendProgress(Client As cWinsock, ByVal bytesSent As Long, ByVal bytesRemaining As Long) Static lStartTime As Long Static lLastUpdate As Long If lStartTime = 0 Then lStartTime = Timer If lLastUpdate = 0 Then lLastUpdate = lStartTime ' 每 0.5 秒更新一次 UI If Timer - lLastUpdate >= 0.5 Then Dim lTotal As Long lTotal = bytesSent + bytesRemaining Dim dElapsed As Double dElapsed = Timer - lStartTime Dim dSpeed As Double dSpeed = bytesSent / dElapsed ' 字节/秒 ' 更新 UI lblStatus.Caption = "发送中: " & FormatSize(bytesSent) & " / " & FormatSize(lTotal) lblSpeed.Caption = "速度: " & FormatSize(dSpeed) & "/s" lLastUpdate = Timer End If End Sub ``` *** ## ✅ SendComplete 事件 ### 说明 数据发送完成时触发。 ### 语法 ```vb Private Sub object_SendComplete(Client As cWinsock) ``` ### 参数 | 参数 | 类型 | 说明 | |------|------|------| | `Client` | cWinsock | 发送完成的客户端对象 | ### 使用示例 ```vb Private Sub m_oClient_SendComplete(Client As cWinsock) Debug.Print "数据发送完成" ' 重置发送状态 m_bSending = False ' 更新 UI cmdSend.Enabled = True lblStatus.Caption = "就绪" End Sub ``` ### 实际应用：命令队列 ```vb Private m_lCommandQueue() As String Private m_lQueueIndex As Long Private Sub SendNextCommand() If m_lQueueIndex <= UBound(m_lCommandQueue) Then m_oClient.SendData m_lCommandQueue(m_lQueueIndex) m_lQueueIndex = m_lQueueIndex + 1 End If End Sub Private Sub m_oClient_SendComplete(Client As cWinsock) Debug.Print "命令发送完成，发送下一个..." SendNextCommand End Sub ``` *** ## ❌ Error 事件 ### 说明 发生 Socket 错误时触发。 ### 语法 ```vb Private Sub object_Error(Client As cWinsock, ByVal Number As Long, Description As String, ByVal Scode As Long) ``` ### 参数 | 参数 | 类型 | 说明 | |------|------|------| | `Client` | cWinsock | 发生错误的客户端对象 | | `Number` | Long | 错误代码 | | `Description` | String | 错误描述 | | `Scode` | Long | SCODE（通常与 Number 相同） | ### 常见错误代码 | 错误代码 | 说明 | |----------|------| | 10053 | 连接被远程主机强制关闭 | | 10054 | 远程主机关闭了连接 | | 10060 | 连接超时 | | 10061 | 连接被拒绝 | | 10065 | 无法到达目标主机 | | 10048 | 地址已被使用 | ### 使用示例 ```vb Private Sub m_oClient_Error(Client As cWinsock, ByVal Number As Long, Description As String, ByVal Scode As Long) Debug.Print "Socket 错误 [" & Number & "]: " & Description Select Case Number Case 10053, 10054 ' 连接被关闭 Debug.Print "远程主机已断开连接" Case 10060 ' 连接超时 Debug.Print "连接超时，请检查网络" Case 10061 ' 连接被拒绝 Debug.Print "服务器拒绝连接，请检查端口和防火墙" Case Else ' 其他错误 Debug.Print "未知错误: " & Description End Select End Sub ``` ### 错误恢复 ```vb Private Sub m_oServer_Error(Client As cWinsock, ByVal Number As Long, Description As String, ByVal Scode As Long) Debug.Print "服务器错误 [" & Number & "]: " & Description ' 移除出错的客户端 If Not Client Is Nothing Then m_oServer.RemoveClient Client End If ' 如果是严重错误，重启服务器 If Number >= 10000 Then Debug.Print "严重错误，重启服务器..." m_oServer.Close_ m_oServer.Listen m_lServerPort End If End Sub ``` *** ## 📨 MessageArrival 事件 ### 说明 当设置了封包协议（`PacketProtocol`）后，接收到完整协议帧消息时触发。与 `DataArrival` 不同，此事件仅在完整消息组装完毕后触发，不会因分包/粘包而触发多次。 ### 语法 ```vb Private Sub object_MessageArrival(Client As cWinsock, ByVal bytesTotal As Long) ``` ### 参数 | 参数 | 类型 | 说明 | |------|------|------| | `Client` | cWinsock | 接收消息的客户端对象 | | `bytesTotal` | Long | 完整消息的字节数 | ### 使用示例 ```vb ' 设置分隔符协议 m_oServer.PacketProtocol = ppDelimiter m_oServer.Delimiter = vbCrLf ' 接收完整消息 Private Sub m_oServer_MessageArrival(Client As cWinsock, ByVal bytesTotal As Long) ' 此时缓冲区中已是完整消息，可直接读取 Dim sData As String sData = Client.GetDataText() Debug.Print "完整消息: " & sData End Sub ``` ### 与 DataArrival 的区别 | 事件 | 触发时机 | 数据完整性 | |------|----------|-----------| | `DataArrival` | 每次收到原始数据（无协议模式） | 可能是分片或粘包数据 | | `MessageArrival` | 协议解析出完整消息后（协议模式） | 保证是一条完整消息 | ### 事件触发规则 * **无协议**（`ppNone`）：仅触发 `DataArrival` * **有协议**：仅触发 `MessageArrival`，不触发 `DataArrival` 协议模式下不会同时触发两个事件，避免同一数据被重复读取。 *** ## 💓 ClientTimeout 事件 ### 说明 服务端检测到客户端空闲时间超过 `HeartbeatTimeout` 时触发。触发后客户端会被自动断开并移除。 ### 语法 ```vb Private Sub object_ClientTimeout(Client As cWinsock) ``` ### 参数 | 参数 | 类型 | 说明 | |------|------|------| | `Client` | cWinsock | 超时的客户端对象 | ### 使用示例 ```vb ' 启用服务器心跳 m_oServer.AutoHeartbeat = True m_oServer.HeartbeatTimeout = 120 ' 2分钟无活动则超时 Private Sub m_oServer_ClientTimeout(Client As cWinsock) Debug.Print "客户端超时: " & Client.Tag & " (" & Client.RemoteHostIP & ")" ' 客户端已被自动断开，可做清理（如更新UI、记录日志等） UpdateClientList End Sub ``` ### 工作原理 1. 心跳管理器内嵌 `cTimer`，每 10 秒触发一次 Tick 2. 每次 Tick 检查所有客户端的 `IdleSeconds` 3. 如果 `IdleSeconds >= HeartbeatTimeout`，触发 `ClientTimeout` 事件并自动断开 4. 每次收发数据自动重置 `LastActivityTime` *** ## 💓 HeartbeatSent 事件 ### 说明 客户端发送心跳包后触发。仅在 `AutoHeartbeat = True` 且客户端模式时触发。 ### 语法 ```vb Private Sub object_HeartbeatSent(Client As cWinsock) ``` ### 参数 | 参数 | 类型 | 说明 | |------|------|------| | `Client` | cWinsock | 发送心跳的客户端对象 | ### 使用示例 ```vb ' 客户端启用心跳 m_oClient.AutoHeartbeat = True m_oClient.HeartbeatInterval = 50 ' 50秒无活动则发心跳 Private Sub m_oClient_HeartbeatSent(Client As cWinsock) Debug.Print "心跳已发送，当前空闲: " & Client.IdleSeconds & "秒" End Sub ``` ### 智能跳过 心跳具有智能跳过机制：如果在上次心跳后有数据收发（`LastActivityTime` 被更新），且空闲时间未达到 `HeartbeatInterval`，则跳过本次心跳。这避免了不必要的网络流量。 *** ## 🎯 事件触发顺序 ### TCP 客户端连接流程 ``` 1. Connect() 调用 2. 内部解析主机名 3. Connect 事件触发 4. 可以开始发送数据 5. SendProgress 事件（多次） 6. SendComplete 事件触发 7. DataArrival 事件（接收数据） 8. CloseEvent 事件（连接关闭） ``` ### TCP 服务器接受连接流程 ``` 1. Listen() 调用 2. 收到新连接请求 3. ConnectionRequest 事件触发（可拦截） 4. 如果接受，创建客户端对象（自动继承协议和心跳配置） 5. 客户端 DataArrival 事件（通过服务器触发） 6. 客户端 MessageArrival 事件（协议模式下，通过服务器触发） 7. ClientTimeout 事件（心跳超时，自动断开） 8. 客户端 CloseEvent 事件（断开时触发） ``` ### UDP 通信流程 ``` 1. Bind() 调用（UDP 服务器） 2. 收到数据包 3. 首次收到该地址:端口 → ConnectionRequest 事件 4. DataArrival 事件触发 5. 可以通过 SendData 回复 ``` *** ## 📌 注意事项 1. **事件处理时间** * 避免在事件处理中执行耗时操作 * 使用 `DoEvents` 释放控制权 * 或将耗时操作放入队列异步处理 2. **对象生命周期** * 不要在事件处理中 `Set Client = Nothing` * 客户端对象由服务器管理，自动清理 3. **线程安全** * 事件在主线程触发，可直接访问 UI * 但避免重入问题 4. **错误处理** * 总是使用 `On Error GoTo` 处理事件中的错误 * 防止一个客户端的错误影响其他客户端 *** **最后更新**: 2026-06-09 --- --- url: /zh/vbman/winsock/properties.md --- # cWinsock 属性参考 ## 📋 属性列表 | 属性名 | 类型 | 读写 | 说明 | |--------|------|------|------| | `State` | WinsockState | 只读 | 当前 Socket 状态 | | `Protocol` | WinsockProtocol | 读写 | 协议类型（TCP/UDP） | | `RecvBuffer` | Byte() | 读写 | 自定义接收缓冲区 | | `LocalPort` | Long | 读写 | 本地端口 | | `RemoteHost` | String | 读写 | 远程主机名 | | `RemotePort` | Long | 读写 | 远程端口 | | `RemoteHostIP` | String | 只读 | 解析后的远程 IP 地址 | | `LocalHostName` | String | 只读 | 本地主机名 | | `LocalIP` | String | 只读 | 本地 IP 地址 | | `Tag` | String | 读写 | 用户自定义标签（纯业务标识，内部不再使用） | | `ClientId` | Long | 只读 | 服务器分配的唯一连接标识（自增，不重复） | | `UserData` | Variant | 读写 | 用户自定义数据 | | `SocketHandle` | Long | 只读 | Socket 句柄 | | `BytesReceived` | Long | 只读 | 可用数据字节数 | | `IsServer` | Boolean | 只读 | 是否为服务器模式 | | `IsAcceptedClient` | Boolean | 只读 | 是否为服务器接受的客户端 | | `ParentServer` | cWinsock | 只读 | 父服务器对象（仅客户端） | | `Clients` | Collection | 只读 | 所有连接的客户端集合（仅服务器） | | `ClientCount` | Long | 只读 | 客户端连接数（仅服务器） | | `CurrentUser` | Variant | 读写 | 绑定的用户名（用户绑定功能） | | `CurrentUserToken` | String | 读写 | 用户认证令牌（用户绑定功能） | | `CurrentUserInfo` | cJson | 读写 | 用户扩展信息（用户绑定功能） | | `CountUsers` | Long | 只读 | 当前绑定的用户数量（用户绑定功能） | | `CountGroups` | Long | 只读 | 当前组数量（用户绑定功能） | | `PacketHandler` | cPacketProtocol | 读写 | 封包协议处理器对象（高级配置） | | `PacketProtocol` | PacketProtocolType | 读写 | 封包协议类型（快速设置） | | `Delimiter` | String | 读写 | 分隔符协议的分隔符（默认 vbCrLf） | | `FixedLength` | Long | 读写 | 定长协议的消息长度 | | `HeaderBytes` | Long | 读写 | 长度头协议的头字节数（2或4，默认4） | | `HeaderEndian` | EndianEnum | 读写 | 长度头协议的字节序（默认小端） | | `MaxPacketSize` | Long | 读写 | 单包最大字节数（默认1MB），防恶意超大包 | | `MaxBufferSize` | Long | 读写 | 缓冲区累积上限（默认4MB），防内存耗尽 | | `Heartbeat` | cHeartbeat | 只读 | 心跳管理器对象（高级配置） | | `AutoHeartbeat` | Boolean | 读写 | 启用/禁用自动心跳（内嵌 cTimer） | | `HeartbeatTimeout` | Long | 读写 | 服务端心跳超时秒数（默认120） | | `HeartbeatInterval` | Long | 读写 | 客户端心跳间隔秒数（默认50） | | `HeartbeatData` | Byte() | 读写 | 心跳包内容（默认单字节0） | | `IdleSeconds` | Long | 只读 | 当前空闲秒数 | *** ## 🔄 State 属性 ### 说明 返回当前 Socket 的状态。用户自定义标签，用于业务标识或分组。可自由读写，**内部管理不再依赖此属性**。 ### 语法 ```vb Property Get State() As WinsockState ``` ### 返回值 | 常量 | 值 | 说明 | |------|-----|------| | `sckClosed` | 0 | 已关闭 | | `sckOpen` | 1 | 已打开（UDP 绑定后） | | `sckListening` | 2 | 监听中（TCP 服务器） | | `sckConnectionPending` | 3 | 连接挂起 | | `sckResolvingHost` | 4 | 正在解析主机名 | | `sckHostResolved` | 5 | 主机名已解析 | | `sckConnecting` | 6 | 正在连接 | | `sckConnected` | 7 | 已连接 | | `sckClosing` | 8 | 正在关闭 | | `sckError` | 9 | 发生错误 | ### 使用示例 ```vb Private Sub cmdConnect_Click() If m_oClient.State = sckClosed Then m_oClient.Connect "127.0.0.1", 8080 Else MsgBox "Socket 未关闭，当前状态: " & GetStateName(m_oClient.State) End If End Sub Private Function GetStateName(ByVal eState As WinsockState) As String Select Case eState Case sckClosed: GetStateName = "已关闭" Case sckOpen: GetStateName = "已打开" Case sckListening: GetStateName = "监听中" Case sckConnected: GetStateName = "已连接" Case sckClosing: GetStateName = "关闭中" Case sckError: GetStateName = "错误" Case Else: GetStateName = "未知" End Select End Function ``` *** ## 🌐 Protocol 属性 ### 说明 获取或设置 Socket 使用的协议类型。用户自定义标签，用于业务标识或分组。可自由读写，**内部管理不再依赖此属性**。 ### 语法 ```vb Property Get Protocol() As WinsockProtocol Property Let Protocol(ByVal Value As WinsockProtocol) ``` ### 值 | 常量 | 值 | 说明 | |------|-----|------| | `sckTCPProtocol` | 1 | TCP 协议（可靠，面向连接） | | `sckUDPProtocol` | 2 | UDP 协议（不可靠，无连接） | ### 使用示例 ```vb ' 设置为 TCP 协议 m_oSocket.Protocol = sckTCPProtocol ' 设置为 UDP 协议 m_oSocket.Protocol = sckUDPProtocol ' 检查当前协议 If m_oSocket.Protocol = sckTCPProtocol Then Debug.Print "使用 TCP 协议" Else Debug.Print "使用 UDP 协议" End If ``` ### ⚠️ 注意事项 * 只能在 `State = sckClosed` 时修改 * 修改后需要重新调用 `Connect()`、`Listen()` 或 `Bind()` *** ## 📦 RecvBuffer 属性 ### 说明 设置或获取自定义接收缓冲区。通常用于高级场景。用户自定义标签，用于业务标识或分组。可自由读写，**内部管理不再依赖此属性**。 ### 语法 ```vb Property Let RecvBuffer(ByRef Value() As Byte) ``` ### 使用示例 ```vb ' 设置自定义缓冲区 Dim baCustomBuffer() As Byte ReDim baCustomBuffer(0 To 8191) ' 8KB 缓冲区 m_oSocket.RecvBuffer = baCustomBuffer ``` *** ## 🔌 LocalPort 属性 ### 说明 获取或设置本地端口号。用户自定义标签，用于业务标识或分组。可自由读写，**内部管理不再依赖此属性**。 ### 语法 ```vb Property Get LocalPort() As Long Property Let LocalPort(ByVal Value As Long) ``` ### 使用示例 ```vb ' 设置本地端口（必须在调用 Connect/Listen/Bind 之前） m_oServer.LocalPort = 8080 m_oServer.Listen ' 获取实际绑定的端口 Debug.Print "本地端口: " & m_oSocket.LocalPort ``` ### ⚠️ 注意事项 * 只能在 `State = sckClosed` 时设置 * 范围：0-65535 * 0 表示由系统自动分配 *** ## 🌍 RemoteHost 属性 ### 说明 获取或设置远程主机名（域名或 IP）。用户自定义标签，用于业务标识或分组。可自由读写，**内部管理不再依赖此属性**。 ### 语法 ```vb Property Get RemoteHost() As String Property Let RemoteHost(ByVal Value As String) ``` ### 使用示例 ```vb ' 设置远程主机（可以使用域名） m_oClient.RemoteHost = "example.com" m_oClient.RemotePort = 80 m_oClient.Connect ' 使用 IP 地址 m_oClient.RemoteHost = "192.168.1.100" m_oClient.RemotePort = 8080 m_oClient.Connect ' 获取远程主机名 Debug.Print "远程主机: " & m_oClient.RemoteHost ``` *** ## 🔢 RemotePort 属性 ### 说明 获取或设置远程端口号。用户自定义标签，用于业务标识或分组。可自由读写，**内部管理不再依赖此属性**。 ### 语法 ```vb Property Get RemotePort() As Long Property Let RemotePort(ByVal Value As Long) ``` ### 使用示例 ```vb ' 设置远程端口 m_oClient.RemotePort = 8080 ' 获取远程端口 Debug.Print "远程端口: " & m_oClient.RemotePort ``` *** ## 🖥️ RemoteHostIP 属性 ### 说明 获取解析后的远程 IP 地址（只读）。用户自定义标签，用于业务标识或分组。可自由读写，**内部管理不再依赖此属性**。 ### 语法 ```vb Property Get RemoteHostIP() As String ``` ### 使用示例 ```vb Private Sub m_oClient_Connect(Client As cWinsock) Debug.Print "连接成功!" Debug.Print "主机名: " & Client.RemoteHost Debug.Print "IP 地址: " & Client.RemoteHostIP Debug.Print "端口: " & Client.RemotePort End Sub ``` ### 特殊情况：UDP 服务器虚拟客户端 ```vb Private Sub m_oUdp_DataArrival(Client As cWinsock, ByVal bytesTotal As Long) ' UDP 服务器模式下，虚拟客户端的 RemoteHostIP 返回发送方 IP Debug.Print "收到来自 " & Client.RemoteHostIP & ":" & Client.RemotePort & " 的数据" End Sub ``` *** ## 💻 LocalHostName 属性 ### 说明 获取本地主机名。用户自定义标签，用于业务标识或分组。可自由读写，**内部管理不再依赖此属性**。 ### 语法 ```vb Property Get LocalHostName() As String ``` ### 使用示例 ```vb Debug.Print "本机名: " & m_oSocket.LocalHostName ``` *** ## 🌐 LocalIP 属性 ### 说明 获取本地 IP 地址。用户自定义标签，用于业务标识或分组。可自由读写，**内部管理不再依赖此属性**。 ### 语法 ```vb Property Get LocalIP() As String ``` ### 使用示例 ```vb Debug.Print "本机 IP: " & m_oSocket.LocalIP ``` *** ## 🏷️ Tag 属性 ### 说明 用户自定义标签，用于业务标识或分组。可自由读写，**内部管理不再依赖此属性**。用户自定义标签，用于业务标识或分组。可自由读写，**内部管理不再依赖此属性**。 ### 语法 ```vb Property Get Tag() As String Property Let Tag(ByVal Value As String) ``` ### 使用示例 ```vb ' 在 ConnectionRequest 中为客户端设置业务标签 Private Sub m_oServer_ConnectionRequest(Client As cWinsock, ByRef DisConnect As Boolean) Client.Tag = "客户端-" & Client.RemoteHostIP Debug.Print "新客户端 Tag: " & Client.Tag End Sub ' 通过 Tag 查找客户端（需自行遍历） Private Function FindClientByTag(ByVal sTag As String) As cWinsock Dim oClient As cWinsock For Each oClient In m_oServer.Clients If oClient.Tag = sTag Then Set FindClientByTag = oClient Exit Function End If Next Set FindClientByTag = Nothing End Function ``` *** ## 🆔 ClientId 属性 ### 说明 服务器分配的唯一连接标识（只读）。自增编号，从 `1` 开始，断开后不复用，不会重复。 * 服务器自身（Listen socket）的 `ClientId = 0`。 * TCP 和 UDP 客户端连接均自动分配。用户自定义标签，用于业务标识或分组。可自由读写，**内部管理不再依赖此属性**。 ### 语法 ```vb Property Get ClientId() As Long ``` ### 使用示例 ```vb ' 在 ConnectionRequest 或 DataArrival 中识别客户端 Private Sub m_oServer_ConnectionRequest(Client As cWinsock, ByRef DisConnect As Boolean) Debug.Print "新客户端接入，ID: " & Client.ClientId & " from " & Client.RemoteHostIP End Sub ' 用 ID 记录日志或做键值映射 Private Sub m_oServer_DataArrival(Client As cWinsock, ByVal bytesTotal As Long) Debug.Print "Client #" & Client.ClientId & " 发送了 " & bytesTotal & " 字节" End Sub ``` | 特性 | 说明 | |------|------| | 可读性 | `#1`, `#42` 一眼识别 | | 唯一性 | 单调递增，生命周期内不重复 | | 类型 | `Long`，便于比较和存储 | *** ## 💾 UserData 属性 ### 说明 用户自定义数据存储，可以存储任意类型的数据。用户自定义标签，用于业务标识或分组。可自由读写，**内部管理不再依赖此属性**。 ### 语法 ```vb Property Get UserData() As Variant Property Let UserData(ByVal Value As Variant) Property Set UserData(ByVal Value As Variant) ``` ### 使用示例 ```vb ' 存储字符串 m_oClient.UserData = "用户信息: 张三" ' 存储数字 m_oClient.UserData = 12345 ' 存储对象 Dim oUserInfo As New CUserInfo oUserInfo.Name = "张三" oUserInfo.Age = 25 Set m_oClient.UserData = oUserInfo ' 读取数据 Dim sInfo As String sInfo = m_oClient.UserData Debug.Print sInfo ' 读取对象 Dim oUserData As CUserInfo Set oUserData = m_oClient.UserData Debug.Print oUserInfo.Name & ", " & oUserData.Age ``` ### 高级用法：客户端会话数据 ```vb Private Type tSessionData LoginTime As Date LastActivity As Date LoginAttempts As Long Authenticated As Boolean End Type Private Sub m_oServer_ConnectionRequest(Client As cWinsock, ByRef DisConnect As Boolean) Dim tSession As tSessionData tSession.LoginTime = Now tSession.LastActivity = Now tSession.LoginAttempts = 0 tSession.Authenticated = False Client.UserData = tSession End Sub Private Sub CheckSessionTimeout() Dim oClient As cWinsock Dim tSession As tSessionData For Each oClient In m_oServer.Clients tSession = oClient.UserData If DateDiff("s", tSession.LastActivity, Now) > 300 Then ' 5 分钟无活动 Debug.Print "会话超时，断开 Client #" & oClient.ClientId oClient.Close_ End If Next End Sub ``` *** ## 🔑 SocketHandle 属性 ### 说明 获取底层的 Socket 句柄（只读）。用户自定义标签，用于业务标识或分组。可自由读写，**内部管理不再依赖此属性**。 ### 语法 ```vb Property Get SocketHandle() As Long ``` ### 使用示例 ```vb ' 获取 Socket 句柄 Debug.Print "Socket 句柄: " & m_oSocket.SocketHandle ' 用于高级操作（如与 Win32 API 交互） If m_oSocket.SocketHandle <> 0 Then Call SomeWin32Function(m_oSocket.SocketHandle) End If ``` *** ## 📊 BytesReceived 属性 ### 说明 获取接收缓冲区中可用的字节数（只读）。用户自定义标签，用于业务标识或分组。可自由读写，**内部管理不再依赖此属性**。 ### 语法 ```vb Property Get BytesReceived() As Long ``` ### 使用示例 ```vb Private Sub m_oClient_DataArrival(Client As cWinsock, ByVal bytesTotal As Long) Debug.Print "事件通知: " & bytesTotal & " 字节" Debug.Print "缓冲区总计: " & Client.BytesReceived & " 字节" ' 只读取部分数据 If Client.BytesReceived > 100 Then Dim sData As String Client.GetData sData, vbString, 100 ' 只读取前 100 字节 Debug.Print "读取了部分数据: " & sData End If End Sub ``` *** ## 🏢 IsServer 属性 ### 说明 判断当前对象是否为服务器模式（只读）。用户自定义标签，用于业务标识或分组。可自由读写，**内部管理不再依赖此属性**。 ### 语法 ```vb Property Get IsServer() As Boolean ``` ### 使用示例 ```vb Private Sub m_oServer_DataArrival(Client As cWinsock, ByVal bytesTotal As Long) If Client.IsServer Then Debug.Print "来自服务器的数据" Else Debug.Print "来自客户端的数据" End If End Sub ``` *** ## 🔗 IsAcceptedClient 属性 ### 说明 判断当前对象是否为服务器接受的客户端（只读）。用户自定义标签，用于业务标识或分组。可自由读写，**内部管理不再依赖此属性**。 ### 语法 ```vb Property Get IsAcceptedClient() As Boolean ``` ### 使用示例 ```vb Private Sub SomeFunction(oSocket As cWinsock) If oSocket.IsAcceptedClient Then Debug.Print "这是服务器接受的客户端" Debug.Print "父服务器: " & oSocket.ParentServer.Tag Else Debug.Print "这是独立客户端或服务器对象" End If End Sub ``` *** ## 👆 ParentServer 属性 ### 说明 获取父服务器对象（仅对服务器接受的客户端有效）。用户自定义标签，用于业务标识或分组。可自由读写，**内部管理不再依赖此属性**。 ### 语法 ```vb Property Get ParentServer() As cWinsock ``` ### 使用示例 ```vb Private Sub m_oServer_ConnectionRequest(Client As cWinsock, ByRef DisConnect As Boolean) ' 服务器设置 ParentServer ' 客户端可以访问父服务器 Debug.Print "新客户端的父服务器: " & Client.ParentServer.Tag End Sub ``` ### 高级用法：客户端广播消息 ```vb ' 在某个客户端的事件中，通过父服务器向其他客户端广播 Private Sub ClientBroadcastToOthers(ByVal oSender As cWinsock, ByVal sMessage As String) Dim oClient As cWinsock For Each oClient In oSender.ParentServer.Clients If Not oClient Is oSender Then ' 不发送给自己 oClient.SendData sMessage End If Next End Sub ``` *** ## 👥 Clients 属性 ### 说明 获取所有连接的客户端集合（仅对服务器对象有效）。用户自定义标签，用于业务标识或分组。可自由读写，**内部管理不再依赖此属性**。 ### 语法 ```vb Property Get Clients() As Collection ``` ### 使用示例 ```vb ' 遍历所有客户端 Private Sub ListAllClients() Debug.Print "当前连接数: " & m_oServer.ClientCount Dim oClient As cWinsock For Each oClient In m_oServer.Clients Debug.Print oClient.Tag & ": " & oClient.RemoteHostIP & ":" & oClient.RemotePort Next End Sub ' 查找特定客户端 Private Function FindClientByIP(ByVal sIP As String) As cWinsock Dim oClient As cWinsock For Each oClient In m_oServer.Clients If oClient.RemoteHostIP = sIP Then Set FindClientByIP = oClient Exit Function End If Next Set FindClientByIP = Nothing End Function ' 向所有客户端广播 Private Sub BroadcastToAll(ByVal sMessage As String) Dim oClient As cWinsock For Each oClient In m_oServer.Clients On Error Resume Next oClient.SendData sMessage On Error GoTo 0 Next End Sub ``` *** ## 🔢 ClientCount 属性 ### 说明 获取当前连接的客户端数量（只读，仅对服务器对象有效）。用户自定义标签，用于业务标识或分组。可自由读写，**内部管理不再依赖此属性**。 ### 语法 ```vb Property Get ClientCount() As Long ``` ### 使用示例 ```vb ' 显示连接数 lblClientCount.Caption = "当前连接: " & m_oServer.ClientCount ' 限制最大连接数 Private Sub m_oServer_ConnectionRequest(Client As cWinsock, ByRef DisConnect As Boolean) If m_oServer.ClientCount >= m_lMaxClients Then Debug.Print "达到最大连接数限制: " & m_lMaxClients DisConnect = True End If End Sub ``` *** ## 👤 CurrentUser 属性 ### 说明 获取或设置绑定的用户名（用于用户绑定功能）。当使用 `BindUser` 方法绑定用户后，该属性自动设置为用户名。用户自定义标签，用于业务标识或分组。可自由读写，**内部管理不再依赖此属性**。 ### 语法 ```vb Public CurrentUser As Variant ``` ### 使用示例 ```vb ' 客户端连接时绑定用户 Private Sub m_oServer_DataArrival(Client As cWinsock, ByVal bytesTotal As Long) Dim sData As String Client.GetData sData If Left$(sData, 6) = "LOGIN:" Then Dim sUsername As String sUsername = Mid$(sData, 7) ' 绑定用户 m_oServer.BindUser sUsername, Client ' 验证绑定成功 Debug.Print "Client.CurrentUser = " & Client.CurrentUser End If End Sub ' 检查用户是否已登录 Private Sub CheckUserLogin(ByVal oClient As cWinsock) If LenB(CStr(oClient.CurrentUser)) = 0 Then Debug.Print "用户未登录" Else Debug.Print "当前用户: " & oClient.CurrentUser End If End Sub ``` ### 与 Tag 属性的区别 | 属性 | 用途 | 设置方式 | |------|------|----------| | `Tag` | 用户自定义业务标识 | 手动设置 | | `ClientId` | 系统分配的连接编号 | 服务器自动分配 | | `CurrentUser` | 标识登录用户 | 通过 `BindUser` 绑定 | ### 自动清理 当客户端断开连接时（调用 `Close_` 或对象销毁），系统会自动解绑用户，无需手动处理。 *** ## 🔑 CurrentUserToken 属性 ### 说明 获取或设置用户认证令牌（用于用户绑定功能）。当使用 `BindUser` 方法绑定用户时传入 `Token` 参数，该属性自动设置为对应值。用户自定义标签，用于业务标识或分组。可自由读写，**内部管理不再依赖此属性**。 ### 语法 ```vb Public CurrentUserToken As String ``` ### 使用示例 ```vb ' 绑定用户时传入 Token m_oServer.BindUser "alice", Client, "jwt_token_xyz123" ' 后续验证 Token If Client.CurrentUserToken = "jwt_token_xyz123" Then Debug.Print "Token 验证通过" End If ' 获取当前用户的 Token Debug.Print "用户 " & Client.CurrentUser & " 的 Token: " & Client.CurrentUserToken ``` *** ## 📋 CurrentUserInfo 属性 ### 说明 获取或设置用户扩展信息（用于用户绑定功能）。当使用 `BindUser` 方法绑定用户时传入 `Info` 参数（cJson 对象），该属性自动设置为对应值。可用于存储用户的额外元数据，如登录时间、IP 地址、权限等级等。用户自定义标签，用于业务标识或分组。可自由读写，**内部管理不再依赖此属性**。 ### 语法 ```vb Public CurrentUserInfo As cJson ``` ### 使用示例 ```vb ' 绑定用户时传入扩展信息 Dim oInfo As New cJson oInfo.Add "loginTime", Now oInfo.Add "ip", Client.RemoteHostIP oInfo.Add "role", "admin" m_oServer.BindUser "alice", Client, , oInfo ' 读取用户扩展信息 Debug.Print "登录时间: " & Client.CurrentUserInfo.Item("loginTime") Debug.Print "角色: " & Client.CurrentUserInfo.Item("role") ' 动态添加信息 Client.CurrentUserInfo.Add "lastActivity", Now ``` ### 与 UserData 的区别 | 属性 | 用途 | 生命周期 | |------|------|----------| | `UserData` | 通用自定义数据存储 | 由用户手动管理 | | `CurrentUserInfo` | 用户绑定的结构化信息（JSON） | 随 `BindUser`/`UnbindUser` 自动管理 | *** ## 🔢 CountUsers 属性 ### 说明 获取当前已绑定用户的数量（只读）。通过 `BindUser` 方法绑定的用户会计入此计数。用户自定义标签，用于业务标识或分组。可自由读写，**内部管理不再依赖此属性**。 ### 语法 ```vb Property Get CountUsers() As Long ``` ### 使用示例 ```vb ' 显示当前绑定用户数 Debug.Print "当前绑定用户数: " & m_oServer.CountUsers ' 监控用户登录状态 Private Sub UpdateUserCount() lblUserCount.Caption = "在线用户: " & m_oServer.CountUsers End Sub ' 在 DataArrival 中检查 Private Sub m_oServer_DataArrival(Client As cWinsock, ByVal bytesTotal As Long) Debug.Print "当前绑定用户总数: " & m_oServer.CountUsers End Sub ``` *** ## 👥 CountGroups 属性 ### 说明 获取当前已创建的组数量（只读）。通过 `AddGroup` 方法创建的组会计入此计数。用户自定义标签，用于业务标识或分组。可自由读写，**内部管理不再依赖此属性**。 ### 语法 ```vb Property Get CountGroups() As Long ``` ### 使用示例 ```vb ' 显示当前组数量 Debug.Print "当前组数量: " & m_oServer.CountGroups ' 初始化时创建默认组 Private Sub InitializeGroups() If m_oServer.CountGroups = 0 Then m_oServer.AddGroup "Default" m_oServer.AddGroup "Admins" End If End Sub ``` *** ## 📦 PacketHandler 属性 ### 说明 获取或设置封包协议处理器对象。每个 cWinsock 实例持有独立的协议实例，多客户端互不干扰。用户自定义标签，用于业务标识或分组。可自由读写，**内部管理不再依赖此属性**。 ### 语法 ```vb Property Get PacketHandler() As cPacketProtocol Property Set PacketHandler(ByVal Value As cPacketProtocol) ``` ### 使用示例 ```vb ' 高级配置：直接操作协议对象 Dim oProtocol As cPacketProtocol Set oProtocol = New cPacketProtocol oProtocol.ProtocolType = ppLengthHeader oProtocol.HeaderBytes = 4 oProtocol.Endian = eeBigEndian Set m_oServer.PacketHandler = oProtocol ``` *** ## 📦 PacketProtocol 属性 ### 说明 快速设置封包协议类型。设置后自动创建协议处理器（如果不存在）。设为 `ppNone` 则禁用协议。用户自定义标签，用于业务标识或分组。可自由读写，**内部管理不再依赖此属性**。 ### 语法 ```vb Property Get PacketProtocol() As PacketProtocolType Property Let PacketProtocol(ByVal Value As PacketProtocolType) ``` ### 值 | 常量 | 值 | 说明 | |------|-----|------| | `ppNone` | 0 | 无协议（默认） | | `ppDelimiter` | 1 | 字符分隔符协议 | | `ppFixedLength` | 2 | 定长协议 | | `ppLengthHeader` | 3 | 长度头协议 | ### 使用示例 ```vb ' 设置分隔符协议 m_oServer.PacketProtocol = ppDelimiter m_oServer.Delimiter = vbCrLf ' 设置长度头协议 m_oServer.PacketProtocol = ppLengthHeader m_oServer.HeaderBytes = 4 ' 禁用协议 m_oServer.PacketProtocol = ppNone ``` *** ## 📦 Delimiter 属性 ### 说明 设置或获取字符分隔符协议的分隔符。默认为 `vbCrLf`。仅在 `PacketProtocol = ppDelimiter` 时有效。用户自定义标签，用于业务标识或分组。可自由读写，**内部管理不再依赖此属性**。 ### 语法 ```vb Property Get Delimiter() As String Property Let Delimiter(ByVal Value As String) ``` ### 使用示例 ```vb ' 使用换行符作为分隔符（适合文本行协议） m_oServer.PacketProtocol = ppDelimiter m_oServer.Delimiter = vbCrLf ' 使用空字符作为分隔符（适合二进制文本混合协议） m_oServer.Delimiter = vbNullChar ' 使用自定义分隔符 m_oServer.Delimiter = "" ``` *** ## 📦 FixedLength 属性 ### 说明 设置或获取定长协议的消息长度。仅在 `PacketProtocol = ppFixedLength` 时有效。用户自定义标签，用于业务标识或分组。可自由读写，**内部管理不再依赖此属性**。 ### 语法 ```vb Property Get FixedLength() As Long Property Let FixedLength(ByVal Value As Long) ``` ### 使用示例 ```vb ' 每条消息固定 256 字节 m_oServer.PacketProtocol = ppFixedLength m_oServer.FixedLength = 256 ``` *** ## 📦 HeaderBytes 属性 ### 说明 设置或获取长度头协议的头字节数。2 表示使用 Integer（最大 65535 字节），4 表示使用 Long。默认为 4。仅在 `PacketProtocol = ppLengthHeader` 时有效。用户自定义标签，用于业务标识或分组。可自由读写，**内部管理不再依赖此属性**。 ### 语法 ```vb Property Get HeaderBytes() As Long Property Let HeaderBytes(ByVal Value As Long) ``` ### 值 | 值 | 说明 | 最大消息长度 | |-----|------|------------| | 2 | 2字节头（Unsigned Integer） | 65,535 字节 | | 4 | 4字节头（Unsigned Long） | 2,147,483,647 字节 | ### 使用示例 ```vb ' 小消息用2字节头节省带宽 m_oServer.PacketProtocol = ppLengthHeader m_oServer.HeaderBytes = 2 ' 大消息用4字节头 m_oServer.HeaderBytes = 4 ``` *** ## 📦 HeaderEndian 属性 ### 说明 设置或获取长度头协议的字节序。默认为小端（`eeLittleEndian`）。仅在 `PacketProtocol = ppLengthHeader` 时有效。用户自定义标签，用于业务标识或分组。可自由读写，**内部管理不再依赖此属性**。 ### 语法 ```vb Property Get HeaderEndian() As EndianEnum Property Let HeaderEndian(ByVal Value As EndianEnum) ``` ### 值 | 常量 | 值 | 说明 | |------|-----|------| | `eeLittleEndian` | 0 | 小端序（默认，x86/x64） | | `eeBigEndian` | 1 | 大端序（网络字节序） | ### 使用示例 ```vb ' 与 Java/网络协议通信（通常用大端序） m_oServer.PacketProtocol = ppLengthHeader m_oServer.HeaderEndian = eeBigEndian ``` *** ## 📦 MaxPacketSize 属性 ### 说明 单包最大字节数限制。长度头协议解析时，如果声明的消息长度超过此值，直接报错丢弃。防止恶意超大包声明耗尽内存。用户自定义标签，用于业务标识或分组。可自由读写，**内部管理不再依赖此属性**。 ### 语法 ```vb Property Get MaxPacketSize() As Long Property Let MaxPacketSize(ByVal Value As Long) ``` ### 默认值 1MB（1048576 字节） ### 使用示例 ```vb ' 调整最大包限制 m_oServer.PacketProtocol = ppLengthHeader m_oServer.MaxPacketSize = 524288 ' 512KB ' 新客户端自动继承此配置 ``` ### 注意事项 * 仅对 `ppLengthHeader` 协议有效 * 超限时抛出明确错误信息 * 新客户端自动继承服务器的配置 *** ## 📦 MaxBufferSize 属性 ### 说明 接收缓冲区累积上限。Decode 合并缓冲区前检查，超过此值则报错丢弃。防止大量不完整包慢慢吃内存（如攻击者发送大量不完整包）。用户自定义标签，用于业务标识或分组。可自由读写，**内部管理不再依赖此属性**。 ### 语法 ```vb Property Get MaxBufferSize() As Long Property Let MaxBufferSize(ByVal Value As Long) ``` ### 默认值 4MB（4194304 字节） ### 使用示例 ```vb ' 调整缓冲区上限 m_oServer.PacketProtocol = ppLengthHeader m_oServer.MaxBufferSize = 8388608 ' 8MB ``` ### 注意事项 * 对所有协议类型有效 * 超限时抛出明确错误信息 * 新客户端自动继承服务器的配置 *** ## 💓 Heartbeat 属性 ### 说明 获取心跳管理器对象，用于高级配置。心跳管理器内嵌 `cTimer` 自动驱动，无需外部定时器。用户自定义标签，用于业务标识或分组。可自由读写，**内部管理不再依赖此属性**。 ### 语法 ```vb Property Get Heartbeat() As cHeartbeat ``` ### 使用示例 ```vb ' 高级配置 If Not m_oServer.Heartbeat Is Nothing Then Debug.Print "心跳已发送次数: " & m_oServer.Heartbeat.HeartbeatCount Debug.Print "定时器间隔: " & m_oServer.Heartbeat.TimerInterval & "ms" End If ``` *** ## 💓 AutoHeartbeat 属性 ### 说明 启用或禁用自动心跳。启用后内嵌 `cTimer` 自动驱动，无需外部定时器或 `PollHeartbeat()` 调用。用户自定义标签，用于业务标识或分组。可自由读写，**内部管理不再依赖此属性**。 ### 语法 ```vb Property Get AutoHeartbeat() As Boolean Property Let AutoHeartbeat(ByVal Value As Boolean) ``` ### 使用示例 ```vb ' 服务端：启用心跳检测 m_oServer.AutoHeartbeat = True m_oServer.HeartbeatTimeout = 120 ' 2分钟超时 ' 客户端：启用心跳保活 m_oClient.AutoHeartbeat = True m_oClient.HeartbeatInterval = 50 ' 50秒间隔 ' 禁用心跳 m_oServer.AutoHeartbeat = False ``` *** ## 💓 HeartbeatTimeout 属性 ### 说明 服务端心跳超时秒数。客户端空闲时间超过此值将被自动断开。默认 120 秒（2 分钟）。仅在服务器模式且 `AutoHeartbeat = True` 时有效。用户自定义标签，用于业务标识或分组。可自由读写，**内部管理不再依赖此属性**。 ### 语法 ```vb Property Get HeartbeatTimeout() As Long Property Let HeartbeatTimeout(ByVal Value As Long) ``` ### 使用示例 ```vb m_oServer.AutoHeartbeat = True m_oServer.HeartbeatTimeout = 180 ' 3分钟超时 ``` *** ## 💓 HeartbeatInterval 属性 ### 说明 客户端心跳间隔秒数。当空闲时间超过此值，客户端自动发送心跳包。默认 50 秒。仅在客户端模式且 `AutoHeartbeat = True` 时有效。用户自定义标签，用于业务标识或分组。可自由读写，**内部管理不再依赖此属性**。 ### 语法 ```vb Property Get HeartbeatInterval() As Long Property Let HeartbeatInterval(ByVal Value As Long) ``` ### 使用示例 ```vb m_oClient.AutoHeartbeat = True m_oClient.HeartbeatInterval = 30 ' 30秒无活动则发心跳 ``` *** ## 💓 HeartbeatData 属性 ### 说明 心跳包内容（字节数组）。默认为单字节 `&H00`。可根据协议自定义心跳包格式。用户自定义标签，用于业务标识或分组。可自由读写，**内部管理不再依赖此属性**。 ### 语法 ```vb Property Get HeartbeatData() As Byte() Property Let HeartbeatData(ByRef Value() As Byte) ``` ### 使用示例 ```vb ' 自定义心跳包内容 Dim baHB(0 To 3) As Byte baHB(0) = &HFF baHB(1) = &H0 baHB(2) = &H0 baHB(3) = &HFF m_oClient.HeartbeatData = baHB ``` *** ## 💓 IdleSeconds 属性 ### 说明 当前连接的空闲秒数（只读）。从最后一次收发数据开始计算。可用于判断连接活跃度。用户自定义标签，用于业务标识或分组。可自由读写，**内部管理不再依赖此属性**。 ### 语法 ```vb Property Get IdleSeconds() As Long ``` ### 使用示例 ```vb ' 检查客户端活跃度 Dim oClient As cWinsock For Each oClient In m_oServer.Clients Debug.Print "Client #" & oClient.ClientId & " 空闲: " & oClient.IdleSeconds & "秒" Next ``` *** ## 📌 属性使用场景总结 ### 客户端常用属性 ```vb ' 连接前设置 m_oClient.Protocol = sckTCPProtocol m_oClient.RemoteHost = "192.168.1.100" m_oClient.RemotePort = 8080 m_oClient.Connect ' 连接后获取 Debug.Print "IP: " & m_oClient.RemoteHostIP Debug.Print "端口: " & m_oClient.RemotePort Debug.Print "状态: " & m_oClient.State ' 自定义标签 m_oClient.Tag = "客户端-001" m_oClient.UserData = "用户信息" ``` ### 服务器常用属性 ```vb ' 启动服务器 m_oServer.Protocol = sckTCPProtocol m_oServer.LocalPort = 8080 m_oServer.Listen ' 设置封包协议 m_oServer.PacketProtocol = ppDelimiter m_oServer.Delimiter = vbCrLf ' 设置心跳 m_oServer.AutoHeartbeat = True m_oServer.HeartbeatTimeout = 120 ' 管理客户端 Debug.Print "连接数: " & m_oServer.ClientCount Dim oClient As cWinsock For Each oClient In m_oServer.Clients Debug.Print "Client #" & oClient.ClientId & ": " & oClient.RemoteHostIP & " (空闲" & oClient.IdleSeconds & "秒)" oClient.SendData "广播消息" Next ``` *** **最后更新**: 2026-06-19 --- --- url: /zh/vbman/winsock/sync-methods.md --- # cWinsock 同步方法详解 ## 📋 目录 * [概述](#概述) * [同步方法列表](#同步方法列表) * [事件掩码枚举](#事件掩码枚举) * [方法详解](#方法详解) * [SyncConnect](#syncconnect-同步连接) * [SyncSendText](#syncsendtext-同步发送文本) * [SyncSendArray](#syncsendarray-同步发送字节数组) * [SyncSend](#syncsend-同步发送缓冲区) * [SyncReceiveText](#syncreceivetext-同步接收文本) * [SyncReceiveArray](#syncreceivearray-同步接收字节数组) * [SyncReceive](#syncreceive-同步接收到缓冲区) * [SyncWaitForEvent](#syncwaitforevent-等待事件) * [SyncCancelWait](#synccancelwait-取消等待) * [使用场景](#使用场景) * [异步 vs 同步](#异步-vs-同步) * [注意事项](#注意事项) * [完整示例](#完整示例) *** ## 概述 `cWinsock` 提供了一套完整的同步（阻塞式）网络操作方法，使开发者可以在不使用事件驱动模型的情况下进行网络通信。同步方法会在操作完成前阻塞当前线程，直到操作成功、超时或发生错误。 ### 核心特性 * ⏱️ **超时控制** - 所有同步操作都支持超时设置 * 🔄 **消息泵机制** - 通过 PeekMessage/DispatchMessage 处理消息队列，不会阻塞 UI * 🎯 **简洁 API** - 函数式调用，返回 Boolean 表示成功/失败 * 🌐 **全面支持** - 连接、发送、接收、事件等待全覆盖 * 💻 **编码灵活** - 支持多种文本编码（ACP/GBK、UTF-8、Unicode） ### 适用场景 * 简单的客户端应用（如 HTTP 客户端） * 需要顺序执行的网络操作 * 不需要复杂事件处理的场景 * 快速原型开发 *** ## 同步方法列表 | 方法名 | 返回类型 | 说明 | | ------------------ | -------- | -------------------- | | `SyncConnect` | Boolean | 同步连接到远程服务器 | | `SyncSendText` | Boolean | 同步发送字符串 | | `SyncSendArray` | Boolean | 同步发送字节数组 | | `SyncSend` | Boolean | 同步发送缓冲区数据 | | `SyncReceiveText` | String | 同步接收字符串 | | `SyncReceiveArray` | Boolean | 同步接收到字节数组 | | `SyncReceive` | Boolean | 同步接收到缓冲区 | | `SyncWaitForEvent` | Boolean | 等待指定套接字事件 | | `SyncCancelWait` | Sub | 取消等待操作 | *** ## 事件掩码枚举 `WinSocketEventMaskEnum` 用于指定 `SyncWaitForEvent` 要等待的事件类型。 ### 枚举值 | 枚举名 | 值 | 说明 | | -------------------- | ------- | ---------------- | | `wskSfdRead` | 2^0 | 可读事件 | | `wskSfdWrite` | 2^1 | 可写事件 | | `wskSfdOob` | 2^2 | 带外数据 | | `wskSfdAccept` | 2^3 | 接受连接 | | `wskSfdConnect` | 2^4 | 连接完成 | | `wskSfdClose` | 2^5 | 连接关闭 | | `wskSfdAll` | 2^6 - 1 | 所有事件（默认） | | `[_wskSfdResolve]` | 2^15 | 内部：域名解析 | | `[_wskSfdForceRead]` | 2^14 | 内部：强制读取 | ### 使用示例 ```vb ' 等待可读事件 If ws.SyncWaitForEvent(5000, wskSfdRead) Then Debug.Print "套接字可读" End If ' 等待可写或可读事件 If ws.SyncWaitForEvent(5000, wskSfdRead Or wskSfdWrite) Then Debug.Print "套接字就绪" End If ' 等待任何事件 If ws.SyncWaitForEvent(5000, wskSfdAll) Then Debug.Print "事件触发" End If ``` *** ## 方法详解 ### SyncConnect - 同步连接 ### 说明 同步连接到指定的远程服务器，带有超时控制。连接成功后返回 `True`，超时或失败返回 `False`。 ### 语法 ```vb Public Function SyncConnect(HostAddress As String, ByVal HostPort As Long, Optional ByVal TimeOut As Long) As Boolean ``` ### 参数 | 参数 | 类型 | 说明 | | ------------- | ------------ | ------------------------------------ | | `HostAddress` | String | 远程主机名或 IP 地址 | | `HostPort` | Long | 远程端口号 | | `TimeOut` | Long（可选） | 超时时间（毫秒），默认使用底层默认值 | ### 返回值 * `True` - 连接成功 * `False` - 连接失败或超时 ### 使用示例 ```vb Private Sub TestSyncConnect() Dim ws As New cWinsock Dim bResult As Boolean ' 连接到 example.com 的 80 端口，超时 5 秒 bResult = ws.SyncConnect("example.com", 80, 5000) If bResult Then Debug.Print "连接成功!" Debug.Print "远程 IP: " & ws.RemoteHostIP Debug.Print "本地 IP: " & ws.LocalIP Debug.Print "本地端口: " & ws.LocalPort Else Debug.Print "连接失败或超时" End If ws.Close_ End Sub ``` ### 错误处理 ```vb Private Sub TestConnectWithError() Dim ws As New cWinsock On Error GoTo EH If ws.SyncConnect("invalid-host-name-12345.com", 80, 3000) Then Debug.Print "连接成功" Else Debug.Print "连接失败" End If Exit Sub EH: Debug.Print "连接错误: " & Err.Description & " (错误号: " & Err.Number & ")" ws.Close_ End Sub ``` *** ### SyncSendText - 同步发送文本 ### 说明 同步发送字符串数据，带有超时控制。 ### 语法 ```vb Public Function SyncSendText( _ Text As String, _ Optional ByVal TimeOut As Long, _ Optional HostAddress As String, _ Optional ByVal HostPort As Long, _ Optional ByVal CodePage As EnumScpCodePage = wcpUtf8) As Boolean ``` ### 参数 | 参数 | 类型 | 说明 | | ------------- | ----------------------- | ---------------------------------- | | `Text` | String | 要发送的文本 | | `TimeOut` | Long（可选） | 超时时间（毫秒） | | `HostAddress` | String（可选） | 目标主机地址（UDP 服务器模式使用） | | `HostPort` | Long（可选） | 目标端口（UDP 服务器模式使用） | | `CodePage` | EnumScpCodePage（可选） | 文本编码，默认 `wcpUtf8` | ### 返回值 * `True` - 发送成功 * `False` - 发送失败或超时 ### 使用示例 ```vb Private Sub TestSyncSendText() Dim ws As New cWinsock ' 连接 If ws.SyncConnect("example.com", 80, 5000) Then ' 发送 HTTP 请求 Dim sRequest As String sRequest = "GET / HTTP/1.1" & vbCrLf & _ "Host: example.com" & vbCrLf & vbCrLf If ws.SyncSendText(sRequest, 5000, , , wcpUtf8) Then Debug.Print "发送成功" Else Debug.Print "发送失败" End If End If ws.Close_ End Sub ``` ### 使用不同编码 ```vb ' 使用 GBK 编码（默认） ws.SyncSendText "中文测试", 5000, , , wcpAcp ' 使用 UTF-8 编码（推荐） ws.SyncSendText "中文测试", 5000, , , wcpUtf8 ' 使用 Unicode（不转换） ws.SyncSendText "中文测试", 5000, , , wcpUnicode ``` *** ### SyncSendArray - 同步发送字节数组 ### 说明 同步发送字节数组数据，带有超时控制。 ### 语法 ```vb Public Function SyncSendArray( _ Buffer() As Byte, _ Optional ByVal TimeOut As Long, _ Optional HostAddress As String, _ Optional ByVal HostPort As Long, _ Optional ByVal Flags As Long = 0) As Boolean ``` ### 参数 | 参数 | 类型 | 说明 | | ------------- | -------------- | ---------------- | | `Buffer` | Byte() | 要发送的字节数组 | | `TimeOut` | Long（可选） | 超时时间（毫秒） | | `HostAddress` | String（可选） | 目标主机地址 | | `HostPort` | Long（可选） | 目标端口 | | `Flags` | Long（可选） | 发送标志位 | ### 返回值 * `True` - 发送成功 * `False` - 发送失败或超时 ### 使用示例 ```vb Private Sub TestSyncSendArray() Dim ws As New cWinsock Dim baData() As Byte ' 准备数据 baData = StrConv("Hello World", vbFromUnicode) ' 连接并发送 If ws.SyncConnect("127.0.0.1", 8080, 5000) Then If ws.SyncSendArray(baData, 5000) Then Debug.Print "字节数组发送成功" End If End If ws.Close_ End Sub ``` *** ### SyncSend - 同步发送缓冲区 ### 说明 同步从指定缓冲区指针发送数据，用于高性能场景。 ### 语法 ```vb Public Function SyncSend( _ ByVal BufPtr As Long, _ ByVal BufLen As Long, _ Optional ByVal TimeOut As Long, _ Optional HostAddress As String, _ Optional ByVal HostPort As Long, _ Optional ByVal Flags As Long = 0) As Boolean ``` ### 参数 | 参数 | 类型 | 说明 | | ------------- | -------------- | ---------------- | | `BufPtr` | Long | 缓冲区指针 | | `BufLen` | Long | 缓冲区长度 | | `TimeOut` | Long（可选） | 超时时间（毫秒） | | `HostAddress` | String（可选） | 目标主机地址 | | `HostPort` | Long（可选） | 目标端口 | | `Flags` | Long（可选） | 发送标志位 | ### 返回值 * `True` - 发送成功 * `False` - 发送失败或超时 ### 使用示例 ```vb ' 注意：此方法需要内存指针操作，通常用于高级场景 Private Sub TestSyncSend() Dim ws As New cWinsock Dim sData As String Dim lPtr As Long sData = "Hello World" ' 获取字符串指针（使用 StrPtr） lPtr = StrPtr(sData) If ws.SyncConnect("127.0.0.1", 8080, 5000) Then If ws.SyncSend(lPtr, LenB(sData), 5000) Then Debug.Print "发送成功" End If End If ws.Close_ End Sub ``` *** ### SyncReceiveText - 同步接收文本 ### 说明 同步接收文本数据，带有超时控制。可以指定接收的最小字节数。 ### 语法 ```vb Public Function SyncReceiveText( _ Optional ByVal NeedLen As Long = 1, _ Optional ByVal TimeOut As Long, _ Optional HostAddress As String, _ Optional HostPort As Long, _ Optional ByVal CodePage As EnumScpCodePage = wcpUtf8) As String ``` ### 参数 | 参数 | 类型 | 说明 | | ------------- | ----------------------- | ------------------------ | | `NeedLen` | Long（可选） | 最小接收字节数，默认 1 | | `TimeOut` | Long（可选） | 超时时间（毫秒） | | `HostAddress` | String（可选） | 源主机地址（UDP 模式） | | `HostPort` | Long（可选） | 源端口（UDP 模式） | | `CodePage` | EnumScpCodePage（可选） | 文本编码，默认 `wcpUtf8` | ### 返回值 * 成功：返回接收到的文本 * 失败：返回空字符串 ### 使用示例 ```vb Private Sub TestSyncReceiveText() Dim ws As New cWinsock Dim sResponse As String ' 连接 If ws.SyncConnect("example.com", 80, 5000) Then ' 发送请求 Dim sRequest As String sRequest = "GET / HTTP/1.1" & vbCrLf & _ "Host: example.com" & vbCrLf & vbCrLf If ws.SyncSendText(sRequest, 5000, , , wcpUtf8) Then ' 接收响应（至少 100 字节，超时 5 秒） sResponse = ws.SyncReceiveText(100, 5000, , , wcpUtf8) If Len(sResponse) > 0 Then Debug.Print "收到响应:" Debug.Print sResponse Debug.Print "长度: " & Len(sResponse) & " 字符" Else Debug.Print "接收失败或超时" End If End If End If ws.Close_ End Sub ``` ### 读取固定长度 ```vb ' 读取前 100 字节 Dim sHeader As String sHeader = ws.SyncReceiveText(100, 3000, , , wcpUtf8) Debug.Print "头部: " & sHeader ``` *** ### SyncReceiveArray - 同步接收字节数组 ### 说明 同步接收字节数组数据，带有超时控制。 ### 语法 ```vb Public Function SyncReceiveArray( _ Buffer() As Byte, _ Optional ByVal NeedLen As Long, _ Optional ByVal TimeOut As Long, _ Optional HostAddress As String, _ Optional ByVal HostPort As Long, _ Optional ByVal Flags As Long = 0) As Boolean ``` ### 参数 | 参数 | 类型 | 说明 | | ------------- | -------------- | ---------------------- | | `Buffer` | Byte() | 用于接收数据的字节数组 | | `NeedLen` | Long（可选） | 最小接收字节数 | | `TimeOut` | Long（可选） | 超时时间（毫秒） | | `HostAddress` | String（可选） | 源主机地址 | | `HostPort` | Long（可选） | 源端口 | | `Flags` | Long（可选） | 接收标志位 | ### 返回值 * `True` - 接收成功 * `False` - 接收失败或超时 ### 使用示例 ```vb Private Sub TestSyncReceiveArray() Dim ws As New cWinsock Dim baBuffer() As Byte ' 连接 If ws.SyncConnect("127.0.0.1", 8080, 5000) Then ' 发送请求 If ws.SyncSendText("GET_DATA", 5000, , , wcpUtf8) Then ' 接收响应（最大 8192 字节） ReDim baBuffer(0 To 8191) As Byte If ws.SyncReceiveArray(baBuffer, 1, 5000) Then ' 获取实际接收长度 Dim lReceived As Long lReceived = UBound(baBuffer) + 1 Debug.Print "收到 " & lReceived & " 字节" Else Debug.Print "接收失败或超时" End If End If End If ws.Close_ End Sub ``` *** ### SyncReceive - 同步接收到缓冲区 ### 说明 同步从套接字接收数据到指定缓冲区指针，用于高性能场景。 ### 语法 ```vb Public Function SyncReceive( _ ByVal BufPtr As Long, _ ByVal BufLen As Long, _ ByRef Received As Long, _ Optional ByVal TimeOut As Long, _ Optional HostAddress As String, _ Optional ByVal HostPort As Long, _ Optional ByVal Flags As Long = 0) As Boolean ``` ### 参数 | 参数 | 类型 | 说明 | | ------------- | -------------- | ---------------- | | `BufPtr` | Long | 缓冲区指针 | | `BufLen` | Long | 缓冲区长度 | | `Received` | Long（传址） | 实际接收的字节数 | | `TimeOut` | Long（可选） | 超时时间（毫秒） | | `HostAddress` | String（可选） | 源主机地址 | | `HostPort` | Long（可选） | 源端口 | | `Flags` | Long（可选） | 接收标志位 | ### 返回值 * `True` - 接收成功，`Received` 包含实际接收字节数 * `False` - 接收失败或超时 ### 使用示例 ```vb Private Sub TestSyncReceive() Dim ws As New cWinsock Dim baBuffer() As Byte Dim lReceived As Long ' 准备缓冲区 ReDim baBuffer(0 To 8191) As Byte ' 连接 If ws.SyncConnect("127.0.0.1", 8080, 5000) Then ' 发送请求 If ws.SyncSendText("GET_DATA", 5000, , , wcpUtf8) Then ' 接收响应 If ws.SyncReceive(VarPtr(baBuffer(0)), 8192, lReceived, 5000) Then Debug.Print "实际收到: " & lReceived & " 字节" ' 只使用实际接收的部分 If lReceived > 0 Then ReDim Preserve baBuffer(0 To lReceived - 1) End If Else Debug.Print "接收失败或超时" End If End If End If ws.Close_ End Sub ``` *** ### SyncWaitForEvent - 等待事件 ### 说明 等待指定的套接字事件发生，带有超时控制。可用于轮询特定事件或实现自定义协议。 ### 语法 ```vb Public Function SyncWaitForEvent( _ ByVal TimeOut As Long, _ Optional ByVal EventMask As WinSocketEventMaskEnum = wskSfdAll) As Boolean ``` ### 参数 | 参数 | 类型 | 说明 | | ----------- | ------------------------------ | -------------------------- | | `TimeOut` | Long | 超时时间（毫秒） | | `EventMask` | WinSocketEventMaskEnum（可选） | 事件掩码，默认 `wskSfdAll` | ### 返回值 * `True` - 指定事件发生 * `False` - 超时或错误 ### 使用示例 ```vb Private Sub TestWaitForEvent() Dim ws As New cWinsock ' 连接 If ws.SyncConnect("example.com", 80, 5000) Then ' 等待可写事件（表示套接字准备好发送数据） If ws.SyncWaitForEvent(5000, wskSfdWrite) Then Debug.Print "套接字可写，可以发送数据" ' 发送数据 ws.SyncSendText "Hello", 5000, , , wcpUtf8 End If ' 等待可读事件（表示有数据可读） If ws.SyncWaitForEvent(5000, wskSfdRead) Then Debug.Print "套接字可读，可以接收数据" Dim sData As String sData = ws.SyncReceiveText(1, 5000, , , wcpUtf8) Debug.Print "收到: " & sData End If End If ws.Close_ End Sub ``` ### 等待多个事件 ```vb ' 等待可读或可写事件 Dim lMask As Long lMask = wskSfdRead Or wskSfdWrite If ws.SyncWaitForEvent(5000, lMask) Then ' 检查 BytesReceived 来判断具体是哪个事件 If ws.BytesReceived > 0 Then Debug.Print "有数据可读" Else Debug.Print "套接字可写" End If End If ``` *** ### SyncCancelWait - 取消等待 ### 说明 取消当前正在进行的同步等待操作（如 `SyncWaitForEvent`、`SyncReceiveText` 等）。 ### 语法 ```vb Public Sub SyncCancelWait() ``` ### 使用场景 * 在窗体关闭时取消正在进行的网络操作 * 在用户取消操作时中断等待 * 多线程场景中通知停止 ### 使用示例 ```vb Private WithEvents m_oWinsock As cWinsock Private m_bCancelled As Boolean Private Sub cmdStart_Click() Set m_oWinsock = New cWinsock If m_oWinsock.SyncConnect("example.com", 80, 5000) Then ' 开始等待数据 Dim sData As String m_bCancelled = False Do ' 检查是否取消 If m_bCancelled Then Debug.Print "用户取消操作" m_oWinsock.SyncCancelWait Exit Do End If ' 接收数据 sData = m_oWinsock.SyncReceiveText(1, 1000, , , wcpUtf8) If Len(sData) > 0 Then Debug.Print "收到: " & sData Else Debug.Print "超时，继续等待..." End If DoEvents ' 允许 UI 响应 Loop Until False End If m_oWinsock.Close_ End Sub Private Sub cmdCancel_Click() m_bCancelled = True End Sub Private Sub Form_Unload(Cancel As Integer) ' 窗体关闭时取消等待 If Not m_oWinsock Is Nothing Then m_oWinsock.SyncCancelWait m_oWinsock.Close_ End If End Sub ``` *** ## 使用场景 ### 场景 1：HTTP 客户端 ```vb Private Function HttpGet(ByVal sUrl As String, ByVal sPath As String) As String Dim ws As New cWinsock Dim sHost As String Dim nPort As Long Dim sRequest As String Dim sResponse As String ' 解析 URL（简化版） sHost = ExtractHost(sUrl) nPort = ExtractPort(sUrl, 80) ' 连接 If Not ws.SyncConnect(sHost, nPort, 5000) Then HttpGet = "连接失败" Exit Function End If ' 构造请求 sRequest = "GET " & sPath & " HTTP/1.1" & vbCrLf & _ "Host: " & sHost & vbCrLf & _ "Connection: close" & vbCrLf & vbCrLf ' 发送请求 If Not ws.SyncSendText(sRequest, 5000, , , wcpUtf8) Then HttpGet = "发送失败" ws.Close_ Exit Function End If ' 接收响应 sResponse = ws.SyncReceiveText(1, 5000, , , wcpUtf8) ws.Close_ HttpGet = sResponse End Function ' 使用 Dim sHtml As String sHtml = HttpGet("http://example.com", "/") Debug.Print sHtml ``` ### 场景 2：Echo 客户端 ```vb Private Sub EchoClient() Dim ws As New cWinsock ' 连接到 Echo 服务器 If ws.SyncConnect("127.0.0.1", 7, 5000) Then Debug.Print "已连接到 Echo 服务器" ' 发送消息 Dim sMessage As String sMessage = "Hello, Echo Server!" If ws.SyncSendText(sMessage, 5000, , , wcpUtf8) Then Debug.Print "发送: " & sMessage ' 接收回显 Dim sReply As String sReply = ws.SyncReceiveText(Len(sMessage), 5000, , , wcpUtf8) Debug.Print "接收: " & sReply End If End If ws.Close_ End Sub ``` ### 场景 3：文件上传（简化版） ```vb Private Sub UploadFile(ByVal sFilePath As String, ByVal sServer As String, ByVal nPort As Long) Dim ws As New cWinsock Dim baBuffer() As Byte Dim nFileNum As Integer Dim lFileSize As Long Dim lOffset As Long Dim lChunkSize As Long ' 连接服务器 If Not ws.SyncConnect(sServer, nPort, 5000) Then Debug.Print "连接失败" Exit Sub End If ' 打开文件 nFileNum = FreeFile Open sFilePath For Binary As #nFileNum lFileSize = LOF(nFileNum) ' 发送文件头 Dim sHeader As String sHeader = "UPLOAD:" & CStr(lFileSize) & vbCrLf ws.SyncSendText sHeader, 5000, , , wcpUtf8 ' 分块发送 lChunkSize = 8192 ' 8KB 每块 lOffset = 1 Do While lOffset <= lFileSize ReDim baBuffer(0 To lChunkSize - 1) As Byte Get #nFileNum, lOffset, baBuffer ' 调整最后一块的大小 If lOffset + lChunkSize > lFileSize + 1 Then ReDim Preserve baBuffer(0 To lFileSize + 1 - lOffset) As Byte End If ' 发送块 If Not ws.SyncSendArray(baBuffer, 5000) Then Debug.Print "发送失败于偏移: " & lOffset Exit Do End If lOffset = lOffset + lChunkSize ' 更新进度 Debug.Print "已发送: " & Format((lOffset - 1) / lFileSize * 100, "0.00") & "%" DoEvents Loop Close #nFileNum ws.Close_ Debug.Print "上传完成" End Sub ``` *** ## 异步 vs 同步 ### 异步事件驱动模式 **优点：** * ✅ 不会阻塞 UI 线程 * ✅ 适合高并发场景 * ✅ 响应及时 * ✅ 可以处理多个客户端 **缺点：** * ❌ 代码分散在多个事件中 * ❌ 逻辑流程不直观 * ❌ 需要维护状态变量 ```vb ' 异步模式 Private WithEvents ws As cWinsock Private m_bWaiting As Boolean Private m_sResponse As String Private Sub cmdConnect_Click() Set ws = New cWinsock ws.Connect "example.com", 80 m_bWaiting = True Do While m_bWaiting DoEvents Loop End Sub Private Sub ws_Connect(Client As cWinsock) Client.SendData "GET / HTTP/1.1" & vbCrLf End Sub Private Sub ws_DataArrival(Client As cWinsock, ByVal bytesTotal As Long) Client.GetData m_sResponse m_bWaiting = False End Sub ``` ### 同步阻塞模式 **优点：** * ✅ 代码线性，逻辑清晰 * ✅ 易于理解和调试 * ✅ 适合简单顺序操作 * ✅ 无需维护状态变量 **缺点：** * ❌ 会阻塞当前执行流 * ❌ 不适合高并发 * ❌ 需要手动调用 DoEvents 保持 UI 响应 ```vb ' 同步模式 Private Sub cmdConnect_Click() Dim ws As New cWinsock ' 连接 If ws.SyncConnect("example.com", 80, 5000) Then ' 发送 If ws.SyncSendText("GET / HTTP/1.1" & vbCrLf, 5000, , , wcpUtf8) Then ' 接收 Dim sResponse As String sResponse = ws.SyncReceiveText(1, 5000, , , wcpUtf8) Debug.Print sResponse End If End If ws.Close_ End Sub ``` ### 选择建议 | 场景 | 推荐模式 | 原因 | | ---------------- | -------- | ------------------ | | 简单 HTTP 客户端 | 同步 | 顺序操作，逻辑简单 | | TCP 服务器 | 异步 | 需要处理多个客户端 | | 高并发应用 | 异步 | 避免阻塞 | | 快速原型 | 同步 | 开发速度快 | | 文件传输 | 同步 | 简单的请求-响应 | | 实时通信 | 异步 | 及时响应 | *** ## 注意事项 ### ⚠️ 重要注意事项 1. **消息泵机制** * 同步方法内部使用 `PeekMessage`/`DispatchMessage` 处理消息队列 * **不会阻塞 UI 消息循环**，窗体仍然可以响应 * 无需手动调用 `DoEvents` 2. **超时设置** * 建议所有同步操作都设置合理的超时时间 * 超时时间根据网络环境调整（建议 3-30 秒） * 超时后会自动返回失败状态 3. **错误处理** * 所有同步方法应该配合 `On Error` 使用 * 检查返回值判断操作是否成功 * 使用 `GetErrorDescription` 获取错误描述 4. **资源清理** * 务必在操作完成后调用 `Close_` * 在窗体卸载时取消正在进行的等待操作 * 使用 `SyncCancelWait` 中断长时间等待 5. **编码问题** * 默认编码为 `wcpUtf8` * 确保发送和接收使用相同的编码 * 与其他系统通信时明确编码协议 6. **状态检查** * 调用同步方法前确保 socket 已连接 * 使用 `State` 属性检查连接状态 * 使用 `BytesReceived` 检查可用数据 ### ⚠️ 性能注意事项 1. **避免频繁的小数据发送** * 合并小数据块一起发送 * 使用缓冲区批量处理 2. **合理设置超时** * 过短的超时可能导致误判 * 过长的超时会降低响应速度 3. **内存管理** * 及时释放大字节数组 * 避免在循环中重复分配内存 ### ⚠️ 线程安全 * 同步方法**不**支持多线程场景 * 所有操作应在主线程执行 * 不要在后台线程中调用同步方法 *** ## 完整示例 ### 完整的 HTTP 客户端示例 ```vb ' Form1.frm Option Explicit Private WithEvents m_oWinsock As cWinsock Private m_bCancelled As Boolean Private Sub cmdGet_Click() Dim sUrl As String Dim sHost As String Dim nPort As Long Dim sPath As String Dim sRequest As String Dim sResponse As String ' 获取 URL sUrl = txtUrl.Text ' 解析 URL ParseUrl sUrl, sHost, nPort, sPath If Len(sHost) = 0 Then MsgBox "无效的 URL", vbExclamation Exit Sub End If ' 创建 socket Set m_oWinsock = New cWinsock m_bCancelled = False ' 禁用按钮 cmdGet.Enabled = False cmdCancel.Enabled = True ' 连接 If Not m_oWinsock.SyncConnect(sHost, nPort, 5000) Then MsgBox "连接失败: " & m_oWinsock.GetErrorDescription(Err.LastDllError), vbExclamation ResetUI Exit Sub End If Debug.Print "已连接到 " & sHost & ":" & nPort ' 检查取消 If m_bCancelled Then ResetUI Exit Sub End If ' 构造请求 sRequest = "GET " & sPath & " HTTP/1.1" & vbCrLf & _ "Host: " & sHost & vbCrLf & _ "User-Agent: cWinsock/1.0" & vbCrLf & _ "Connection: close" & vbCrLf & vbCrLf ' 发送请求 If Not m_oWinsock.SyncSendText(sRequest, 5000, , , wcpUtf8) Then MsgBox "发送失败", vbExclamation ResetUI Exit Sub End If Debug.Print "已发送请求" ' 检查取消 If m_bCancelled Then ResetUI Exit Sub End If ' 接收响应 sResponse = m_oWinsock.SyncReceiveText(1, 10000, , , wcpUtf8) If Len(sResponse) > 0 Then Debug.Print "收到响应，长度: " & Len(sResponse) txtResponse.Text = sResponse Else MsgBox "接收超时或失败", vbExclamation End If ' 清理 ResetUI End Sub Private Sub cmdCancel_Click() m_bCancelled = True If Not m_oWinsock Is Nothing Then m_oWinsock.SyncCancelWait End If End Sub Private Sub Form_Unload(Cancel As Integer) If Not m_oWinsock Is Nothing Then m_oWinsock.SyncCancelWait m_oWinsock.Close_ Set m_oWinsock = Nothing End If End Sub Private Sub ResetUI() If Not m_oWinsock Is Nothing Then m_oWinsock.Close_ Set m_oWinsock = Nothing End If cmdGet.Enabled = True cmdCancel.Enabled = False End Sub Private Sub ParseUrl(ByVal sUrl As String, ByRef sHost As String, ByRef nPort As Long, ByRef sPath As String) Dim sTemp As String Dim nPos As Long Dim nPortPos As Long Dim nPathPos As Long ' 移除协议前缀 If InStr(1, sUrl, "://") > 0 Then sUrl = Mid$(sUrl, InStr(sUrl, "://") + 3) End If ' 查找路径开始位置 nPathPos = InStr(1, sUrl, "/") If nPathPos = 0 Then nPathPos = Len(sUrl) + 1 End If ' 提取主机和端口 sTemp = Left$(sUrl, nPathPos - 1) ' 查找端口 nPortPos = InStr(1, sTemp, ":") If nPortPos > 0 Then sHost = Left$(sTemp, nPortPos - 1) nPort = Val(Mid$(sTemp, nPortPos + 1)) Else sHost = sTemp nPort = 80 End If ' 提取路径 sPath = Mid$(sUrl, nPathPos) If Len(sPath) = 0 Then sPath = "/" End If End Sub ``` ### 简单的聊天客户端示例 ```vb Private WithEvents m_oWinsock As cWinsock Private Sub cmdConnect_Click() Set m_oWinsock = New cWinsock If m_oWinsock.SyncConnect(txtServer.Text, Val(txtPort.Text), 5000) Then Debug.Print "已连接到服务器" txtSend.Enabled = True cmdConnect.Enabled = False cmdDisconnect.Enabled = True Else MsgBox "连接失败", vbExclamation End If End Sub Private Sub cmdDisconnect_Click() If Not m_oWinsock Is Nothing Then m_oWinsock.SyncCancelWait m_oWinsock.Close_ Set m_oWinsock = Nothing End If txtSend.Enabled = False cmdConnect.Enabled = True cmdDisconnect.Enabled = False End Sub Private Sub cmdSend_Click() If m_oWinsock Is Nothing Then Exit Sub Dim sMessage As String sMessage = "[" & txtNick.Text & "]: " & txtSend.Text If m_oWinsock.SyncSendText(sMessage, 5000, , , wcpUtf8) Then txtReceive.Text = txtReceive.Text & sMessage & vbCrLf txtSend.Text = "" Else MsgBox "发送失败", vbExclamation End If End Sub Private Sub tmrReceive_Timer() If m_oWinsock Is Nothing Or m_oWinsock.State <> sckConnected Then Exit Sub ' 检查是否有数据 If m_oWinsock.BytesReceived > 0 Then Dim sData As String sData = m_oWinsock.SyncReceiveText(1, 100, , , wcpUtf8) If Len(sData) > 0 Then txtReceive.Text = txtReceive.Text & sData & vbCrLf txtReceive.SelStart = Len(txtReceive.Text) End If End If End Sub ``` *** ## 总结 `cWinsock` 的同步方法提供了一种简单、直观的网络编程方式，特别适合： * 🎯 **简单客户端应用** - HTTP、Echo、聊天等 * 📚 **学习网络编程** - 线性代码易于理解 * ⚡ **快速原型开发** - 快速验证想法 * 🔄 **顺序操作** - 需要按步骤执行的任务 对于更复杂的服务器或高并发场景，建议使用异步事件驱动模式。 *** **最后更新**: 2026-01-26 --- --- url: /zh/vbman/winsock/binding.md --- # cWinsock 用户绑定与组管理 ## 📋 功能概述 用户绑定和组管理功能提供了一套完整的用户身份管理和消息分发机制： * **用户绑定**：将用户身份与 socket 连接关联，支持按用户名发送消息 * **组管理**：将用户分组，支持批量消息发送和管理操作 * **双向同步**：组操作自动同步服务器端和客户端的 `CurrentGroups` * **自动清理**：用户断开时自动解绑，无需手动处理 ### 关键属性 | 属性 | 类型 | 说明 | |------|------|------| | `CurrentUser` | Variant | 客户端实例上绑定的用户名 | | `CurrentUserToken` | String | 客户端实例上绑定的用户 Token（如认证令牌） | | `CurrentUserInfo` | cJson | 客户端实例上绑定的用户扩展信息（JSON 对象） | | `CurrentGroups` | Dictionary | 客户端实例上所属的组列表（组名 → True） | *** ## 👤 用户绑定 ### BindUser 方法 #### 说明 将用户绑定到客户端连接，实现用户身份与 socket 连接的关联。 #### 语法 ```vb Public Sub BindUser(ByVal User As Variant, Client As cWinsock, Optional ByVal Token As String, Optional Info As cJson) ``` #### 参数 | 参数 | 类型 | 说明 | |------|------|------| | `User` | Variant | 用户标识（字符串或其他唯一值） | | `Client` | cWinsock | 客户端 socket 实例 | | `Token` | String（可选） | 用户认证令牌，绑定后可通过 `Client.CurrentUserToken` 获取 | | `Info` | cJson（可选） | 用户扩展信息（JSON 对象），绑定后可通过 `Client.CurrentUserInfo` 获取 | #### 使用示例 ```vb ' 服务器端：客户端连接时绑定用户 Private Sub m_oServer_DataArrival(Client As cWinsock, ByVal bytesTotal As Long) Dim sData As String Client.GetData sData ' 解析登录消息，假设格式为 "LOGIN:username" If Left$(sData, 6) = "LOGIN:" Then Dim sUsername As String sUsername = Mid$(sData, 7) ' 绑定用户到客户端（带 Token 和扩展信息） Dim oInfo As New cJson oInfo.Add "loginTime", Now oInfo.Add "ip", Client.RemoteHostIP m_oServer.BindUser sUsername, Client, "secret_token_123", oInfo Client.SendData "LOGIN:OK" Debug.Print "用户 " & sUsername & " 已登录，Token: " & Client.CurrentUserToken End If End Sub ``` *** ### ExistsUser 方法 #### 说明 检查指定用户是否已绑定。 #### 语法 ```vb Public Function ExistsUser(ByVal User As Variant) As Boolean ``` #### 使用示例 ```vb If m_oServer.ExistsUser("alice") Then Debug.Print "用户在线" Else Debug.Print "用户不在线" End If ``` *** ### UnbindUser 方法 #### 说明 解绑指定用户。 #### 语法 ```vb Public Sub UnbindUser(ByVal User As Variant) ``` #### 使用示例 ```vb ' 手动踢出用户 If m_oServer.ExistsUser("alice") Then m_oServer.UnbindUser "alice" Debug.Print "用户已解绑" End If ``` #### 自动解绑 用户断开连接时，系统会自动从用户列表中移除，无需手动调用。 *** ### SendToUser 方法 #### 说明 向绑定的用户发送数据。 #### 语法 ```vb Public Sub SendToUser(ByVal User As Variant, Data As Variant, Optional ByVal CodePage As EnumScpCodePage = wcpAcp) ``` #### 参数 | 参数 | 类型 | 说明 | |------|------|------| | `User` | Variant | 用户标识 | | `Data` | Variant | 要发送的数据（字符串或字节数组） | | `CodePage` | EnumScpCodePage（可选） | 文本编码，默认 `wcpAcp` | #### 使用示例 ```vb ' 向指定用户发送消息 m_oServer.SendToUser "alice", "Hello, Alice!" ' 使用 UTF-8 编码发送 m_oServer.SendToUser "alice", "你好，爱丽丝！", wcpUtf8 ' 广播消息给所有在线用户 Dim vUser As Variant For Each vUser In m_oServer.m_Users.Keys m_oServer.SendToUser vUser, "系统公告：服务器将在5分钟后维护" Next ``` #### 错误处理 如果用户不存在，会抛出错误： ```vb On Error GoTo EH m_oServer.SendToUser "bob", "Hello!" Exit Sub EH: If Err.Number = vbObjectError Then MsgBox "用户不在线" End If ``` *** ## 👥 组管理 组管理功能允许将用户分组，方便批量发送消息和管理。 ### 前提条件 绑定组之前，用户必须先绑定到客户端： ```vb ' ✅ 正确流程：先绑定用户，再绑定组 m_oServer.BindUser "alice", Client m_oServer.BindGroup "admins", Client ' ❌ 错误：用户未绑定，无法绑定组 m_oServer.BindGroup "admins", Client ' 会报错 ``` *** ### BindGroup 方法 #### 说明 将已绑定用户的客户端加入指定组。 #### 语法 ```vb Public Sub BindGroup(ByVal GroupName As String, Client As cWinsock) ``` #### 参数 | 参数 | 类型 | 说明 | |------|------|------| | `GroupName` | String | 组名称 | | `Client` | cWinsock | 已绑定用户的客户端实例 | #### 使用示例 ```vb Private Sub m_oServer_DataArrival(Client As cWinsock, ByVal bytesTotal As Long) Dim sData As String Client.GetData sData ' 解析加入组请求，格式为 "JOIN_GROUP:groupname" If Left$(sData, 11) = "JOIN_GROUP:" Then Dim sGroup As String sGroup = Mid$(sData, 12) ' 检查用户是否已绑定 If LenB(CStr(Client.CurrentUser)) = 0 Then Client.SendData "ERROR: Please login first" Exit Sub End If ' 加入组 m_oServer.BindGroup sGroup, Client Client.SendData "JOIN_GROUP:OK:" & sGroup Debug.Print Client.CurrentUser & " 加入了组: " & sGroup End If End Sub ``` #### 同一用户多次加入同一组 同一个用户可以多次调用 `BindGroup` 加入同一个组，但不会重复添加。 *** ### ExistsGroup 方法 #### 说明 检查指定组是否存在。 #### 语法 ```vb Public Function ExistsGroup(ByVal GroupName As String) As Boolean ``` #### 使用示例 ```vb If m_oServer.ExistsGroup("admins") Then Debug.Print "管理员组存在，成员数: " & m_oServer.GetGroupMembers("admins").Count Else Debug.Print "管理员组不存在" End If ``` *** ### UnbindGroup 方法 #### 说明 从指定组中移除用户。 #### 语法 ```vb Public Sub UnbindGroup(ByVal GroupName As String, ByVal User As Variant) ``` #### 使用示例 ```vb ' 从组中移除用户 m_oServer.UnbindGroup "admins", "alice" ' 组长踢人 Private Sub m_oServer_DataArrival(Client As cWinsock, ByVal bytesTotal As Long) Dim sData As String Client.GetData sData If Left$(sData, 13) = "KICK_FROM_GROUP" Then Dim sGroup As String, sTarget As String sGroup = Mid$(sData, 14, InStr(sData, ":") - 14) sTarget = Mid$(sData, InStr(sData, ":") + 1) m_oServer.UnbindGroup sGroup, sTarget Debug.Print sTarget & " 已被移出组: " & sGroup End If End Sub ``` #### 自动清理 当组内成员全部离开时，组会自动删除。 *** ### GetGroupMembers 方法 #### 说明 获取指定组的所有成员用户名列表。 #### 语法 ```vb Public Function GetGroupMembers(ByVal GroupName As String) As String() ``` #### 返回值 返回包含所有成员用户名的字符串数组。如果组不存在或为空，返回空数组。 #### 使用示例 ```vb Dim aMembers() As String Dim sMember As String aMembers = m_oServer.GetGroupMembers("admins") If UBound(aMembers) >= 0 Then Debug.Print "管理员组共有 " & (UBound(aMembers) + 1) & " 人:" For Each sMember In aMembers Debug.Print " - " & sMember Next Else Debug.Print "管理员组为空" End If ``` *** ### SendToGroup 方法 #### 说明 向指定组内的所有成员发送数据。 #### 语法 ```vb Public Sub SendToGroup(ByVal GroupName As String, Data As Variant, Optional ByVal CodePage As EnumScpCodePage = wcpAcp) ``` #### 参数 | 参数 | 类型 | 说明 | |------|------|------| | `GroupName` | String | 组名称 | | `Data` | Variant | 要发送的数据 | | `CodePage` | EnumScpCodePage（可选） | 文本编码 | #### 使用示例 ```vb ' 发送群消息 m_oServer.SendToGroup "developers", "各位同事，下午3点有技术分享会" ' 广播系统公告给所有组 Dim sGroup As Variant For Each sGroup In m_oServer.m_Groups.Keys m_oServer.SendToGroup CStr(sGroup), "【系统公告】服务器将在10分钟后重启" Next ``` #### 智能处理 * 如果组不存在，不发送任何数据 * 如果组内某些用户已离线，会自动跳过，只发送给在线用户 *** ### GetUserGroups 方法 #### 说明 获取指定用户所属的所有组的列表。 #### 语法 ```vb Public Function GetUserGroups(ByVal User As Variant) As String() ``` #### 返回值 返回包含所有组名的字符串数组。 #### 使用示例 ```vb ' 查看用户所在的组 Dim aGroups() As String Dim sGroup As String aGroups = m_oServer.GetUserGroups("alice") If UBound(aGroups) >= 0 Then Debug.Print "alice 属于以下组:" For Each sGroup In aGroups Debug.Print " - " & sGroup Next Else Debug.Print "alice 不在任何组中" End If ``` *** ### DeleteGroup 方法 #### 说明 解散指定组，从所有成员的 `CurrentGroups` 中同步删除该组。 #### 语法 ```vb Public Sub DeleteGroup(ByVal GroupName As String) ``` #### 使用示例 ```vb ' 解散组 m_oServer.DeleteGroup "temp_group" Debug.Print "组已解散" ' 管理员解散组 Private Sub m_oServer_DataArrival(Client As cWinsock, ByVal bytesTotal As Long) Dim sData As String Client.GetData sData If Left$(sData, 12) = "DELETE_GROUP" Then Dim sGroup As String sGroup = Mid$(sData, 14) If m_oServer.ExistsGroup(sGroup) Then m_oServer.DeleteGroup sGroup Debug.Print "组 " & sGroup & " 已被解散" End If End If End Sub ``` #### 同步机制 解散组时，系统会自动遍历所有组成员，从每个成员的 `CurrentGroups` 中移除该组名。 *** ### CloseUser 方法 #### 说明 强制下线指定用户，关闭其客户端连接。 #### 语法 ```vb Public Sub CloseUser(ByVal User As Variant) ``` #### 使用示例 ```vb ' 踢出指定用户 m_oServer.CloseUser "alice" Debug.Print "用户已下线" ' 管理员踢人 Private Sub m_oServer_DataArrival(Client As cWinsock, ByVal bytesTotal As Long) Dim sData As String Client.GetData sData If Left$(sData, 5) = "KICK:" Then Dim sTarget As String sTarget = Mid$(sData, 6) If m_oServer.ExistsUser(sTarget) Then m_oServer.CloseUser sTarget Debug.Print sTarget & " 已被管理员踢出" End If End If End Sub ``` #### 清理流程 调用 `CloseUser` 会触发客户端的 `Class_Terminate`，自动完成以下清理： * 从所有组中解绑 * 从用户列表中移除 * 清空 `CurrentGroups` *** ## 🔧 内部方法 以下方法是内部使用的方法，通常不需要直接调用： ### UnbindUserFromAllGroups 将用户从所有组中解绑（由 `Class_Terminate` 调用，用户断开连接时自动触发）。会同步更新客户端的 `CurrentGroups`。 *** ## 📊 数据结构与同步机制 ### 服务器端存储结构 ``` m_Users (Dictionary) └── 用户名 → cWinsock 客户端实例 m_Groups (Dictionary) └── 组名 → Dictionary(用户名 → True) ``` ### 客户端实例属性 ``` CurrentUser (Variant) └── 绑定的用户名 CurrentUserToken (String) └── 用户认证令牌（BindUser 时传入的 Token） CurrentUserInfo (cJson) └── 用户扩展信息（BindUser 时传入的 Info） CurrentGroups (Dictionary) └── 组名 → True ``` ### 双向同步 所有组操作都会自动同步服务器端和客户端的数据： | 操作 | 服务器端 | 客户端 | |------|----------|--------| | `BindGroup` | 添加到 `m_Groups[组名]` | 添加到 `CurrentGroups` | | `UnbindGroup` | 从 `m_Groups[组名]` 移除 | 从 `CurrentGroups` 移除 | | `DeleteGroup` | 删除 `m_Groups[组名]` | 从所有成员 `CurrentGroups` 移除 | | `UnbindUserFromAllGroups` | 从所有组移除用户 | 清空 `CurrentGroups` | *** ## 📊 自动清理机制 ### 用户断开时的清理流程 当客户端断开连接时，系统会自动执行以下清理： ``` 1. 客户端 Close_() 或 Class_Terminate() 被调用 2. 检查 CurrentUser 是否为空 3. 如果不为空： a. 调用 UnbindUserFromAllGroups() 从所有组移除 b. 调用 UnbindUser() 从用户列表移除 c. 清空 CurrentGroups d. 清空 CurrentUser e. 清空 CurrentUserToken（置为空字符串） f. 清空 CurrentUserInfo（调用 Clear） ``` ### 内存管理注意事项 用户绑定功能使用 Dictionary 存储用户和组的引用。为避免内存泄漏： 1. **始终通过服务器对象绑定和解绑**：不要直接操作内部的 `m_Users` 和 `m_Groups` 2. **使用 RemoveClient**：客户端断开时应调用服务器的 `RemoveClient` 方法 3. **避免循环引用**：服务器持有客户端引用，客户端持有父服务器引用（通过 `ParentServer`） *** ## 💬 完整聊天服务器示例 ```vb ' 服务器端完整示例 Dim WithEvents m_oServer As cWinsock Private Sub Form_Load() Set m_oServer = New cWinsock m_oServer.Protocol = sckTCPProtocol m_oServer.Listen 8080 End Sub ' 处理连接请求 Private Sub m_oServer_ConnectionRequest(Client As cWinsock, ByRef DisConnect As Boolean) Debug.Print "新连接: " & Client.RemoteHostIP End Sub ' 处理数据到达 Private Sub m_oServer_DataArrival(Client As cWinsock, ByVal bytesTotal As Long) Dim sData As String Client.GetData sData ' 解析命令 Select Case Left$(sData, InStr(sData, ":") - 1) Case "LOGIN" HandleLogin Client, Mid$(sData, 7) Case "JOIN_GROUP" HandleJoinGroup Client, Mid$(sData, 12) Case "MSG" HandleMessage Client, Mid$(sData, 5) Case "BROADCAST" HandleBroadcast Client, Mid$(sData, 11) End Select End Sub Private Sub HandleLogin(Client As cWinsock, ByVal sUsername As String) If m_oServer.ExistsUser(sUsername) Then Client.SendData "LOGIN:ERROR:User already logged in" Exit Sub End If ' 绑定用户，附带 Token 和扩展信息 Dim oInfo As New cJson oInfo.Add "loginTime", Now oInfo.Add "ip", Client.RemoteHostIP m_oServer.BindUser sUsername, Client, "secret_token_123", oInfo Client.SendData "LOGIN:OK" Debug.Print sUsername & " 登录成功，Token: " & Client.CurrentUserToken End Sub Private Sub HandleJoinGroup(Client As cWinsock, ByVal sGroup As String) If LenB(CStr(Client.CurrentUser)) = 0 Then Client.SendData "ERROR:Please login first" Exit Sub End If m_oServer.BindGroup sGroup, Client Client.SendData "JOIN_GROUP:OK:" & sGroup Debug.Print Client.CurrentUser & " 加入组: " & sGroup End Sub Private Sub HandleMessage(Client As cWinsock, ByVal sMsg As String) If LenB(CStr(Client.CurrentUser)) = 0 Then Client.SendData "ERROR:Please login first" Exit Sub End If ' 向所有组员发送消息 m_oServer.SendToGroup "general", Client.CurrentUser & ": " & sMsg End Sub Private Sub HandleBroadcast(Client As cWinsock, ByVal sMsg As String) If LenB(CStr(Client.CurrentUser)) = 0 Then Client.SendData "ERROR:Please login first" Exit Sub End If ' 向所有组广播 Dim sGroup As Variant For Each sGroup In m_oServer.m_Groups.Keys m_oServer.SendToGroup CStr(sGroup), "[广播] " & Client.CurrentUser & ": " & sMsg Next End Sub ' 处理客户端断开 Private Sub m_oServer_CloseEvent(Client As cWinsock) If LenB(CStr(Client.CurrentUser)) <> 0 Then Debug.Print Client.CurrentUser & " 已离线" ' 无需手动解绑，系统会自动处理 End If End Sub ``` *** **最后更新**: 2026-04-26 --- --- url: /zh/vbman/winsock/best-practices.md --- # cWinsock 最佳实践 ## 📖 目录 * [性能优化](#性能优化) * [错误处理](#错误处理) * [安全建议](#安全建议) * [调试技巧](#调试技巧) * [常见陷阱](#常见陷阱) *** ## 性能优化 ### 1️⃣ 事件处理优化 避免在事件处理中执行耗时操作 ```vb ' ❌ 错误：在事件中处理大量数据 Private Sub m_oServer_DataArrival(Client As cWinsock, ByVal bytesTotal As Long) Dim sData As String Client.GetData sData ' 在事件中进行耗时操作 ProcessLargeData sData ' 可能耗时很久 SaveToDatabase sData ' 可能超时 End Sub ' ✅ 正确：将耗时操作放入队列 Private m_oWorkQueue As Collection Private Sub m_oServer_DataArrival(Client As cWinsock, ByVal bytesTotal As Long) Dim sData As String Client.GetData sData ' 添加到工作队列 m_oWorkQueue.Add Array(Client.Tag, sData) ' 定时器处理队列 tmrWorkQueue_Timer End Sub Private Sub tmrWorkQueue_Timer() Dim vItem As Variant Dim sTag As String Dim sData As String If m_oWorkQueue.Count > 0 Then vItem = m_oWorkQueue(1) sTag = vItem(0) sData = vItem(1) ' 处理数据 ProcessData sTag, sData ' 从队列移除 m_oWorkQueue.Remove 1 End If End Sub ``` *** ### 2️⃣ 缓冲区大小优化 根据应用场景调整缓冲区大小 ```vb ' 小数据频繁传输 Private Const SMALL_BUFFER_SIZE As Long = 1024 ' 1KB ' 大数据块传输 Private Const LARGE_BUFFER_SIZE As Long = 65536 ' 64KB ' 文件传输 Private Const FILE_CHUNK_SIZE As Long = 8192 ' 8KB ' 使用示例 Private Sub SendOptimal(ByVal sData As String) Dim lSize As Long lSize = Len(sData) If lSize < SMALL_BUFFER_SIZE Then ' 小数据，直接发送 m_oClient.SendData sData Else ' 大数据，分块发送 Dim lOffset As Long lOffset = 1 Do While lOffset <= lSize Dim sChunk As String sChunk = Mid$(sData, lOffset, FILE_CHUNK_SIZE) m_oClient.SendData sChunk lOffset = lOffset + FILE_CHUNK_SIZE ' 等待发送完成 Do While m_bSending DoEvents Loop Loop End If End Sub ``` *** ### 3️⃣ 连接池管理 对于需要频繁建立连接的场景，使用连接池 ```vb ' 连接池类 Private Type tConnection Socket As cWinsock InUse As Boolean LastUsed As Date End Type Private m_oConnections() As tConnection Private m_lPoolSize As Long ' 初始化连接池 Private Sub InitConnectionPool(ByVal lSize As Long) ReDim m_oConnections(0 To lSize - 1) As tConnection m_lPoolSize = lSize Dim i As Long For i = 0 To lSize - 1 Set m_oConnections(i).Socket = New cWinsock m_oConnections(i).InUse = False m_oConnections(i).LastUsed = Now Next End Sub ' 获取连接 Private Function GetConnection() As cWinsock Dim i As Long ' 查找可用连接 For i = 0 To m_lPoolSize - 1 If Not m_oConnections(i).InUse Then If m_oConnections(i).Socket.State = sckConnected Then m_oConnections(i).InUse = True Set GetConnection = m_oConnections(i).Socket Exit Function End If End If Next ' 没有可用连接，返回 Nothing Set GetConnection = Nothing End Function ' 释放连接 Private Sub ReleaseConnection(ByVal oSocket As cWinsock) Dim i As Long For i = 0 To m_lPoolSize - 1 If m_oConnections(i).Socket Is oSocket Then m_oConnections(i).InUse = False m_oConnections(i).LastUsed = Now Exit For End If Next End Sub ``` *** ### 4️⃣ 批量发送优化 ```vb ' 批量发送 Private Sub SendBatch(ByVal vData() As Variant) Const BATCH_SIZE As Long = 100 Dim lStart As Long lStart = LBound(vData) Do While lStart <= UBound(vData) Dim lEnd As Long lEnd = Min(lStart + BATCH_SIZE - 1, UBound(vData)) Dim lBatchCount As Long lBatchCount = lEnd - lStart + 1 ' 一次性发送多个数据包（使用分隔符） Dim i As Long Dim sBatch As String For i = lStart To lEnd sBatch = sBatch & vData(i) & vbCrLf Next m_oClient.SendData sBatch ' 等待发送完成 Do While m_bSending DoEvents Loop lStart = lEnd + 1 Loop End Sub ``` *** ## 错误处理 ### 1️⃣ 统一错误处理 ```vb ' 错误处理模块 Public Enum ErrorLevel elInfo = 0 elWarning = 1 elError = 2 elCritical = 3 End Enum ' 统一错误日志 Public Sub LogError(ByVal eLevel As ErrorLevel, ByVal sSource As String, ByVal sMessage As String, ByVal lErrNum As Long) Dim sPrefix As String Select Case eLevel Case elInfo: sPrefix = "[INFO]" Case elWarning: sPrefix = "[WARN]" Case elError: sPrefix = "[ERROR]" Case elCritical: sPrefix = "[CRIT]" End Select Dim sLog As String sLog = Format$(Now, "yyyy-mm-dd hh:mm:ss") & " " & sPrefix & " [" & sSource & "] " & sMessage & " (Error " & lErrNum & ")" Debug.Print sLog ' 写入文件 WriteToLogFile sLog End Sub ' 使用示例 Private Sub m_oClient_Error(Client As cWinsock, ByVal Number As Long, Description As String, ByVal Scode As Long) LogError elError, "Client", Description, Number Select Case Number Case 10053, 10054 ' 连接关闭，正常 LogError elInfo, "Client", "连接被远程关闭", Number Case 10060 ' 连接超时 LogError elWarning, "Client", "连接超时", Number Case Else ' 其他错误 LogError elError, "Client", Description, Number End Select End Sub ``` *** ### 2️⃣ 重试机制 ```vb ' 带重试的操作 Private Function DoWithRetry(ByVal sFuncName As String, ByVal lMaxRetries As Long, ByVal vFunc As Variant) As Boolean Dim lRetry As Long Dim bSuccess As Boolean For lRetry = 1 To lMaxRetries On Error Resume Next bSuccess = CallByName(vFunc, sFuncName, VbMethod) If bSuccess And Err.Number = 0 Then LogError elInfo, "Retry", sFuncName & " 成功 (尝试 " & lRetry & "/" & lMaxRetries & ")", 0 DoWithRetry = True Exit Function End If LogError elWarning, "Retry", sFuncName & " 失败 (尝试 " & lRetry & "/" & lMaxRetries & ")", Err.Number ' 等待后重试 Sleep 1000 * lRetry Next LogError elError, "Retry", sFuncName & " 失败，超过最大重试次数", 0 DoWithRetry = False End Function ' 使用示例 Private Function SendDataWithRetry(ByVal sData As String) As Boolean On Error Resume Next m_oClient.SendData sData SendDataWithRetry = (Err.Number = 0) End Function Private Sub SendImportantData(ByVal sData As String) If Not DoWithRetry("SendDataWithRetry", 3, Me) Then LogError elCritical, "Send", "无法发送重要数据", 0 End If End Sub ``` *** ### 3️⃣ 资源清理 ```vb ' 确保资源清理 Private Sub SafeCloseSocket(ByRef oSocket As cWinsock) On Error Resume Next If Not oSocket Is Nothing Then If oSocket.State <> sckClosed Then oSocket.Close_ Debug.Print "Socket 已关闭" End If Set oSocket = Nothing End If End Sub ' 窗体卸载时清理所有资源 Private Sub Form_Unload(Cancel As Integer) On Error Resume Next ' 关闭所有 socket SafeCloseSocket m_oClient SafeCloseSocket m_oServer SafeCloseSocket m_oUdp ' 停止所有定时器 tmrHeartbeat.Enabled = False tmrCleanup.Enabled = False ' 清理集合 Set m_oWorkQueue = Nothing Set m_oClients = Nothing Debug.Print "所有资源已清理" End Sub ``` *** ## 安全建议 ### 1️⃣ 连接验证 ```vb ' 连接前验证 Private Function ValidateConnection(ByVal sHost As String, ByVal lPort As Long) As Boolean ' 检查白名单 If Not IsWhitelisted(sHost) Then LogError elWarning, "Security", sHost & " 不在白名单中", 0 ValidateConnection = False Exit Function End If ' 检查端口范围 If lPort < 1024 Or lPort > 65535 Then LogError elWarning, "Security", "端口 " & lPort & " 超出允许范围", 0 ValidateConnection = False Exit Function End If ' 检查连接数限制 If m_oServer.ClientCount >= MAX_CONNECTIONS Then LogError elWarning, "Security", "达到最大连接数", 0 ValidateConnection = False Exit Function End If ValidateConnection = True End Function ' 使用 Private Sub m_oServer_ConnectionRequest(Client As cWinsock, ByRef DisConnect As Boolean) If Not ValidateConnection(Client.RemoteHostIP, Client.RemotePort) Then DisConnect = True End If End Sub ``` *** ### 2️⃣ 数据验证 ```vb ' 验证接收的数据 Private Function ValidateData(ByVal sData As String) As Boolean ' 检查长度 If Len(sData) > MAX_DATA_SIZE Then LogError elWarning, "Security", "数据大小超过限制", 0 ValidateData = False Exit Function End If ' 检查危险字符 If InStr(sData, " 0 Or InStr(sData, "javascript:") > 0 Then LogError elWarning, "Security", "检测到危险内容", 0 ValidateData = False Exit Function End If ' 自定义验证 If Not CustomValidation(sData) Then ValidateData = False Exit Function End If ValidateData = True End Function ' 使用 Private Sub m_oServer_DataArrival(Client As cWinsock, ByVal bytesTotal As Long) Dim sData As String Client.GetData sData If Not ValidateData(sData) Then LogError elError, "Security", "拒绝无效数据", 0 Client.Close_ Exit Sub End If ' 处理数据 ProcessData sData End Sub ``` *** ### 3️⃣ 防止缓冲区溢出 ```vb ' 限制缓冲区大小 Private Const MAX_BUFFER_SIZE As Long = 1048576 ' 1MB Private Sub m_oClient_DataArrival(Client As cWinsock, ByVal bytesTotal As Long) ' 检查缓冲区大小 If Client.BytesReceived > MAX_BUFFER_SIZE Then LogError elCritical, "Security", "缓冲区溢出，关闭连接", 0 Client.Close_ Exit Sub End If ' 读取数据 Dim sData As String Client.GetData sData End Sub ``` *** ### 4️⃣ 速率限制 ```vb ' 速率限制 Private Type tRateLimit Window As Date RequestCount As Long End Type Private m_oRateLimits As Collection Private Const MAX_REQUESTS_PER_MINUTE As Long = 60 Private Function CheckRateLimit(ByVal sIP As String) As Boolean Dim tLimit As tRateLimit On Error Resume Next tLimit = m_oRateLimits(sIP) ' 如果是新 IP，创建记录 If Err.Number <> 0 Then tLimit.Window = Now tLimit.RequestCount = 0 m_oRateLimits.Add tLimit, sIP End If ' 检查时间窗口 If DateDiff("s", tLimit.Window, Now) > 60 Then ' 超过 1 分钟，重置 tLimit.Window = Now tLimit.RequestCount = 0 End If ' 检查请求数 If tLimit.RequestCount >= MAX_REQUESTS_PER_MINUTE Then LogError elWarning, "Security", sIP & " 超过速率限制", 0 CheckRateLimit = False Else tLimit.RequestCount = tLimit.RequestCount + 1 m_oRateLimits.Remove sIP m_oRateLimits.Add tLimit, sIP CheckRateLimit = True End If End Function ' 使用 Private Sub m_oServer_ConnectionRequest(Client As cWinsock, ByRef DisConnect As Boolean) If Not CheckRateLimit(Client.RemoteHostIP) Then DisConnect = True End If End Sub ``` *** ## 调试技巧 ### 1️⃣ 详细的日志记录 ```vb ' 日志级别 Public Enum LogLevel llDebug = 0 llInfo = 1 llWarning = 2 llError = 3 End Enum Public m_eLogLevel As LogLevel ' 带级别的日志 Public Sub Log(ByVal eLevel As LogLevel, ByVal sSource As String, ByVal sMessage As String) If eLevel < m_eLogLevel Then Exit Sub Dim sPrefix As String Select Case eLevel Case llDebug: sPrefix = "[DEBUG]" Case llInfo: sPrefix = "[INFO]" Case llWarning: sPrefix = "[WARN]" Case llError: sPrefix = "[ERROR]" End Select Dim sLog As String sLog = Format$(Now, "hh:mm:ss") & " " & sPrefix & " [" & sSource & "] " & sMessage Debug.Print sLog ' 写入日志文件 WriteLogToFile sLog End Sub ' 使用 Private Sub m_oClient_Connect(Client As cWinsock) Log llInfo, "Client", "已连接到 " & Client.RemoteHostIP & ":" & Client.RemotePort End Sub Private Sub m_oClient_DataArrival(Client As cWinsock, ByVal bytesTotal As Long) Log llDebug, "Client", "收到 " & bytesTotal & " 字节" Dim sData As String Client.GetData sData Log llDebug, "Client", "数据内容: " & Left$(sData, 100) ' 只记录前 100 字符 End Sub ``` *** ### 2️⃣ 数据包捕获 ```vb ' 数据包捕获 Private Type tPacketCapture Timestamp As Date Direction As String ' "IN" or "OUT" Data As String Size As Long End Type Private m_oPackets As Collection Private Sub CapturePacket(ByVal sDir As String, ByVal sData As String) Dim tPacket As tPacketCapture tPacket.Timestamp = Now tPacket.Direction = sDir tPacket.Data = Left$(sData, 200) ' 限制长度 tPacket.Size = Len(sData) m_oPackets.Add tPacket Debug.Print "[" & sDir & "] " & Format$(tPacket.Timestamp, "hh:mm:ss") & " " & Len(sData) & " bytes" End Sub ' 使用 Private Sub m_oClient_DataArrival(Client As cWinsock, ByVal bytesTotal As Long) Dim sData As String Client.GetData sData CapturePacket "IN", sData End Sub Private Sub cmdSend_Click() Dim sData As String sData = txtSend.Text m_oClient.SendData sData CapturePacket "OUT", sData End Sub ``` *** ### 3️⃣ 性能监控 ```vb ' 性能统计 Private Type tPerformanceStats TotalPackets As Long TotalBytes As Long StartTime As Date PacketsPerSecond As Double BytesPerSecond As Double End Type Private m_oStats As tPerformanceStats ' 初始化统计 Private Sub InitStats() m_oStats.TotalPackets = 0 m_oStats.TotalBytes = 0 m_oStats.StartTime = Now End Sub ' 更新统计 Private Sub UpdateStats(ByVal lBytes As Long) m_oStats.TotalPackets = m_oStats.TotalPackets + 1 m_oStats.TotalBytes = m_oStats.TotalBytes + lBytes Dim lElapsed As Double lElapsed = DateDiff("s", m_oStats.StartTime, Now) If lElapsed > 0 Then m_oStats.PacketsPerSecond = m_oStats.TotalPackets / lElapsed m_oStats.BytesPerSecond = m_oStats.TotalBytes / lElapsed End If End Sub ' 显示统计 Private Sub ShowStats() Debug.Print "===== 性能统计 =====" Debug.Print "运行时间: " & DateDiff("s", m_oStats.StartTime, Now) & " 秒" Debug.Print "总包数: " & m_oStats.TotalPackets Debug.Print "总字节数: " & m_oStats.TotalBytes Debug.Print "包/秒: " & Format$(m_oStats.PacketsPerSecond, "0.00") Debug.Print "字节/秒: " & Format$(m_oStats.BytesPerSecond, "0.00") Debug.Print "==================" End Sub ``` *** ## 封包协议最佳实践 ### 1️⃣ 选择合适的协议类型 | 协议类型 | 适用场景 | 优缺点 | |----------|----------|--------| | `ppDelimiter` | 文本协议（聊天、命令行式） | 简单直观，但数据中不能包含分隔符 | | `ppFixedLength` | 固定格式消息（状态包、传感器数据） | 解析最快，但不灵活 | | `ppLengthHeader` | 二进制协议、变长消息 | 最通用，支持任意数据内容 | ### 2️⃣ 分隔符协议注意事项 ```vb ' ❌ 错误：分隔符出现在数据中 m_oServer.Delimiter = vbCrLf Client.SendData "Line1" & vbCrLf & "Line2" ' 会被拆成两条消息 ' ✅ 正确：选择数据中不会出现的分隔符 m_oServer.Delimiter = vbNullChar ' 空字符分隔 ' 或 m_oServer.Delimiter = "" ' 自定义结束标记 ``` ### 3️⃣ 长度头协议的字节序 ```vb ' 与 C/Java 服务端通信时注意字节序 ' C/Java 网络编程通常用大端序（网络字节序） m_oServer.HeaderEndian = eeBigEndian ' 纯 VB6 内部通信可用小端序（默认） m_oServer.HeaderEndian = eeLittleEndian ``` ### 4️⃣ 协议模式下的数据获取 ```vb ' ✅ 推荐：协议模式下使用 MessageArrival 事件 Private Sub m_oServer_MessageArrival(Client As cWinsock, ByVal bytesTotal As Long) ' 此时缓冲区中已是完整消息 Dim sData As String sData = Client.GetDataText() End Sub ' ⚠️ DataArrival 也会触发（向后兼容），但数据可能不完整 ' 在协议模式下，建议使用 MessageArrival ``` ### 5️⃣ 心跳与协议配合 ```vb ' 心跳数据经过协议编码发送和接收，不会污染协议状态机 ' 因此无需手动过滤心跳包 ' 协议模式下，心跳包和其他正常消息一样走 Encode/Decode ' 只触发 MessageArrival，不会导致协议状态混乱 ' 无需手动处理心跳包过滤 ``` *** ## 常见陷阱 ### 1️⃣ 忘记 `DoEvents` ```vb ' ❌ 错误：长时间处理会阻塞 UI Private Sub m_oServer_DataArrival(Client As cWinsock, ByVal bytesTotal As Long) Dim sData As String Client.GetData sData ' 长时间操作，UI 会冻结 ProcessLargeData sData End Sub ' ✅ 正确：定期释放控制权 Private Sub m_oServer_DataArrival(Client As cWinsock, ByVal bytesTotal As Long) Dim sData As String Client.GetData sData Dim i As Long For i = 1 To 1000 ProcessDataChunk sData, i ' 定期释放控制权 If i Mod 10 = 0 Then DoEvents End If Next End Sub ``` *** ### 2️⃣ 内存泄漏 ```vb ' ❌ 错误：不及时释放对象 Private Sub ProcessClients() Dim oClient As cWinsock For Each oClient In m_oServer.Clients Dim oData As New CDataObject oData.Data = "xxx" ' oData 没有释放 Next End Sub ' ✅ 正确：及时释放 Private Sub ProcessClients() Dim oClient As cWinsock For Each oClient In m_oServer.Clients Dim oData As New CDataObject oData.Data = "xxx" ' 使用后立即释放 Set oData = Nothing Next End Sub ``` *** ### 3️⃣ 忽略状态检查 ```vb ' ❌ 错误：不检查状态就操作 Private Sub cmdSend_Click() m_oClient.SendData "Hello" ' 可能失败 End Sub ' ✅ 正确：先检查状态 Private Sub cmdSend_Click() If m_oClient.State = sckConnected Then m_oClient.SendData "Hello" Else MsgBox "未连接", vbExclamation End If End Sub ``` *** ### 4️⃣ 错误的编码使用 ```vb ' ❌ 错误：编码不一致 m_oClient.SendData "中文", ScpUtf8 ' UTF-8 ' 接收时 Client.GetData sData ' 默认 ACP → 乱码 ' ✅ 正确：保持一致 m_oClient.SendData "中文", ScpUtf8 ' UTF-8 ' 接收时 Client.GetData sData, , , ScpUtf8 ' UTF-8 ``` *** ### 5️⃣ 协议模式下使用 DataArrival ```vb ' ❌ 错误：协议模式下使用 DataArrival 处理消息 ' 协议模式下 DataArrival 不会触发！ Private Sub m_oServer_DataArrival(Client As cWinsock, ByVal bytesTotal As Long) ' 协议模式下不会走到这里 End Sub ' ✅ 正确：使用 MessageArrival 处理完整消息 Private Sub m_oServer_MessageArrival(Client As cWinsock, ByVal bytesTotal As Long) Dim sData As String sData = Client.GetDataText() ' 保证是完整消息 ProcessMessage sData End Sub ``` *** ### 6️⃣ 忘记启用心跳 ```vb ' ❌ 错误：只设置超时但未启用心跳 m_oServer.HeartbeatTimeout = 120 ' 忘了 m_oServer.AutoHeartbeat = True，心跳不会运行 ' ✅ 正确：设置后启用 m_oServer.HeartbeatTimeout = 120 m_oServer.AutoHeartbeat = True ' 关键：启用后内嵌 cTimer 自动驱动 ``` *** **最后更新**: 2026-06-09 --- --- url: /en/vbman/winsock/best-practices.md --- # cWinsock Best Practices ## 📖 Table of Contents * [Performance Optimization](#performance-optimization) * [Error Handling](#error-handling) * [Security Recommendations](#security-recommendations) * [Debugging Techniques](#debugging-techniques) * [Common Pitfalls](#common-pitfalls) *** ## Performance Optimization ### 1️⃣ Event Processing Optimization Avoid executing time-consuming operations in event handlers ```vb ' ❌ Wrong: Processing large data in event Private Sub m_oServer_DataArrival(Client As cWinsock, ByVal bytesTotal As Long) Dim sData As String Client.GetData sData ' Time-consuming operations in event ProcessLargeData sData ' May take long SaveToDatabase sData ' May timeout End Sub ' ✅ Correct: Put time-consuming operations in queue Private m_oWorkQueue As Collection Private Sub m_oServer_DataArrival(Client As cWinsock, ByVal bytesTotal As Long) Dim sData As String Client.GetData sData ' Add to work queue m_oWorkQueue.Add Array(Client.Tag, sData) ' Timer processes queue tmrWorkQueue_Timer End Sub Private Sub tmrWorkQueue_Timer() Dim vItem As Variant Dim sTag As String Dim sData As String If m_oWorkQueue.Count > 0 Then vItem = m_oWorkQueue(1) sTag = vItem(0) sData = vItem(1) ' Process data ProcessData sTag, sData ' Remove from queue m_oWorkQueue.Remove 1 End If End Sub ``` *** ### 2️⃣ Buffer Size Optimization Adjust buffer size according to application scenarios ```vb ' Small data frequent transmission Private Const SMALL_BUFFER_SIZE As Long = 1024 ' 1KB ' Large data block transmission Private Const LARGE_BUFFER_SIZE As Long = 65536 ' 64KB ' File transfer Private Const FILE_CHUNK_SIZE As Long = 8192 ' 8KB ' Usage example Private Sub SendOptimal(ByVal sData As String) Dim lSize As Long lSize = Len(sData) If lSize < SMALL_BUFFER_SIZE Then ' Small data, send directly m_oClient.SendData sData Else ' Large data, send in chunks Dim lOffset As Long lOffset = 1 Do While lOffset <= lSize Dim sChunk As String sChunk = Mid$(sData, lOffset, FILE_CHUNK_SIZE) m_oClient.SendData sChunk lOffset = lOffset + FILE_CHUNK_SIZE ' Wait for send completion Do While m_bSending DoEvents Loop Loop End If End Sub ``` *** ### 3️⃣ Connection Pool Management Use connection pool for scenarios requiring frequent connections ```vb ' Connection pool class Private Type tConnection Socket As cWinsock InUse As Boolean LastUsed As Date End Type Private m_oConnections() As tConnection Private m_lPoolSize As Long ' Initialize connection pool Private Sub InitConnectionPool(ByVal lSize As Long) ReDim m_oConnections(0 To lSize - 1) As tConnection m_lPoolSize = lSize Dim i As Long For i = 0 To lSize - 1 Set m_oConnections(i).Socket = New cWinsock m_oConnections(i).InUse = False m_oConnections(i).LastUsed = Now Next End Sub ' Get connection Private Function GetConnection() As cWinsock Dim i As Long ' Find available connection For i = 0 To m_lPoolSize - 1 If Not m_oConnections(i).InUse Then If m_oConnections(i).Socket.State = sckConnected Then m_oConnections(i).InUse = True Set GetConnection = m_oConnections(i).Socket Exit Function End If End If Next ' No available connection, return Nothing Set GetConnection = Nothing End Function ' Release connection Private Sub ReleaseConnection(ByVal oSocket As cWinsock) Dim i As Long For i = 0 To m_lPoolSize - 1 If m_oConnections(i).Socket Is oSocket Then m_oConnections(i).InUse = False m_oConnections(i).LastUsed = Now Exit For End If Next End Sub ``` *** ### 4️⃣ Batch Sending Optimization ```vb ' Batch send Private Sub SendBatch(ByVal vData() As Variant) Const BATCH_SIZE As Long = 100 Dim lStart As Long lStart = LBound(vData) Do While lStart <= UBound(vData) Dim lEnd As Long lEnd = Min(lStart + BATCH_SIZE - 1, UBound(vData)) Dim lBatchCount As Long lBatchCount = lEnd - lStart + 1 ' Send multiple data packets at once (using separator) Dim i As Long Dim sBatch As String For i = lStart To lEnd sBatch = sBatch & vData(i) & vbCrLf Next m_oClient.SendData sBatch ' Wait for send completion Do While m_bSending DoEvents Loop lStart = lEnd + 1 Loop End Sub ``` *** ## Error Handling ### 1️⃣ Unified Error Handling ```vb ' Error handling module Public Enum ErrorLevel elInfo = 0 elWarning = 1 elError = 2 elCritical = 3 End Enum ' Unified error log Public Sub LogError(ByVal eLevel As ErrorLevel, ByVal sSource As String, ByVal sMessage As String, ByVal lErrNum As Long) Dim sPrefix As String Select Case eLevel Case elInfo: sPrefix = "[INFO]" Case elWarning: sPrefix = "[WARN]" Case elError: sPrefix = "[ERROR]" Case elCritical: sPrefix = "[CRIT]" End Select Dim sLog As String sLog = Format$(Now, "yyyy-mm-dd hh:mm:ss") & " " & sPrefix & " [" & sSource & "] " & sMessage & " (Error " & lErrNum & ")" Debug.Print sLog ' Write to file WriteToLogFile sLog End Sub ' Usage example Private Sub m_oClient_Error(Client As cWinsock, ByVal Number As Long, Description As String, ByVal Scode As Long) LogError elError, "Client", Description, Number Select Case Number Case 10053, 10054 ' Connection closed, normal LogError elInfo, "Client", "Connection closed by remote", Number Case 10060 ' Connection timeout LogError elWarning, "Client", "Connection timeout", Number Case Else ' Other errors LogError elError, "Client", Description, Number End Select End Sub ``` *** ### 2️⃣ Retry Mechanism ```vb ' Operation with retry Private Function DoWithRetry(ByVal sFuncName As String, ByVal lMaxRetries As Long, ByVal vFunc As Variant) As Boolean Dim lRetry As Long Dim bSuccess As Boolean For lRetry = 1 To lMaxRetries On Error Resume Next bSuccess = CallByName(vFunc, sFuncName, VbMethod) If bSuccess And Err.Number = 0 Then LogError elInfo, "Retry", sFuncName & " success (attempt " & lRetry & "/" & lMaxRetries & ")", 0 DoWithRetry = True Exit Function End If LogError elWarning, "Retry", sFuncName & " failed (attempt " & lRetry & "/" & lMaxRetries & ")", Err.Number ' Wait before retry Sleep 1000 * lRetry Next LogError elError, "Retry", sFuncName & " failed, exceeded max retries", 0 DoWithRetry = False End Function ' Usage example Private Function SendDataWithRetry(ByVal sData As String) As Boolean On Error Resume Next m_oClient.SendData sData SendDataWithRetry = (Err.Number = 0) End Function Private Sub SendImportantData(ByVal sData As String) If Not DoWithRetry("SendDataWithRetry", 3, Me) Then LogError elCritical, "Send", "Cannot send important data", 0 End If End Sub ``` *** ### 3️⃣ Resource Cleanup ```vb ' Ensure resource cleanup Private Sub SafeCloseSocket(ByRef oSocket As cWinsock) On Error Resume Next If Not oSocket Is Nothing Then If oSocket.State <> sckClosed Then oSocket.Close_ Debug.Print "Socket closed" End If Set oSocket = Nothing End If End Sub ' Clean up all resources when form unloads Private Sub Form_Unload(Cancel As Integer) On Error Resume Next ' Close all sockets SafeCloseSocket m_oClient SafeCloseSocket m_oServer SafeCloseSocket m_oUdp ' Stop all timers tmrHeartbeat.Enabled = False tmrCleanup.Enabled = False ' Clean up collections Set m_oWorkQueue = Nothing Set m_oClients = Nothing Debug.Print "All resources cleaned up" End Sub ``` *** ## Security Recommendations ### 1️⃣ Connection Validation ```vb ' Validate before connection Private Function ValidateConnection(ByVal sHost As String, ByVal lPort As Long) As Boolean ' Check whitelist If Not IsWhitelisted(sHost) Then LogError elWarning, "Security", sHost & " not in whitelist", 0 ValidateConnection = False Exit Function End If ' Check port range If lPort < 1024 Or lPort > 65535 Then LogError elWarning, "Security", "Port " & lPort & " out of allowed range", 0 ValidateConnection = False Exit Function End If ' Check connection count limit If m_oServer.ClientCount >= MAX_CONNECTIONS Then LogError elWarning, "Security", "Maximum connections reached", 0 ValidateConnection = False Exit Function End If ValidateConnection = True End Function ' Use Private Sub m_oServer_ConnectionRequest(Client As cWinsock, ByRef DisConnect As Boolean) If Not ValidateConnection(Client.RemoteHostIP, Client.RemotePort) Then DisConnect = True End If End Sub ``` *** ### 2️⃣ Data Validation ```vb ' Validate received data Private Function ValidateData(ByVal sData As String) As Boolean ' Check length If Len(sData) > MAX_DATA_SIZE Then LogError elWarning, "Security", "Data size exceeds limit", 0 ValidateData = False Exit Function End If ' Check dangerous characters If InStr(sData, " 0 Or InStr(sData, "javascript:") > 0 Then LogError elWarning, "Security", "Detected dangerous content", 0 ValidateData = False Exit Function End If ' Custom validation If Not CustomValidation(sData) Then ValidateData = False Exit Function End If ValidateData = True End Function ' Use Private Sub m_oServer_DataArrival(Client As cWinsock, ByVal bytesTotal As Long) Dim sData As String Client.GetData sData If Not ValidateData(sData) Then LogError elError, "Security", "Reject invalid data", 0 Client.Close_ Exit Sub End If ' Process data ProcessData sData End Sub ``` *** ### 3️⃣ Prevent Buffer Overflow ```vb ' Limit buffer size Private Const MAX_BUFFER_SIZE As Long = 1048576 ' 1MB Private Sub m_oClient_DataArrival(Client As cWinsock, ByVal bytesTotal As Long) ' Check buffer size If Client.BytesReceived > MAX_BUFFER_SIZE Then LogError elCritical, "Security", "Buffer overflow, closing connection", 0 Client.Close_ Exit Sub End If ' Read data Dim sData As String Client.GetData sData End Sub ``` *** ### 4️⃣ Rate Limiting ```vb ' Rate limiting Private Type tRateLimit Window As Date RequestCount As Long End Type Private m_oRateLimits As Collection Private Const MAX_REQUESTS_PER_MINUTE As Long = 60 Private Function CheckRateLimit(ByVal sIP As String) As Boolean Dim tLimit As tRateLimit On Error Resume Next tLimit = m_oRateLimits(sIP) ' If new IP, create record If Err.Number <> 0 Then tLimit.Window = Now tLimit.RequestCount = 0 m_oRateLimits.Add tLimit, sIP End If ' Check time window If DateDiff("s", tLimit.Window, Now) > 60 Then ' Exceeded 1 minute, reset tLimit.Window = Now tLimit.RequestCount = 0 End If ' Check request count If tLimit.RequestCount >= MAX_REQUESTS_PER_MINUTE Then LogError elWarning, "Security", sIP & " exceeded rate limit", 0 CheckRateLimit = False Else tLimit.RequestCount = tLimit.RequestCount + 1 m_oRateLimits.Remove sIP m_oRateLimits.Add tLimit, sIP CheckRateLimit = True End If End Function ' Use Private Sub m_oServer_ConnectionRequest(Client As cWinsock, ByRef DisConnect As Boolean) If Not CheckRateLimit(Client.RemoteHostIP) Then DisConnect = True End If End Sub ``` *** ## Debugging Techniques ### 1️⃣ Detailed Logging ```vb ' Log levels Public Enum LogLevel llDebug = 0 llInfo = 1 llWarning = 2 llError = 3 End Enum Public m_eLogLevel As LogLevel ' Logging with levels Public Sub Log(ByVal eLevel As LogLevel, ByVal sSource As String, ByVal sMessage As String) If eLevel < m_eLogLevel Then Exit Sub Dim sPrefix As String Select Case eLevel Case llDebug: sPrefix = "[DEBUG]" Case llInfo: sPrefix = "[INFO]" Case llWarning: sPrefix = "[WARN]" Case llError: sPrefix = "[ERROR]" End Select Dim sLog As String sLog = Format$(Now, "hh:mm:ss") & " " & sPrefix & " [" & sSource & "] " & sMessage Debug.Print sLog ' Write to log file WriteLogToFile sLog End Sub ' Use Private Sub m_oClient_Connect(Client As cWinsock) Log llInfo, "Client", "Connected to " & Client.RemoteHostIP & ":" & Client.RemotePort End Sub Private Sub m_oClient_DataArrival(Client As cWinsock, ByVal bytesTotal As Long) Log llDebug, "Client", "Received " & bytesTotal & " bytes" Dim sData As String Client.GetData sData Log llDebug, "Client", "Data content: " & Left$(sData, 100) ' Only log first 100 chars End Sub ``` *** ### 2️⃣ Packet Capture ```vb ' Packet capture Private Type tPacketCapture Timestamp As Date Direction As String ' "IN" or "OUT" Data As String Size As Long End Type Private m_oPackets As Collection Private Sub CapturePacket(ByVal sDir As String, ByVal sData As String) Dim tPacket As tPacketCapture tPacket.Timestamp = Now tPacket.Direction = sDir tPacket.Data = Left$(sData, 200) ' Limit length tPacket.Size = Len(sData) m_oPackets.Add tPacket Debug.Print "[" & sDir & "] " & Format$(tPacket.Timestamp, "hh:mm:ss") & " " & Len(sData) & " bytes" End Sub ' Use Private Sub m_oClient_DataArrival(Client As cWinsock, ByVal bytesTotal As Long) Dim sData As String Client.GetData sData CapturePacket "IN", sData End Sub Private Sub cmdSend_Click() Dim sData As String sData = txtSend.Text m_oClient.SendData sData CapturePacket "OUT", sData End Sub ``` *** ### 3️⃣ Performance Monitoring ```vb ' Performance statistics Private Type tPerformanceStats TotalPackets As Long TotalBytes As Long StartTime As Date PacketsPerSecond As Double BytesPerSecond As Double End Type Private m_oStats As tPerformanceStats ' Initialize statistics Private Sub InitStats() m_oStats.TotalPackets = 0 m_oStats.TotalBytes = 0 m_oStats.StartTime = Now End Sub ' Update statistics Private Sub UpdateStats(ByVal lBytes As Long) m_oStats.TotalPackets = m_oStats.TotalPackets + 1 m_oStats.TotalBytes = m_oStats.TotalBytes + lBytes Dim lElapsed As Double lElapsed = DateDiff("s", m_oStats.StartTime, Now) If lElapsed > 0 Then m_oStats.PacketsPerSecond = m_oStats.TotalPackets / lElapsed m_oStats.BytesPerSecond = m_oStats.TotalBytes / lElapsed End If End Sub ' Display statistics Private Sub ShowStats() Debug.Print "===== Performance Statistics =====" Debug.Print "Runtime: " & DateDiff("s", m_oStats.StartTime, Now) & " seconds" Debug.Print "Total packets: " & m_oStats.TotalPackets Debug.Print "Total bytes: " & m_oStats.TotalBytes Debug.Print "Packets/sec: " & Format$(m_oStats.PacketsPerSecond, "0.00") Debug.Print "Bytes/sec: " & Format$(m_oStats.BytesPerSecond, "0.00") Debug.Print "==================================" End Sub ``` *** ## Common Pitfalls ### 1️⃣ Forgetting `DoEvents` ```vb ' ❌ Wrong: Long processing blocks UI Private Sub m_oServer_DataArrival(Client As cWinsock, ByVal bytesTotal As Long) Dim sData As String Client.GetData sData ' Long operation, UI freezes ProcessLargeData sData End Sub ' ✅ Correct: Periodically release control Private Sub m_oServer_DataArrival(Client As cWinsock, ByVal bytesTotal As Long) Dim sData As String Client.GetData sData Dim i As Long For i = 1 To 1000 ProcessDataChunk sData, i ' Periodically release control If i Mod 10 = 0 Then DoEvents End If Next End Sub ``` *** ### 2️⃣ Memory Leaks ```vb ' ❌ Wrong: Not releasing objects in time Private Sub ProcessClients() Dim oClient As cWinsock For Each oClient In m_oServer.Clients Dim oData As New CDataObject oData.Data = "xxx" ' oData not released Next End Sub ' ✅ Correct: Release in time Private Sub ProcessClients() Dim oClient As cWinsock For Each oClient In m_oServer.Clients Dim oData As New CDataObject oData.Data = "xxx" ' Release immediately after use Set oData = Nothing Next End Sub ``` *** ### 3️⃣ Ignoring State Check ```vb ' ❌ Wrong: Operating without checking state Private Sub cmdSend_Click() m_oClient.SendData "Hello" ' May fail End Sub ' ✅ Correct: Check state first Private Sub cmdSend_Click() If m_oClient.State = sckConnected Then m_oClient.SendData "Hello" Else MsgBox "Not connected", vbExclamation End If End Sub ``` *** ### 4️⃣ Wrong Encoding Usage ```vb ' ❌ Wrong: Inconsistent encoding m_oClient.SendData "中文", ScpUtf8 ' UTF-8 ' When receiving Client.GetData sData ' Default ACP → garbled ' ✅ Correct: Keep consistent m_oClient.SendData "中文", ScpUtf8 ' UTF-8 ' When receiving Client.GetData sData, , , ScpUtf8 ' UTF-8 ``` *** **Last Updated**: 2026-01-09 --- --- url: /en/vbman/winsock/overview.md --- # cWinsock Class Development Documentation\r\n\r\n> 🚀 **cWinsock** - Simplified VB6 Winsock wrapper library, developed by woeoio@qq.com based on VbAsyncSocket (author: wqweto@gmail.com)\r\n\r\n## 📖 Table of Contents\r\n\r\n- [Overview](#overview)\r\n- [Core Highlights](#core-highlights)\r\n- [Comparison with Native Winsock Control](#comparison-with-native-winsock-control)\r\n- [Quick Start](#quick-start)\r\n- [Architecture Design](#architecture-design)\r\n- [Documentation Index](#documentation-index)\r\n\r\n---\r\n\r\n## Overview\r\n\r\n`cWinsock` is a lightweight network communication class designed for VB6, providing an event-driven programming model similar to the classic Winsock control, but with a simpler API and more powerful features.\r\n\r\n### ✨ Main Features\r\n\r\n- 🔌 **Pure class implementation** - No controls required, direct object programming\r\n- 🎯 **Direct object reference** - Event parameters directly pass client objects, no index lookup needed\r\n- 🌐 **Dual protocol support** - Simultaneously supports TCP and UDP communication\r\n- 🏢 **Automatic client management** - Server mode automatically manages all connected clients\r\n- 📦 **Smart data encoding** - Supports multiple text encodings (GBK/ACP, UTF-8, Unicode)\r\n- 🛡️ **Connection interception** - Blacklist/whitelist mechanism via `ConnectionRequest` event\r\n- 🔄 **Event proxy mechanism** - Server client data unified through server event triggering\r\n- 💾 **Flexible data types** - Supports both string and byte array data formats\r\n- 📦 **Data packet protocol** - Three built-in protocols solve TCP fragmentation/sticky packet, automatic packet/unpacket\r\n- 💓 **Smart heartbeat mechanism** - Embedded timer auto-drive, server timeout detection, client smart keep-alive\r\n- 🔒 **TLS/SSL support** - Chain function configuration for TLS, both client and server can encrypt communication\r\n- 🎯 **GetData enhanced** - Return value style convenience methods, one-line code to get text/Hex/byte array\r\n\r\n---\r\n\r\n## Core Highlights\r\n\r\n### 1️⃣ Direct Object Reference Event Model 🔗\r\n\r\n**Traditional Winsock control problems:**\r\n`vb\r\n' Need to manage clients via index\r\nPrivate Sub Winsock1_ConnectionRequest(Index As Integer, ByVal requestID As Long)\r\n Dim i As Integer\r\n ' Find available index or dynamically load control...\r\nEnd Sub\r\n\r\n' When processing data, need to know which client\r\nPrivate Sub Winsock1_DataArrival(Index As Integer, ByVal bytesTotal As Long)\r\n Winsock1(Index).GetData strData\r\nEnd Sub\r\n`\r\n\r\n**cWinsock's elegant solution:**\r\n`vb\r\n' Event directly passes client object!\r\nPrivate Sub m_oServer_ConnectionRequest(Client As cWinsock, ByRef DisConnect As Boolean)\r\n ' Directly operate on Client object, no index needed\r\n Debug.Print "New client: " & Client.RemoteHostIP\r\n \r\n ' Reject blacklist IP\r\n If IsBlacklisted(Client.RemoteHostIP) Then\r\n DisConnect = True\r\n End If\r\nEnd Sub\r\n\r\n' Data event also directly passes client object\r\nPrivate Sub m_oServer_DataArrival(Client As cWinsock, ByVal bytesTotal As Long)\r\n Dim sData As String\r\n Client.GetData sData\r\n ' Directly read data from Client object, no index lookup needed\r\nEnd Sub\r\n`\r\n\r\n---\r\n\r\n### 2️⃣ Smart TCP Client Event Proxy 📡\r\n\r\n**Problem scenario:** After server accepts new connection and creates client object, its data reception event cannot be subscribed by host.\r\n\r\n**cWinsock's solution:** Automatically trigger events through parent server object\r\n\r\n`vb\r\n' In server object's DataArrival event\r\n' Can receive data from all clients!\r\nPrivate Sub m_oServer_DataArrival(Client As cWinsock, ByVal bytesTotal As Long)\r\n Dim sData As String\r\n Client.GetData sData\r\n \r\n ' Client parameter is the specific client object\r\n ' Can directly reply to that client\r\n Client.SendData "Echo: " & sData\r\nEnd Sub\r\n`\r\n\r\n**How it works:**\r\n1. Server accepts new connection, creates independent client socket object\r\n2. Client receives data, triggers event via parent server's `RaiseDataArrivalEvent` method\r\n3. Host only needs to subscribe to server object events to handle all client data\r\n\r\n---\r\n\r\n### 3️⃣ UDP Server Virtual Client Management 🎭\r\n\r\nUDP is a connectionless protocol, but `cWinsock` creates virtual client objects for each different remote address:port combination, simulating connection behavior:\r\n\r\n`vb\r\n' UDP server mode\r\nPrivate Sub m_oUdp_ConnectionRequest(Client As cWinsock, ByRef DisConnect As Boolean)\r\n ' Each remote address:port combination that communicates for the first time\r\n ' Automatically creates a virtual Client object\r\n Debug.Print "UDP client: " & Client.RemoteHostIP & ":" & Client.RemotePort\r\nEnd Sub\r\n\r\nPrivate Sub m_oUdp_DataArrival(Client As cWinsock, ByVal bytesTotal As Long)\r\n Dim sData As String\r\n Client.GetData sData\r\n \r\n ' Can reply to specific virtual client\r\n ' cWinsock automatically uses correct target address:port\r\n Client.SendData "Reply: " & sData\r\nEnd Sub\r\n`\r\n\r\n---\r\n\r\n### 4️⃣ Connection Request Interception Mechanism 🚦\r\n\r\nImplement connection interception via `DisConnect` parameter in `ConnectionRequest` event:\r\n\r\n`vb\r\nPrivate Sub m_oServer_ConnectionRequest(Client As cWinsock, ByRef DisConnect As Boolean)\r\n ' Blacklist check\r\n If IsInBlacklist(Client.RemoteHostIP) Then\r\n Debug.Print "Reject blacklist IP: " & Client.RemoteHostIP\r\n DisConnect = True ' Set to True, automatically disconnect and cleanup resources\r\n Exit Sub\r\n End If\r\n \r\n ' Port range restriction\r\n If Client.RemotePort < 1024 Then\r\n Debug.Print "Reject privileged port connection: " & Client.RemotePort\r\n DisConnect = True\r\n Exit Sub\r\n End If\r\n \r\n ' Whitelist mode\r\n If m_bWhitelistMode And Not IsInWhitelist(Client.RemoteHostIP) Then\r\n Debug.Print "Not in whitelist, reject connection"\r\n DisConnect = True\r\n Exit Sub\r\n End If\r\n \r\n ' Keep DisConnect False, accept connection\r\n Debug.Print "Accept connection: " & Client.RemoteHostIP & ":" & Client.RemotePort\r\nEnd Sub\r\n`\r\n\r\n---\r\n\r\n### 5️⃣ Flexible Text Encoding Support 🔤\r\n\r\nSupports multiple encoding methods to adapt to different scenarios:\r\n\r\n`vb\r\n' Default uses ACP/GBK encoding (compatible with VB6)\r\nClient.SendData "中文测试"\r\nClient.GetData sData ' Default ACP\r\n\r\n' Use UTF-8 encoding (recommended for network transmission)\r\nClient.SendData "中文测试", ucsScpUtf8\r\nClient.GetData sData, , , ucsScpUtf8\r\n\r\n' Use Unicode (no conversion, keep wide characters)\r\nClient.SendData "中文测试", ScpUnicode\r\nClient.GetData sData, , , ScpUnicode\r\n\r\n' Send byte array (no encoding involved)\r\nDim baData() As Byte\r\nbaData = GetByteArray()\r\nClient.SendData baData\r\n`\r\n\r\n**Encoding enumeration:**\r\n- `ScpAcp` (0) - System default code page (GBK on Chinese Windows)\r\n- `ScpUtf8` (65001) - UTF-8 encoding\r\n- `ScpUnicode` (-1) - Unicode, no encoding conversion\r\n\r\n---\r\n\r\n### 6️⃣ Automatic Client Collection Management 📚\r\n\r\nIn server mode, automatically maintains all connected clients:\r\n\r\n`vb\r\n' Client collection automatically initialized when server starts\r\nm_oServer.Listen 8080\r\n\r\n' Iterate through all clients\r\nDim oClient As cWinsock\r\nFor Each oClient In m_oServer.Clients\r\n Debug.Print "Client: " & oClient.ClientId & " - " & oClient.RemoteHostIP\r\nNext\r\n\r\n' Get client count\r\nDebug.Print "Current connections: " & m_oServer.ClientCount\r\n\r\n' Manually remove client (usually automatically handled by CloseEvent)\r\nm_oServer.RemoveClient oClient\r\n`\r\n\r\n---\r\n\r\n### 7️⃣ Smart Remote Address Resolution 🌐\r\n\r\nUDP server mode supports domain name resolution:\r\n\r\n`vb\r\n' Set remote address (can be IP or domain name)\r\nm_oUdp.RemoteHost = "example.com"\r\nm_oUdp.RemotePort = 8888\r\n\r\n' Domain name automatically resolved when sending\r\nm_oUdp.SendData "Hello"\r\n`\r\n\r\n**Internal logic:**\r\n`vb\r\n' Smart selection in SendData method\r\nIf LenB(m_sRemoteHostIP) <> 0 Then\r\n ' If resolved IP exists, prioritize using it\r\n m_oSocket.SendText Data, m_sRemoteHostIP, m_lRemotePort, CodePage\r\nElseIf LenB(m_sRemoteHost) <> 0 Then\r\n ' Otherwise use hostname, underlying layer automatically resolves domain name\r\n m_oSocket.SendText Data, m_sRemoteHost, m_lRemotePort, CodePage\r\nEnd If\r\n`\r\n\r\n---\r\n\r\n### 8️⃣ Data Buffer Management 📊\r\n\r\nBuilt-in data buffer, supports partial reading:\r\n\r\n`vb\r\n' When receiving data, only read first 100 bytes\r\nDim sPartial As String\r\nClient.GetData sPartial, vbString, 100\r\n\r\n' Remaining data automatically saved in internal buffer\r\n' Will continue to return remaining data on next read\r\n`\r\n\r\n**Internal buffer mechanism:**\r\n- TCP and client mode: Use `m_baRecvBuffer` private member\r\n- UDP server virtual client: Use `UserData` property for temporary storage\r\n\r\n---\r\n\r\n### 9️⃣ Data Packet Protocol 📦\r\n\r\n**Problem scenario**: TCP is a streaming protocol with data fragmentation and sticky packet issues\r\n\r\n`vb\r\n' Sender sends continuously\r\nClient.SendData "Hello"\r\nClient.SendData "World"\r\n\r\n' Receiver may receive\r\n"HelloWorld" ' Sticky packet\r\n"Hel" ' Fragmentation\r\n"loWorld"\r\n`\r\n\r\n**cWinsock built-in three protocols to solve this:**\r\n- **Character delimiter protocol** (`ppDelimiter`) - Supports custom delimiters (e.g., `\r\n`, `|`, `\0`, etc.)\r\n- **Fixed length protocol** (`ppFixedLength`) - Suitable for fixed-length messages\r\n- **Length header protocol** (`ppLengthHeader`) - Supports 2/4 byte headers, configurable endianness\r\n\r\n**Usage example:**\r\n`vb\r\n' Set character delimiter protocol\r\nServer.PacketProtocol = ppDelimiter\r\nServer.Delimiter = vbCrLf\r\n\r\n' Or set length header protocol\r\nServer.PacketProtocol = ppLengthHeader\r\nServer.HeaderBytes = 4 ' 4-byte length header\r\nServer.HeaderEndian = eeLittleEndian\r\n\r\n' Send automatic packet\r\nClient.SendData "Hello World" ' Automatically append protocol marker\r\n\r\n' Receive automatic unpacket - use MessageArrival event\r\nPrivate Sub Server_MessageArrival(Client As cWinsock, ByVal bytesTotal As Long)\r\n Dim sData As String\r\n Client.GetDataText sData ' Get complete message\r\nEnd Sub\r\n`\r\n\r\n**Key features:**\r\n- Each client has independent protocol instance, buffers isolated from each other\r\n- New clients automatically inherit server protocol configuration\r\n- In protocol mode, **only `MessageArrival` is triggered**, not `DataArrival`, to avoid duplicate reads\r\n- Heartbeat data goes through protocol encoding, does not pollute protocol state machine\r\n- `MaxPacketSize`/`MaxBufferSize` safety limits, prevent malicious packets and memory exhaustion\r\n- UDP clients also support packet protocol\r\n\r\n**Detailed description**: See [Packet Protocol and Heartbeat Mechanism](./packet-protocol.md), [Properties Reference](./properties.md), [Events Reference](./events.md)\r\n\r\n---\r\n\r\n### 🔟 TCP Smart Heartbeat 💓\r\n\r\n**Problem scenario**: TCP connection may silently disconnect due to network issues, need keep-alive mechanism\r\n\r\n**cWinsock built-in heartbeat manager**, embedded `cTimer` auto-drive, no external timer needed:\r\n\r\n`vb\r\n' Server: Timeout detection (default 120 seconds)\r\nServer.HeartbeatTimeout = 120\r\nServer.AutoHeartbeat = True\r\n\r\n' Client: Heartbeat keep-alive (default 50 seconds interval)\r\nClient.HeartbeatInterval = 50\r\nClient.AutoHeartbeat = True\r\n\r\n' Events\r\nPrivate Sub Server_ClientTimeout(Client As cWinsock)\r\n Debug.Print "Client timeout: " & Client.RemoteHostIP\r\n ' Already auto-disconnected, can do cleanup\r\nEnd Sub\r\n\r\nPrivate Sub Client_HeartbeatSent(Client As cWinsock)\r\n Debug.Print "Heartbeat sent"\r\nEnd Sub\r\n`\r\n\r\n**Key features:**\r\n- Embedded `cTimer` (10-second interval), `AutoHeartbeat = True` for full auto operation\r\n- Server: Polls client idle time, auto-disconnects zombie connections on timeout\r\n- Client: Smart skip - skips heartbeat when data send/receive exists, saves bandwidth\r\n- Each send/receive auto-updates `LastActivityTime`\r\n- New clients automatically inherit server heartbeat configuration\r\n- Heartbeat data goes through protocol encoding, does not pollute packet protocol state machine\r\n\r\n**Detailed description**: See [Packet Protocol and Heartbeat Mechanism](./packet-protocol.md), [Properties Reference](./properties.md), [Events Reference](./events.md)\r\n\r\n---\r\n\r\n### 1️⃣1️⃣ GetData Enhanced Methods 🎯\r\n\r\n**Problem scenario**: Getting data requires manual format conversion, code is tedious\r\n\r\n**cWinsock provides return value style convenience methods**, one-line code ready to use:\r\n\r\n`vb\r\n' Directly return text\r\nDebug.Print Client.GetDataText() ' ACP/GBK\r\nDebug.Print Client.GetDataTextUTF8() ' UTF-8\r\nDebug.Print Client.GetDataTextUnicode() ' Unicode\r\n\r\n' Directly return hexadecimal\r\nDebug.Print Client.GetDataHex() ' "48 65 6C 6C 6F"\r\n\r\n' Directly return byte array\r\nDim baData() As Byte\r\nbaData = Client.GetDataByteArray()\r\n\r\n' Condition check\r\nIf Client.GetDataText() = "Hello" Then\r\n Debug.Print "Received Hello"\r\nEnd If\r\n\r\n' Compatible with old method\r\nDim sData As String\r\nsData = Client.GetDataToString() ' Equivalent to GetDataText()\r\n`\r\n\r\n**Detailed description**: See [Methods Reference](./methods.md)\r\n\r\n---\r\n\r\n## Comparison with Native Winsock Control\r\n\r\n| Feature | Native Winsock Control | cWinsock Class |\r\n|---------|------------------------|-----------------|\r\n| **Object model** | Control array, managed via index | Pure class object, direct reference |\r\n| **Event parameters** | Pass index, need reverse lookup object | Directly pass client object |\r\n| **Client management** | Manually maintain index and controls | Automatically manage Clients collection |\r\n| **UDP server** | Connectionless, no client concept | Virtual client objects |\r\n| **Connection interception** | Need to manually close after Accept | Event parameter control, auto cleanup |\r\n| **Encoding support** | Fixed encoding | Multiple encoding options |\r\n| **Data types** | String/byte array | String/byte array + flexible conversion + return value convenience methods |\r\n| **Event unification** | Independent event per client | Server triggers all client events uniformly |\r\n| **Packet protocol** | Need manual sticky packet handling | Three built-in protocols, automatic packet/unpacket |\r\n| **Heartbeat keep-alive** | Need manual implementation | Built-in heartbeat manager, full auto drive |\r\n| **Resource management** | Need to manually Unload controls | Auto cleanup and garbage collection |\r\n\r\n---\r\n\r\n## Quick Start\r\n\r\n### TCP Client Example\r\n\r\n`vb\r\nPrivate WithEvents m_oClient As cWinsock\r\n\r\nPrivate Sub Form_Load()\r\n Set m_oClient = New cWinsock\r\n m_oClient.Protocol = sckTCPProtocol\r\n m_oClient.Connect "127.0.0.1", 8080\r\nEnd Sub\r\n\r\nPrivate Sub m_oClient_Connect(Client As cWinsock)\r\n Debug.Print "Connected to server"\r\n Client.SendData "Hello, Server!"\r\nEnd Sub\r\n\r\nPrivate Sub m_oClient_DataArrival(Client As cWinsock, ByVal bytesTotal As Long)\r\n Dim sData As String\r\n Client.GetData sData\r\n Debug.Print "Received data: " & sData\r\nEnd Sub\r\n\r\nPrivate Sub Form_Unload(Cancel As Integer)\r\n m_oClient.Close_\r\nEnd Sub\r\n`\r\n\r\n### TCP Server Example\r\n\r\n`vb\r\nPrivate WithEvents m_oServer As cWinsock\r\n\r\nPrivate Sub Form_Load()\r\n Set m_oServer = New cWinsock\r\n m_oServer.Protocol = sckTCPProtocol\r\n m_oServer.Listen 8080\r\nEnd Sub\r\n\r\nPrivate Sub m_oServer_ConnectionRequest(Client As cWinsock, ByRef DisConnect As Boolean)\r\n Debug.Print "New client connection: " & Client.RemoteHostIP\r\n ' DisConnect = False means accept connection\r\nEnd Sub\r\n\r\nPrivate Sub m_oServer_DataArrival(Client As cWinsock, ByVal bytesTotal As Long)\r\n Dim sData As String\r\n Client.GetData sData\r\n Debug.Print "Data from client " & Client.ClientId & ": " & sData\r\n \r\n ' Echo\r\n Client.SendData "Echo: " & sData\r\nEnd Sub\r\n\r\nPrivate Sub m_oServer_CloseEvent(Client As cWinsock)\r\n Debug.Print "Client disconnected: " & Client.ClientId\r\nEnd Sub\r\n\r\nPrivate Sub Form_Unload(Cancel As Integer)\r\n m_oServer.Close_\r\nEnd Sub\r\n`\r\n\r\n### UDP Communication Example\r\n\r\n`vb\r\nPrivate WithEvents m_oUdp As cWinsock\r\n\r\nPrivate Sub Form_Load()\r\n Set m_oUdp = New cWinsock\r\n m_oUdp.Protocol = sckUDPProtocol\r\n m_oUdp.Bind 8888\r\nEnd Sub\r\n\r\nPrivate Sub cmdSend_Click()\r\n m_oUdp.RemoteHost = "127.0.0.1"\r\n m_oUdp.RemotePort = 9999\r\n m_oUdp.SendData "Hello, UDP!"\r\nEnd Sub\r\n\r\nPrivate Sub m_oUdp_DataArrival(Client As cWinsock, ByVal bytesTotal As Long)\r\n Dim sData As String\r\n Client.GetData sData\r\n Debug.Print "Received UDP data (" & Client.RemoteHostIP & ":" & Client.RemotePort & "): " & sData\r\nEnd Sub\r\n`\r\n\r\n---\r\n\r\n## Architecture Design\r\n\r\n### Class Hierarchy\r\n\r\n`\r\ncWinsock (public class)\r\n ├── m_oSocket: cTlsSocket (internal encapsulation, supports TLS)\r\n ├── m_cClients: Collection (client collection)\r\n ├── m_oParentServer: cWinsock (parent server reference, clients only)\r\n ├── m_oPacketProtocol: cPacketProtocol (packet protocol handler)\r\n ├── m_oHeartbeat: cHeartbeat (heartbeat manager, embedded cTimer)\r\n └── Events: Connect, CloseEvent, ConnectionRequest, DataArrival, MessageArrival,\r\n SendProgress, SendComplete, Error, ClientTimeout, HeartbeatSent, ServerCertificateVerify\r\n`\r\n\r\n### Sub-module Classes\r\n\r\n| Class | File | Responsibility |\r\n|-------|------|---------------|\r\n| `cPacketProtocol` | `cPacketProtocol.cls` | Data packet protocol: delimiter/fixed-length/length-header, solves TCP fragmentation/sticky packet |\r\n| `cHeartbeat` | `cHeartbeat.cls` | Heartbeat management: embedded cTimer auto-drive, timeout detection, heartbeat keep-alive |\r\n\r\n### Object Relationship Diagram\r\n\r\n`\r\nServer object\r\n├── Socket (listening socket)\r\n├── Clients collection\r\n│ ├── Client object 1 (cWinsock)\r\n│ │ ├── Socket (independent connection)\r\n│ │ └── ParentServer → Server object\r\n│ ├── Client object 2 (cWinsock)\r\n│ │ ├── Socket (independent connection)\r\n│ │ └── ParentServer → Server object\r\n│ └── ...\r\n└── Event handler\r\n └── All client data triggered through this\r\n`\r\n\r\n### State Machine\r\n\r\n`\r\nsckClosed (0)\r\n ├─ Connect() → sckResolvingHost → sckHostResolved → sckConnecting → sckConnected (7)\r\n ├─ Listen() → sckListening (2)\r\n └─ Bind() → sckOpen (1)\r\n\r\nsckListening (2)\r\n └─ OnAccept → Create client → sckConnected\r\n\r\nsckConnected (7)\r\n └─ OnClose → sckClosed\r\n\r\nError → sckError (9)\r\n`\r\n\r\n---\r\n\r\n## Documentation Index\r\n\r\n| Document | Description |\r\n|----------|-------------|\r\n| [Packet Protocol and Heartbeat](./packet-protocol.md) | Detailed description and complete examples for packet protocol and heartbeat mechanism |\r\n| [Events Reference](./events.md) | Detailed explanation and usage examples for all events |\r\n| [Properties Reference](./properties.md) | Description, type, and purpose of all properties |\r\n| [Methods Reference](./methods.md) | Parameters, return values, and usage examples for all methods |\r\n| [Encoding Guide](./encoding.md) | Usage instructions and best practices for text encoding |\r\n| [TCP Programming](./tcp.md) | TCP client and server programming guide |\r\n| [UDP Programming](./udp.md) | UDP communication programming guide |\r\n| [Best Practices](./best-practices.md) | Solutions for common scenarios and performance optimization recommendations |\r\n| [TLS/SSL Support](./tls.md) | Configuration and usage instructions for TLS encrypted communication |\r\n| [Certificate Mode Details](../tls/overview.md) | Detailed introduction of three certificate sources (file/Windows store/memory) |\r\n| [Development Plan](./roadmap.md) | Project development progress tracking and future feature planning |\r\n\r\n---\r\n\r\n## License\r\n\r\nBased on VbAsyncSocket (wqweto@gmail.com)\r\n\r\n---\r\n\r\n## Author\r\n\r\n**cWinsock**: woeoio@qq.com \r\n**VbAsyncSocket**: wqweto@gmail.com\r\n\r\n---\r\n\r\n**Last Updated**: 2026-06-09\r\n --- --- url: /en/vbman/demo/14.Winsock.md --- # cWinsock Development Guide ## Table of Contents * [Overview](#overview) * [Quick Start](#quick-start) * [TCP Client](#tcp-client) * [TCP Server](#tcp-server) * [UDP Communication](#udp-communication) * [API Reference](#api-reference) * [Event Reference](#event-reference) * [Advanced Features](#advanced-features) * [FAQ](#faq) *** ## Overview cWinsock is a high-level wrapper class based on Windows Socket API, providing an easy-to-use VB6 network programming interface. It supports both TCP and UDP protocols, allowing you to easily create client and server applications. ### Key Features * **Multi-protocol Support**: Supports TCP and UDP protocols * **Asynchronous Non-blocking**: Uses asynchronous I/O model without blocking UI thread * **Multi-client Management**: Server automatically manages multiple client connections * **Event-driven**: Handles network events through event mechanism * **Error Handling**: Comprehensive error handling mechanism ### Project Structure ``` Winsock/ 念岸岸 Form1.frm # Main form (Server + UDP example) 念岸岸 Client.frm # Client form 念岸岸 Module1.bas # Module file 念岸岸 Project1.vbp # Project file 弩岸岸 README.md # Example description ``` *** ## Quick Start ### Requirements * Visual Basic 6.0 or higher * VBMAN.dll library (located in `..\..\vbman\dist\DLL\`) ### Reference Library 1. Open project `Project1.vbp` 2. Ensure `VBMANLIB` library is referenced 3. Check reference path: `..\..\vbman\dist\DLL\VBMAN.dll` ### Basic Code Structure ```vb ' Declare cWinsock object (with events) Private WithEvents m_oSocket As cWinsock ' Initialize object Set m_oSocket = New cWinsock ' Set protocol type m_oSocket.Protocol = sckTCPProtocol ' or sckUDPProtocol ``` *** ## TCP Client A TCP client is used to connect to a remote server and establish a reliable connection for bidirectional communication. ![client](/images/vbman/socket/1.png) ### Creating a TCP Client ```vb Private WithEvents m_oClient As cWinsock Private Sub InitializeClient() If m_oClient Is Nothing Then Set m_oClient = New cWinsock m_oClient.Protocol = sckTCPProtocol End If End Sub ``` ### Connecting to Server ```vb Private Sub ConnectToServer(ByVal sHost As String, ByVal lPort As Long) On Error GoTo EH InitializeClient() m_oClient.Connect sHost, lPort LogMessage "Connecting to " & sHost & ":" & lPort & "..." Exit Sub EH: LogMessage "Connection error: " & Err.Description End Sub ``` **Parameters:** * `sHost`: Server IP address or hostname (e.g., "127.0.0.1" or "example.com") * `lPort`: Server port number (e.g., 8080) ### Sending Data ```vb Private Sub SendData(sData As String) On Error GoTo EH If Not m_oClient Is Nothing And m_oClient.State = sckConnected Then m_oClient.SendData sData LogMessage "Data sent: " & sData Else LogMessage "Not connected to server" End If Exit Sub EH: LogMessage "Send error: " & Err.Description End Sub ``` ### Disconnecting ```vb Private Sub Disconnect() If Not m_oClient Is Nothing Then m_oClient.Close_ LogMessage "Client disconnected" End If End Sub ``` ### Complete Example Refer to `Client.frm` file for a complete TCP client implementation: ```vb Private Sub cmdClientConnect_Click() On Error GoTo EH If m_oClient Is Nothing Then Set m_oClient = New cWinsock m_oClient.Protocol = sckTCPProtocol End If m_oClient.Connect txtClientHost.Text, CLng(txtClientPort.Text) LogMessage "Connecting to " & txtClientHost.Text & ":" & txtClientPort.Text & "..." Exit Sub EH: LogMessage "Connection error: " & Err.Description End Sub Private Sub cmdClientDisconnect_Click() If Not m_oClient Is Nothing Then m_oClient.Close_ LogMessage "Client disconnected" End If cmdClientConnect.Enabled = True cmdClientDisconnect.Enabled = False cmdClientSend.Enabled = False End Sub Private Sub cmdClientSend_Click() On Error GoTo EH If Not m_oClient Is Nothing And m_oClient.State = sckConnected Then m_oClient.SendData txtClientData.Text LogMessage "Data sent: " & txtClientData.Text End If Exit Sub EH: LogMessage "Send error: " & Err.Description End Sub ``` *** ## TCP Server A TCP server listens on a specified port, accepts multiple client connections, and can communicate independently with each client. ![server](/images/vbman/socket/2.png) ### Creating a TCP Server ```vb Private WithEvents m_oServer As cWinsock Private Sub InitializeServer() If m_oServer Is Nothing Then Set m_oServer = New cWinsock End If m_oServer.Protocol = sckTCPProtocol End Sub ``` ### Starting to Listen ```vb Private Sub StartListening(ByVal lPort As Long) On Error GoTo EH InitializeServer() m_oServer.Listen lPort LogMessage "Server listening on port " & lPort Exit Sub EH: LogMessage "Listen error: " & Err.Description End Sub ``` ### Stopping Listening ```vb Private Sub StopListening() If Not m_oServer Is Nothing Then m_oServer.Close_ LogMessage "Server stopped listening" End If End Sub ``` ### Handling Client Connection ```vb Private Sub m_oServer_ConnectionRequest(Client As VBMANLIB.cWinsock, DisConnect As Boolean) ' In stress test mode, don't log connection If Not m_bStressTestMode Then LogMessage "New client connection: " & Client.RemoteHostIP & ":" & Client.RemotePort & " (Tag: " & Client.Tag & ")" End If ' Write Tag content to listbox lstClients.AddItem Client.Tag & " " & Client.RemoteHostIP & ":" & Client.RemotePort End Sub ``` ### Stress Test Mode Stress test mode is used for performance testing. In high concurrency scenarios, it only collects statistics without displaying detailed logs: ```vb ' Stress test mode variables Private m_bStressTestMode As Boolean Private m_lMsgCount As Long ' Current period message count Private m_lBytesCount As Long ' Current period byte count Private m_lTotalMsgCount As Long ' Total message count Private m_lTotalBytesCount As Long ' Total byte count Private m_lCurrentClientCount As Long ' Current client count Private m_dLastStatsTime As Double ' Last statistics time Private WithEvents tmrStats As VB.Timer ' Toggle stress test mode Private Sub chkStressTest_Click() m_bStressTestMode = (chkStressTest.Value = vbChecked) If m_bStressTestMode Then LogMessage "Stress test mode enabled - Statistics only, no message content displayed" ResetStats Else LogMessage "Stress test mode disabled - Display all message content" End If End Sub ' Receive data (stress test mode) Private Sub m_oServer_DataArrival(Client As cWinsock, ByVal bytesTotal As Long) Dim sData As String Dim sResponse As String On Error GoTo EH If m_bStressTestMode Then ' Stress test mode: only statistics, no content display Client.GetData sData, vbString, bytesTotal ' Accumulate statistics m_lMsgCount = m_lMsgCount + 1 m_lBytesCount = m_lBytesCount + bytesTotal m_lTotalMsgCount = m_lTotalMsgCount + 1 m_lTotalBytesCount = m_lTotalBytesCount + bytesTotal ' Echo data sResponse = "OK" Client.SendData sResponse Else ' Normal mode: display content Client.GetData sData LogMessage "Received data from client " & Client.Tag & " (" & bytesTotal & " bytes): " & sData sResponse = "Echo: " & sData Client.SendData sResponse LogMessage "Sent echo to client " & Client.Tag & ": " & sResponse End If Exit Sub EH: LogMessage "Server receive data error: " & Err.Description End Sub ' Statistics timer (update every second) Private Sub tmrStats_Timer() Dim dCurrentTime As Double Dim dElapsedTime As Double Dim lMsgPerSec As Long Dim lBytesPerSec As Long Dim sStats As String If m_bStressTestMode Then dCurrentTime = Timer dElapsedTime = dCurrentTime - m_dLastStatsTime If dElapsedTime > 0 Then lMsgPerSec = CLng(m_lMsgCount / dElapsedTime) lBytesPerSec = CLng(m_lBytesCount / dElapsedTime) ' Build statistics info (one item per line) sStats = vbCrLf & _ "========================================" & vbCrLf & _ Format$(Now, "hh:mm:ss") & " - [Statistics]" & vbCrLf & _ "----------------------------------------" & vbCrLf & _ "Current period messages: " & m_lMsgCount & vbCrLf & _ "Current period bytes: " & m_lBytesCount & vbCrLf & _ "Message rate: " & lMsgPerSec & " msg/s" & vbCrLf & _ "Data rate: " & Format$(lBytesPerSec / 1024, "0.00") & " KB/s" & vbCrLf & _ "----------------------------------------" & vbCrLf & _ "Current client count: " & m_lCurrentClientCount & vbCrLf & _ "Total messages: " & m_lTotalMsgCount & vbCrLf & _ "Total bytes: " & Format$(m_lTotalBytesCount / 1024 / 1024, "0.00") & " MB" & vbCrLf & _ "========================================" & vbCrLf ' Replace textbox content directly txtLog.Text = sStats txtLog.SelStart = Len(txtLog.Text) ' Reset current period statistics m_lMsgCount = 0 m_lBytesCount = 0 m_dLastStatsTime = dCurrentTime End If End If End Sub ``` ### Receiving and Sending Data ```vb Private Sub m_oServer_DataArrival(Client As cWinsock, ByVal bytesTotal As Long) Dim sData As String Dim sResponse As String On Error GoTo EH ' Get data Client.GetData sData LogMessage "Received data from client " & Client.Tag & " (" & bytesTotal & " bytes): " & sData ' Process data and send back sResponse = "Echo: " & sData Client.SendData sResponse LogMessage "Sent echo to client " & Client.Tag & ": " & sResponse Exit Sub EH: LogMessage "Server receive data error: " & Err.Description End Sub ``` ### Handling Client Disconnect ```vb Private Sub m_oServer_CloseEvent(Client As cWinsock) Dim i As Long ' In stress test mode, don't log disconnection If Not m_bStressTestMode Then LogMessage "Client " & Client.RemoteHostIP & ":" & Client.RemotePort & " disconnected" End If ' Use Tag to traverse listbox and remove matching item For i = 0 To lstClients.ListCount - 1 If InStr(lstClients.List(i), Client.Tag) > 0 Then lstClients.RemoveItem i Exit For End If Next End Sub ``` ### Complete Example Refer to the server implementation in `Form1.frm`: ```vb Private Sub cmdServerListen_Click() On Error GoTo EH If m_oServer Is Nothing Then Set m_oServer = New cWinsock End If m_oServer.Protocol = sckTCPProtocol m_oServer.Listen CLng(txtServerPort.Text) LogMessage "Server listening on port " & txtServerPort.Text cmdServerListen.Enabled = False cmdServerStop.Enabled = True Exit Sub EH: LogMessage "Listen error: " & Err.Description End Sub Private Sub m_oServer_ConnectionRequest(Client As VBMANLIB.cWinsock, DisConnect As Boolean) LogMessage "New client connection: " & Client.RemoteHostIP & ":" & Client.RemotePort & " (Tag: " & Client.Tag & ")" lstClients.AddItem Client.Tag & " - " & Client.RemoteHostIP & ":" & Client.RemotePort End Sub ``` *** ## UDP Communication UDP (User Datagram Protocol) is a connectionless protocol, suitable for sending small amounts of data or scenarios where reliability is not critical. ### Creating a UDP Socket ```vb Private WithEvents m_oUdp As cWinsock Private Sub InitializeUdp() If m_oUdp Is Nothing Then Set m_oUdp = New cWinsock m_oUdp.Protocol = sckUDPProtocol End If End Sub ``` ### Binding Local Port ```vb Private Sub BindUdpPort(ByVal lPort As Long) On Error GoTo EH InitializeUdp() m_oUdp.Bind lPort LogMessage "UDP Socket bound to port " & lPort Exit Sub EH: LogMessage "UDP bind error: " & Err.Description End Sub ``` ### Sending UDP Data ```vb Private Sub SendUdpData(sHost As String, lPort As Long, sData As String) On Error GoTo EH With m_oUdp .RemoteHost = sHost .RemotePort = lPort .SendData sData LogMessage "UDP sent data to " & sHost & ":" & lPort & ": " & sData End With Exit Sub EH: LogMessage "UDP send error: " & Err.Description End Sub ``` ### Receiving UDP Data ```vb Private Sub m_oUdp_DataArrival(Client As cWinsock, ByVal bytesTotal As Long) Dim sData As String On Error GoTo EH Client.GetData sData LogMessage "UDP received data (" & bytesTotal & " bytes) from " & Client.RemoteHostIP & ":" & Client.RemotePort & ": " & sData Exit Sub EH: LogMessage "UDP receive data error: " & Err.Description End Sub ``` ### Complete Example Refer to the UDP implementation in `Form1.frm`: ```vb Private Sub cmdUdpBind_Click() If m_oUdp Is Nothing Then Set m_oUdp = New cWinsock m_oUdp.Protocol = sckUDPProtocol End If m_oUdp.Bind CLng(txtUdpPort.Text) LogMessage "UDP Socket bound to port " & txtUdpPort.Text End Sub Private Sub cmdUdpSend_Click() On Error GoTo EH With m_oUdp .RemoteHost = txtUdpHost.Text .RemotePort = CLng(txtUdpPort.Text) .SendData txtUdpData.Text LogMessage "UDP sent data to " & txtUdpHost.Text & ":" & txtUdpPort.Text & ": " & txtUdpData.Text End With Exit Sub EH: LogMessage "UDP send error: " & Err.Description End Sub ``` *** ## API Reference ### Properties | Property | Type | Description | |----------|------|-------------| | `Protocol` | Integer | Protocol type: `sckTCPProtocol` (0) or `sckUDPProtocol` (1) | | `State` | Integer | Connection state, see state constants below | | `RemoteHost` | String | Remote host address | | `RemoteHostIP` | String | Remote host IP address (read-only) | | `RemotePort` | Long | Remote port number | | `LocalPort` | Long | Local port number (read-only) | | `Tag` | Variant | Tag for storing custom data | ### Methods #### Connect ```vb oSocket.Connect RemoteHost, RemotePort ``` Connects to the specified server. **Parameters:** * `RemoteHost`: Server address (IP or hostname) * `RemotePort`: Server port #### Listen ```vb oSocket.Listen Port ``` Starts listening on the specified port (TCP server mode only). **Parameters:** * `Port`: Listening port number #### Bind ```vb oSocket.Bind Port ``` Binds to a local port (UDP mode only). **Parameters:** * `Port`: Port number to bind #### SendData ```vb oSocket.SendData Data ``` Sends data to the remote endpoint. **Parameters:** * `Data`: Data to send (string or byte array) #### GetData ```vb oSocket.GetData Data, [Type], [MaxLen] ``` Retrieves received data from buffer. **Parameters:** * `Data`: Variable to store received data * `Type`: Optional, data type (default is string) * `MaxLen`: Optional, maximum read length #### Close\_ ```vb oSocket.Close_ ``` Closes connection or stops listening. ### State Constants | Constant | Value | Description | |----------|-------|-------------| | `sckClosed` | 0 | Connection closed | | `sckOpen` | 1 | Socket opened | | `sckListening` | 2 | Listening | | `sckConnectionPending` | 3 | Connection pending | | `sckResolvingHost` | 4 | Resolving host | | `sckHostResolved` | 5 | Host resolved | | `sckConnecting` | 6 | Connecting | | `sckConnected` | 7 | Connected | | `sckClosing` | 8 | Closing | | `sckError` | 9 | Error occurred | *** ## Event Reference ### Connect ```vb Private Sub oSocket_Connect(Client As cWinsock) ``` Triggered when client successfully connects to server. **Parameters:** * `Client`: The cWinsock object that triggered the event ### CloseEvent ```vb Private Sub oSocket_CloseEvent(Client As cWinsock) ``` Triggered when connection is closed. **Parameters:** * `Client`: The cWinsock object that triggered the event ### ConnectionRequest ```vb Private Sub oSocket_ConnectionRequest(Client As cWinsock, DisConnect As Boolean) ``` Triggered when server receives a new client connection request (TCP server only). **Parameters:** * `Client`: The new client connection object * `DisConnect`: Set to True to reject connection, False to accept connection ### DataArrival ```vb Private Sub oSocket_DataArrival(Client As cWinsock, ByVal bytesTotal As Long) ``` Triggered when data is received. **Parameters:** * `Client`: The client object receiving data * `bytesTotal`: Number of bytes received ### Error ```vb Private Sub oSocket_Error(Client As cWinsock, ByVal Number As Long, Description As String, ByVal Scode As Long) ``` Triggered when an error occurs. **Parameters:** * `Client`: The client object where error occurred * `Number`: Error code * `Description`: Error description * `Scode`: System Scode error code *** ## Advanced Features ### Multi-client Management The server automatically creates independent client objects for each connection. You can identify different clients using the `Tag` property: ```vb Private Sub m_oServer_ConnectionRequest(Client As cWinsock, DisConnect As Boolean) ' Assign unique identifier Client.Tag = "Client_" & GetNextId() ' Store in collection for management colClients.Add Client, Client.Tag LogMessage "New client: " & Client.Tag End Sub ``` ### Client Authentication Implement simple authentication in the `ConnectionRequest` event: ```vb Private Sub m_oServer_ConnectionRequest(Client As cWinsock, DisConnect As Boolean) ' Check IP whitelist If Not IsAllowedIP(Client.RemoteHostIP) Then DisConnect = True LogMessage "Connection rejected: " & Client.RemoteHostIP Exit Sub End If LogMessage "Connection accepted: " & Client.RemoteHostIP End Sub ``` ### Data Fragmentation Handle packet transmission for large amounts of data: ```vb Private Sub m_oServer_DataArrival(Client As cWinsock, ByVal bytesTotal As Long) Static sBuffer As String Dim sData As String Dim lPos As Long Client.GetData sData sBuffer = sBuffer & sData ' Look for message end marker (e.g., newline) Do lPos = InStr(sBuffer, vbCrLf) If lPos > 0 Then ProcessMessage Client, Left(sBuffer, lPos - 1) sBuffer = Mid(sBuffer, lPos + 2) Else Exit Do End If Loop End Sub ``` ### Auto-reconnect on Error Implement automatic reconnection: ```vb Private Sub m_oClient_CloseEvent(Client As cWinsock) LogMessage "Connection closed, attempting to reconnect..." ' Delayed reconnection Dim i As Integer For i = 1 To 3 If TryReconnect() Then Exit Sub End If Sleep 2000 Next i LogMessage "Reconnection failed" End Sub ``` *** ## FAQ ### Q1: How to handle connection timeout? A: Use a timer to monitor connection state: ```vb Private WithEvents tmrConnect As Timer Private Sub StartConnectTimer() Set tmrConnect = New Timer tmrConnect.Interval = 10000 ' 10 second timeout tmrConnect.Enabled = True End Sub Private Sub tmrConnect_Timer() If m_oClient.State <> sckConnected Then m_oClient.Close_ LogMessage "Connection timeout" tmrConnect.Enabled = False End If End Sub ``` ### Q2: How to send binary data? A: Use byte array: ```vb Dim byData() As Byte byData = StrConv("Hello", vbFromUnicode) m_oClient.SendData byData ``` ### Q3: How to distinguish different senders in UDP mode? A: Use `RemoteHostIP` and `RemotePort` properties: ```vb Private Sub m_oUdp_DataArrival(Client As cWinsock, ByVal bytesTotal As Long) Dim sSender As String sSender = Client.RemoteHostIP & ":" & Client.RemotePort LogMessage "Received data from " & sSender End Sub ``` ### Q4: How to limit client connections? A: Use counter management: ```vb Private lClientCount As Long Private Sub m_oServer_ConnectionRequest(Client As cWinsock, DisConnect As Boolean) If lClientCount >= 100 Then DisConnect = True LogMessage "Connection rejected: maximum client count reached" Exit Sub End If lClientCount = lClientCount + 1 LogMessage "Client count: " & lClientCount End Sub Private Sub m_oServer_CloseEvent(Client As cWinsock) lClientCount = lClientCount - 1 End Sub ``` ### Q5: How to debug network communication issues? A: Use logging to record all key events: ```vb Private Sub LogMessage(sMessage As String) txtLog.Text = txtLog.Text & Format$(Now, "hh:mm:ss") & " - " & sMessage & vbCrLf txtLog.SelStart = Len(txtLog.Text) Debug.Print sMessage ' Output to immediate window End Sub ``` *** ## Best Practices 1. **Always check connection state**: Check `State = sckConnected` before sending data 2. **Error handling**: Include error handling for all network operations 3. **Resource cleanup**: Call `Close_` when form unloads to release resources 4. **Logging**: Record key events for easier debugging 5. **Timeout handling**: Set reasonable connection and operation timeouts 6. **Data validation**: Validate format and length when receiving data *** ## Related Resources * Project directory: `Winsock/` * Example code: `Client.frm`, `Form1.frm` * Dependency library: `VBMAN.dll` *** ## Changelog * v1.0 - Initial version, includes TCP client, TCP server, and UDP examples --- --- url: /en/vbman/winsock/roadmap.md --- # cWinsock Development Plan > 📋 Project Development Progress Tracking Document ## 📖 Table of Contents * [Completed Features](#completed-features) * [Features Under Development](#features-under-development) * [Development Priorities](#development-priorities) * [Technical Roadmap](#technical-roadmap) *** ## ✅ Completed Features ### Core Features #### 1. Basic Network Communication * \[x] TCP client/server communication * \[x] UDP client/server communication * \[x] Async socket encapsulation (based on VbAsyncSocket) * \[x] Connection state management * \[x] Exception handling mechanism #### 2. Event-Driven Model * \[x] Connect event (connection successful) * \[x] CloseEvent event (connection closed) * \[x] ConnectionRequest event (new connection request) * \[x] DataArrival event (data arrived) * \[x] SendProgress event (send progress) * \[x] SendComplete event (send completed) * \[x] Error event (error handling) #### 3. Object Model Design * \[x] Pure class implementation, no controls required * \[x] Direct object reference passing (no index lookup needed) * \[x] Automatic client collection management (Clients collection) * \[x] Server-client parent-child relationship maintenance * \[x] Event proxy mechanism (server unified handling of client events) #### 4. TCP Client Event Proxy * \[x] Automatic triggering of client events through parent server * \[x] Unified data arrival handling * \[x] Unified connection disconnection handling * \[x] Unified error handling #### 5. UDP Virtual Client Management * \[x] Create virtual client objects for each remote address:port * \[x] Simulate TCP connection behavior * \[x] Support ConnectionRequest event * \[x] Automatically maintain virtual client collection #### 6. Connection Request Interception * \[x] DisConnect parameter in ConnectionRequest event * \[x] Blacklist mechanism * \[x] Whitelist mechanism * \[x] Port range restriction * \[x] Automatic disconnect and resource cleanup #### 7. Text Encoding Support * \[x] ScpAcp (system default code page, GBK) * \[x] ScpUtf8 (UTF-8 encoding) * \[x] ScpUnicode (Unicode wide characters) * \[x] Flexible string/byte array conversion #### 8. Data Buffer Management * \[x] TCP receive buffer (m\_baRecvBuffer) * \[x] UDP virtual client buffer (UserData) * \[x] Partial read support * \[x] Automatic buffer of remaining data #### 9. Remote Address Resolution * \[x] Automatic domain name resolution * \[x] Smart selection of IP and domain name * \[x] RemoteHost/RemoteHostIP/RemotePort properties #### 10. Application Scenarios * \[x] TCP server mode * \[x] TCP client mode * \[x] UDP server mode * \[x] UDP client mode * \[x] Bidirectional communication * \[x] Broadcast/multicast basic support *** ## 🚧 Features Under Development ### 1. Data Packet Protocol (High Priority) **Feature Description:** Solve TCP packet fragmentation and sticky packet issues, providing built-in and custom packet protocol support. **Implementation Details:** #### 1.1 Built-in Protocols ##### Character Delimiter Protocol * **Default delimiter**: `\0` (VbNullChar) * **Custom delimiter**: User can specify any character or string as delimiter * **Common delimiters**: * `\r\n` - Carriage return + line feed (HTTP, SMTP and other text protocols) * `\n` - Line feed * `\0` - Null character (C string style) * `|` - Vertical bar (custom protocol) * Any other character/string * **Applicable scenarios**: Text protocols, custom message formats ##### Fixed Length Protocol * Fixed-length message blocks * Applicable to protocols with known lengths * Split data by fixed length ##### Length Header Protocol * Message header contains data length information * Support different length header formats (2-byte/4-byte integer) * Automatically parse complete messages #### 1.2 Custom Protocol * User provides callback function * Support complex business logic * Flexible packet/unpacket rules #### 1.3 Protocol Class Design **Unified Interface Design:** All protocol classes provide two interface functions: `Encode` (packet) and `Decode` (unpacket), and the protocol class internally caches fragmented data. ```vb ' Protocol type enumeration Public Enum PacketProtocol ppNone = 0 ' No processing (default) ppDelimiter = 1 ' Character delimiter protocol ppFixedLength = 2 ' Fixed length protocol ppLengthHeader = 3 ' Length header protocol ppCustom = 4 ' Custom protocol End Enum ' Protocol class unified interface ' Encode: called before sending data, used to add protocol markers (packet) Public Function Encode(ByRef baData() As Byte) As Byte() ' Parameter: original data ' Return value: complete data with protocol markers added End Function ' Decode: called after receiving data, used to parse complete messages (unpacket) Public Function Decode(ByRef baData() As Byte) As Variant ' Parameter: currently received data ' Return value: ' - If data is incomplete, return Empty (protocol class internally caches data) ' - If data is complete, return complete message data (byte array) ' - If multiple complete messages, return byte array collection End Function ``` **Internal Responsibilities of Protocol Class:** * **Encode (packet)**: Add protocol markers at the end or beginning of data * Character delimiter protocol: append delimiter at the end of data * Fixed length protocol: pad or truncate to fixed length * Length header protocol: add length header at the beginning of data * **Decode (unpacket)**: * Cache fragmented data (class internally maintains receive buffer) * Determine if data is complete * When data is complete, return complete message and clear internal buffer * Automatically handle packet fragmentation and sticky packets **Independent Protocol Instance per Client:** * In multi-client scenarios, each `cWinsock` client object holds an independent protocol class instance * Internal buffers of protocol classes are isolated from each other without interference * Support different clients using different protocol types and parameters #### 1.4 API Design ```vb ' Protocol configuration in cWinsock class ' ============================================= ' Set packet protocol type Public Property Let PacketProtocol(ByVal eProtocol As PacketProtocol) Public Property Get PacketProtocol() As PacketProtocol ' Character delimiter protocol parameters Public Property Let Delimiter(ByVal sDelimiter As String) Public Property Get Delimiter() As String ' Fixed length protocol parameters Public Property Let FixedLength(ByVal lLength As Long) Public Property Get FixedLength() As Long ' Length header protocol parameters Public Property Let HeaderBytes(ByVal nBytes As Integer) ' 2 or 4 Public Property Get HeaderBytes() As Integer Public Property Let HeaderEndian(ByVal eEndian As EndianEnum) Public Property Get HeaderEndian() As EndianEnum ' Custom protocol handler object Public Property Let CustomPacketHandler(ByVal oHandler As Object) Public Property Get CustomPacketHandler() As Object ' SendData automatic packet (automatically call protocol Encode method when sending) Public Sub SendData(Data As Variant, Optional ByVal CodePage As ScpEnum = ScpAcp) ' GetData automatic unpacket (processed through protocol class Decode method when receiving) Public Sub GetData(Data As Variant, Optional ByVal Type_ As VbVarType, Optional ByVal MaxLen As Long, Optional ByVal CodePage As ScpEnum = ScpAcp) ``` #### 1.5 Architecture Design **cWinsock Class Internal Structure:** ```vb ' ============================================= ' cWinsock class definition ' ============================================= Public Class cWinsock ' Protocol configuration properties Private m_ePacketProtocol As PacketProtocol Private m_oPacketHandler As Object Private m_sDelimiter As String Private m_lFixedLength As Long Private m_nHeaderBytes As Integer ' Protocol class instance (independently held by each client object) Private m_oPacketProtocol As IPacketProtocol ' Internal send buffer Private m_baSendBuffer() As Byte ' Internal receive buffer Private m_baRecvBuffer() As Byte ' ... other members ... End Class ``` **Mechanism of Independent Protocol Instance per Client:** ```vb ' ============================================= ' Protocol instance creation and management ' ============================================= ' When setting protocol type, create independent protocol instance for current client object Public Property Let PacketProtocol(ByVal eProtocol As PacketProtocol) m_ePacketProtocol = eProtocol ' Create independent protocol instance for current cWinsock object Set m_oPacketProtocol = CreateProtocolInstance(eProtocol) End Property ' Private method to create protocol instance for current client Private Function CreateProtocolInstance(ByVal eProtocol As PacketProtocol) As IPacketProtocol Dim oProtocol As IPacketProtocol Select Case eProtocol Case ppDelimiter ' Create character delimiter protocol instance (independent per client) Set oProtocol = New DelimiterProtocol(IIf(LenB(m_sDelimiter) = 0, vbCrLf, m_sDelimiter)) Case ppFixedLength ' Create fixed length protocol instance (independent per client) Set oProtocol = New FixedLengthProtocol(m_lFixedLength) Case ppLengthHeader ' Create length header protocol instance (independent per client) Set oProtocol = New LengthHeaderProtocol(m_nHeaderBytes) Case ppCustom ' Use custom protocol handler Set oProtocol = m_oPacketHandler Case Else Set oProtocol = Nothing End Select Set CreateProtocolInstance = oProtocol End Function ' When server accepts new connection, new client object automatically inherits server protocol configuration ' and creates its own independent protocol instance Private Sub OnAcceptClient(ByRef oNewClient As cWinsock) ' New client inherits server protocol configuration oNewClient.PacketProtocol = Me.PacketProtocol oNewClient.Delimiter = Me.Delimiter oNewClient.FixedLength = Me.FixedLength oNewClient.HeaderBytes = Me.HeaderBytes ' New client creates its own independent protocol instance (buffer isolation) ' oNewClient internally calls CreateProtocolInstance to create new instance End Sub ' When client closes, clean up its own protocol instance Private Sub OnClose() If Not m_oPacketProtocol Is Nothing Then m_oPacketProtocol.Clear ' Clear protocol internal buffer Set m_oPacketProtocol = Nothing End If End Sub ``` **Instance Relationship in Multi-Client Concurrent Scenarios:** ``` Server cWinsock object ├── Protocol configuration properties │ ├── PacketProtocol = ppDelimiter │ └── Delimiter = vbCrLf │ └── Clients collection ├── Client 1 (cWinsock) │ ├── Protocol instance 1 (DelimiterProtocol) │ │ └── Receive buffer 1 (independent) │ └── Socket connection 1 │ ├── Client 2 (cWinsock) │ ├── Protocol instance 2 (DelimiterProtocol) │ │ └── Receive buffer 2 (independent) │ └── Socket connection 2 │ └── Client 3 (cWinsock) ├── Protocol instance 3 (DelimiterProtocol) │ └── Receive buffer 3 (independent) └── Socket connection 3 ``` **Core Advantages:** * ✅ **State isolation**: Each client's protocol buffer is completely independent without interference * ✅ **Protocol flexibility**: Different clients can use different protocol types and parameters * ✅ **Thread safety**: In VB6 single-threaded environment, independent state of each object is naturally safe * ✅ **Memory management**: Automatically clean up protocol instances and buffers when client disconnects * ✅ **Configuration inheritance**: New clients automatically inherit server protocol configuration while creating independent instances #### 1.6 Implementation Details **Data Flow:** 1. **Send flow (SendData)**: * Convert data to byte array * Call `Encode` method of **current client object's** protocol instance for packet * Character delimiter protocol: append delimiter at end of data * Fixed length protocol: pad or truncate to fixed length * Length header protocol: add length header at beginning of data * Custom protocol: call custom handler's `Encode` method * Send complete data after packet 2. **Receive flow (DataArrival)**: * Get original byte data * Call `Decode` method of **current client object's** protocol instance for unpacket * Protocol instance internally merges new data into **its own** receive buffer * Determine if data is complete * Data complete: return complete message (with protocol markers removed), trigger event * Data incomplete: return Empty, protocol instance internally caches data * Continue processing when next data arrives 3. **Buffer management**: * **Each client's protocol instance independently maintains receive buffer** * Automatically clear **its own** buffer after data is complete * Support continuous reception of multiple messages * Clean up **its own** protocol state when client closes 4. **Multi-client concurrent processing**: ``` Timeline example: T1: Client 1 receives "Hel" → Call client 1's protocol instance 1.Decode("Hel") → Protocol instance 1 buffer: ["Hel"] → Return Empty (incomplete) T2: Client 2 receives "Hi\0" → Call client 2's protocol instance 2.Decode("Hi\0") → Protocol instance 2 buffer: ["Hi\0"] → Parse complete message "Hi" → Clear protocol instance 2 buffer → Trigger client 2's DataArrival event T3: Client 1 receives "lo\0" → Call client 1's protocol instance 1.Decode("lo\0") → Protocol instance 1 buffer: ["Hel"] + ["lo\0"] = ["Hello\0"] → Parse complete message "Hello" → Clear protocol instance 1 buffer → Trigger client 1's DataArrival event T4: Client 3 receives "Test\0" → Call client 3's protocol instance 3.Decode("Test\0") → Protocol instance 3 buffer: ["Test\0"] → Parse complete message "Test" → Clear protocol instance 3 buffer → Trigger client 3's DataArrival event ``` * Each client object holds independent protocol instance * Each protocol instance maintains independent internal buffer * Protocol instances do not interfere with each other, independently processing their respective data #### 1.6 Usage Examples **Example 1: Basic usage (character delimiter protocol)** ```vb ' Server configuration Private Sub Form_Load() Set m_oServer = New cWinsock m_oServer.PacketProtocol = ppDelimiter m_oServer.Delimiter = vbNullChar ' Use null character delimiter m_oServer.Listen 8080 End Sub ' Client send Client.SendData "Hello" ' Encode appends vbNullChar ' Server receive (independent protocol instance per client) Private Sub m_oServer_DataArrival(Client As cWinsock, ByVal bytesTotal As Long) Dim sData As String Client.GetData sData ' Decode automatically parses, removes vbNullChar Debug.Print Client.Tag & ": " & sData End Sub ``` **Example 2: Multi-client concurrent demonstration** ```vb ' Server configuration Private Sub Form_Load() Set m_oServer = New cWinsock m_oServer.PacketProtocol = ppDelimiter m_oServer.Delimiter = vbCrLf ' Use carriage return + line feed delimiter m_oServer.Listen 8080 End Sub ' Client 1 sends (fragmented) Client1.SendData "Hel" ' Protocol instance 1 caches: "Hel" Client1.SendData "lo" & vbCrLf ' Protocol instance 1 parses: "Hello", clears cache ' Client 2 sends (complete) Client2.SendData "World" & vbCrLf ' Protocol instance 2 parses: "World", clears cache ' Client 3 sends (extra-long fragmented) Client3.SendData "Go" ' Protocol instance 3 caches: "Go" Client3.SendData "od" ' Protocol instance 3 caches: "Good" Client3.SendData " Morn" ' Protocol instance 3 caches: "Good Morn" Client3.SendData "ing" & vbCrLf ' Protocol instance 3 parses: "Good Morning", clears cache ' Server DataArrival Private Sub m_oServer_DataArrival(Client As cWinsock, ByVal bytesTotal As Long) Dim sData As String Client.GetData sData ' Each client gets complete messages parsed by its own independent protocol instance ' Protocol instances do not interfere with each other Debug.Print Client.Tag & ": " & sData ' Output order depends on network arrival time, may be: ' Client 2: World ' Client 1: Hello ' Client 3: Good Morning End Sub ``` **Example 3: Different clients using different protocols** ```vb ' Server can dynamically configure each client's protocol when accepting connection Private Sub m_oServer_ConnectionRequest(Client As cWinsock, ByRef DisConnect As Boolean) ' Use different protocols based on client IP or port Select Case Client.RemotePort Case 9001 ' Client 1 uses character delimiter protocol Client.PacketProtocol = ppDelimiter Client.Delimiter = vbNullChar Case 9002 ' Client 2 uses fixed length protocol Client.PacketProtocol = ppFixedLength Client.FixedLength = 10 Case 9003 ' Client 3 uses length header protocol Client.PacketProtocol = ppLengthHeader Client.HeaderBytes = 4 End Select End Sub ' Server DataArrival (each client uses its own protocol) Private Sub m_oServer_DataArrival(Client As cWinsock, ByVal bytesTotal As Long) Dim sData As String Client.GetData sData ' Determine which client based on Tag, automatically use corresponding protocol to parse Debug.Print Client.Tag & " (" & GetProtocolName(Client) & "): " & sData End Sub ``` **Example 4: Sticky packet scenario demonstration** ```vb ' Client sends quickly in succession (may cause sticky packets) Client.SendData "Msg1" & vbCrLf Client.SendData "Msg2" & vbCrLf Client.SendData "Msg3" & vbCrLf ' Server may receive all at once: "Msg1" & vbCrLf & "Msg2" & vbCrLf ' Protocol instance's Decode method will automatically split: ' First call Decode("Msg1" & vbCrLf & "Msg2" & vbCrLf) ' → Parse "Msg1" ' → Cache: "Msg2" & vbCrLf ' → Return "Msg1" ' Second call Decode("Msg3" & vbCrLf) ' → Merge cache: "Msg2" & vbCrLf & "Msg3" & vbCrLf ' → Parse "Msg2" ' → Cache: "Msg3" & vbCrLf ' → Return "Msg2" ' Third call Decode(empty data) ' → Parse "Msg3" ' → Clear cache ' → Return "Msg3" ``` **Example 5: Packet fragmentation scenario demonstration** ```vb ' Client sends big data (may cause packet fragmentation) Dim sBigData As String sBigData = String(10000, "A") & vbCrLf Client.SendData sBigData ' Server receives in 3 parts: ' DataArrival1: 4000 bytes "AAAA...A" (no delimiter) ' DataArrival2: 4000 bytes "AAAA...A" (no delimiter) ' DataArrival3: 2002 bytes "AAAA...A\r\n" (contains delimiter) ' Protocol instance's Decode method will automatically concatenate: ' First call Decode(4000 bytes) ' → Cache: 4000 bytes ' → No delimiter, return Empty ' Second call Decode(4000 bytes) ' → Merge cache: 8000 bytes ' → No delimiter, return Empty ' Third call Decode(2002 bytes) ' → Merge cache: 10002 bytes ' → Find vbCrLf, parse complete message ' → Clear cache ' → Return 10000 bytes "AAAA...A" ``` #### 1.7 Key Points Summary **Core advantages of independent protocol instance per client:** | Feature | Description | |---------|-------------| | **State isolation** | Each client's protocol class instance maintains independent receive buffer without interference | | **Protocol flexibility** | Different clients can use different protocol types and parameter configurations | | **Concurrency safety** | In VB6 single-threaded environment, independent state of each object is naturally safe | | **Memory management** | Automatically clean up its own protocol instance and buffer when client disconnects | | **Configuration inheritance** | New clients automatically inherit server protocol configuration while creating independent instances | | **Automatic management** | No need to manually manage protocol instance lifecycle, cWinsock internally handles automatically | **Data flow diagram:** ``` Client 1 Socket Client 2 Socket Client 3 Socket │ │ │ ├─ Received "Hel" ├─ Received "Hi\0" ├─ Received "Tes" │ │ │ ▼ ▼ ▼ Protocol instance 1.Decode Protocol instance 2.Decode Protocol instance 3.Decode │ │ │ Buffer 1: ["Hel"] Buffer 2: ["Hi\0"] Buffer 3: ["Tes"] │ │ │ │ ▼ ▼ │ Parsed "Hi" Buffer 3: ["Tes"] │ Clear buffer 2 │ │ Trigger DataArrival │ │ │ │ ├─ Received "lo\0" │ ├─ Received "t\0" │ │ │ ▼ │ ▼ Protocol instance 1.Decode │ Protocol instance 3.Decode │ │ │ Buffer 1: ["Hello\0"] │ Buffer 3: ["Test\0"] │ │ │ ▼ │ ▼ Parsed "Hello" │ Parsed "Test" Clear buffer 1 │ Clear buffer 3 Trigger DataArrival │ Trigger DataArrival ``` **Best practice recommendations:** 1. **Server configures protocol**: Set server protocol configuration before `Listen`, all new clients automatically inherit 2. **Dynamic protocol configuration**: Dynamically set protocol in `ConnectionRequest` event based on client characteristics (IP, port, etc.) 3. **Avoid mixing protocols**: Suggest using unified protocol type for same client within its lifecycle 4. **Client close cleanup**: cWinsock internally automatically cleans up protocol instances, no manual handling needed 5. **Monitor protocol status**: Check if there is unprocessed fragmented data via protocol class instance's `HasPendingData()` method **Typical application scenarios:** * **HTTP server**: Use character delimiter protocol (`\r\n\r\n`) * **Binary protocol**: Use length header protocol (4-byte integer) * **Fixed format protocol**: Use fixed length protocol * **Custom protocol**: Implement custom protocol class, support complex business logic *** ### 2. TCP Smart Heartbeat Mechanism (High Priority) **Feature Description:** Provide automated TCP connection keep-alive and timeout disconnect mechanism. #### 2.1 Server Heartbeat Detection * **Timeout mechanism** * Default timeout: 2 minutes * Detection content: Last communication time (including data sending and receiving) * Automatically disconnect timeout clients * Trigger CloseEvent event * **LastActivityTime update rules** * **Important**: Must immediately reset `LastActivityTime` to current time after each send/receive operation to client * This ensures server polling won't misjudge as timeout after client skips heartbeat cycle * Update timing: * When receiving client data (DataArrival event) * When sending data to client (SendData/SendComplete) * When receiving client heartbeat * Any valid communication interaction * **Implementation method** * Timer polls all clients' LastActivityTime property * Automatically Close client on timeout * Log records (optional) ```vb ' Server configuration Public Property Let HeartbeatTimeout(ByVal lSeconds As Long) Public Property Get HeartbeatTimeout() As Long ' Auto enable/disable Public Property Let AutoHeartbeat(ByVal bEnable As Boolean) ' Event: client timeout disconnect Public Event ClientTimeout(Client As cWinsock) ``` * **LastActivityTime update example** ```vb ' Update in DataArrival event Private Sub Server_DataArrival(Client As cWinsock, ByVal bytesTotal As Long) ' cWinsock internally automatically executes Client.LastActivityTime = Now ' Or GetTickCount etc. timestamp End Sub ' Update in SendData method Public Sub SendData(Data As Variant, Optional ByVal CodePage As ScpEnum = ScpAcp) ' ... send data ... ' cWinsock internally automatically executes If IsClient() Then m_oParentServer.LastActivityTime = Now Else m_lLastActivityTime = Now End If End Sub ``` #### 2.2 Client Heartbeat Keep-Alive * **Auto Ping mechanism** * Default send interval: 50 seconds * Data content: 1 byte (customizable) * Smart skip: Skip current cycle if recent data send/receive exists * **Implementation method** * Timer controls send interval * Check LastActivityTime to determine if send is needed * SendData sends heartbeat packet ```vb ' Client configuration Public Property Let HeartbeatInterval(ByVal lSeconds As Long) Public Property Get HeartbeatInterval() As Long ' Heartbeat packet content Public Property Let HeartbeatData(ByVal vData As Variant) Public Property Get HeartbeatData() As Variant ' Auto enable/disable Public Property Let AutoHeartbeat(ByVal bEnable As Boolean) ' Event: heartbeat sent Public Event HeartbeatSent() ``` #### 2.3 Heartbeat Status Monitoring * Each client maintains heartbeat-related information * Properties: * `LastHeartbeatTime` - Last heartbeat time * `LastActivityTime` - Last communication time * `HeartbeatCount` - Heartbeat count * `IsAlive` - Whether alive *** ### 3. GetData Enhanced Methods (Medium Priority) **Feature Description:** Provide more convenient data retrieval methods, supporting different format outputs. #### 3.1 Design Principles **Important distinction:** * Original `GetData` uses byref parameter to output data * Enhanced methods output data via **return value** * Convenient to write in one line of code, e.g., `Dim Data As String: Data = GetDataText()` #### 3.2 New Methods ```vb ' Get text string (using default encoding ACP) Public Function GetDataText(Optional ByVal MaxLen As Long = -1) As String ' Get text string (specify encoding) Public Function GetDataTextEx(Optional ByVal CodePage As ScpEnum = ScpAcp, Optional ByVal MaxLen As Long = -1) As String ' Get UTF-8 string Public Function GetDataTextUTF8(Optional ByVal MaxLen As Long = -1) As String ' Get Unicode string Public Function GetDataTextUnicode(Optional ByVal MaxLen As Long = -1) As String ' Get hex string (space separated) Public Function GetDataHex(Optional ByVal MaxLen As Long = -1) As String ' Get byte array Public Function GetDataByteArray(Optional ByVal MaxLen As Long = -1) As Byte() ``` #### 3.3 Usage Examples **One-line code style:** ```vb ' Direct assignment, no need to declare and pass byref Debug.Print GetDataText() ' Output text Debug.Print GetDataHex() ' Output: 48 65 6C 6C 6F Debug.Print GetDataTextUTF8() ' Output UTF-8 text ' Check data If GetDataText() = "Hello" Then Debug.Print "Received Hello" End If ' Process data Dim sReply As String sReply = ProcessData(GetDataText()) ' Assign to variable Dim sData As String: sData = GetDataText() Dim baData() As Byte: baData = GetDataByteArray() ``` **Comparison with original GetData:** ```vb ' Original way (need to declare and pass byref) Dim sData As String Client.GetData sData Debug.Print sData ' New way (direct return) Debug.Print Client.GetDataText() ' Original way (byte array) Dim baData() As Byte Client.GetData baData ' New way (direct return) Dim baData() As Byte baData = Client.GetDataByteArray() ``` **With MaxLen parameter:** ```vb ' Only read first 100 bytes Debug.Print Client.GetDataText(100) ' Get hex representation of first 50 bytes Debug.Print Client.GetDataHex(50) ``` #### 3.4 Implementation Details **Internal implementation:** ```vb Public Function GetDataText(Optional ByVal MaxLen As Long = -1) As String Dim sData As String GetData sData, vbString, MaxLen, ScpAcp ' Call original GetData GetDataText = sData ' Return via return value End Function Public Function GetDataHex(Optional ByVal MaxLen As Long = -1) As String Dim baData() As Byte Dim i As Long Dim sHex As String ' Get byte array GetData baData, vbByte + vbArray, MaxLen ' Convert to hex string For i = LBound(baData) To UBound(baData) sHex = sHex & Right$("0" & Hex$(baData(i)), 2) & " " Next ' Remove trailing space If Len(sHex) > 0 Then GetDataHex = Left$(sHex, Len(sHex) - 1) End If End Function ``` **Buffer consistency:** * All enhanced methods internally call original `GetData` * Maintain same buffer behavior as original method * After partial read, remaining data is still retained in internal buffer *** ### 4. Performance Optimization (Medium Priority) #### 4.1 Batch Send ```vb ' Batch send multiple messages, reduce system calls Public Sub SendBatch(vData As Variant) ``` #### 4.2 Data Compression * Optional compression algorithm support * Automatic compression for large data * Transparent compression/decompression #### 4.3 Connection Pool * Reuse TCP connections * Reduce Connect overhead * Automatic load balancing *** ### 5. Advanced Features (Low Priority) #### 5.1 SSL/TLS Encryption * Support HTTPS/WSS * Certificate verification * Secure handshake #### 5.2 WebSocket Protocol * Complete WebSocket support * Handshake and frame processing * Auto Ping/Pong #### 5.3 Auto Reconnect * Automatic reconnection mechanism * Exponential backoff algorithm * Maximum retry count #### 5.4 Rate Limiting * Send rate limit * Receive rate limit * Traffic statistics *** ## 📊 Development Priorities ### P0 - Core Features (Must Implement) 1. **Data Packet Protocol** * Solve most common data fragmentation issues * Improve development efficiency * Reduce error rate 2. **TCP Smart Heartbeat** * Ensure connection stability * Timely cleanup zombie connections * Suitable for production environment ### P1 - Enhanced Features (Important) 1. **GetData Enhanced Methods** * Improve development experience * Reduce code amount * Reduce error probability ### P2 - Optimization Features (Optional) 1. **Performance Optimization** * Batch send * Data compression * Connection pool ### P3 - Advanced Features (Long-term Planning) 1. **SSL/TLS Encryption** 2. **WebSocket Protocol** 3. **Auto Reconnect** 4. **Rate Limiting** *** ## 🗺️ Technical Roadmap ### Phase 1: Packet Protocol Implementation (Estimated 3-5 days) * Day 1-2: Design protocol interface and data structures * Day 3-4: Implement built-in protocols (CRLF, fixed length, length header) * Day 5: Implement custom protocol interface and testing ### Phase 2: Heartbeat Mechanism Implementation (Estimated 2-3 days) * Day 1-2: Implement server timeout detection * Day 3: Implement client heartbeat keep-alive ### Phase 3: GetData Enhancement (Estimated 1 day) * Day 1: Implement 4 new methods and testing ### Phase 4: Performance Optimization (Estimated 2-3 days) * Day 1: Batch send implementation * Day 2: Data compression implementation * Day 3: Connection pool design ### Phase 5: Advanced Features (Long-term) * Gradually implement based on user needs and feedback *** ## 📝 Usage Recommendations ### During Development * Maintain backward compatibility * Don't affect existing functionality * Provide sufficient unit tests * Update documentation and examples ### Release Strategy * Phased release * Collect user feedback * Continuous optimization and improvement *** ## 🔗 Related Documents * [Overview](./overview.md) - Project overview and core features * [Property Reference](./properties.md) - Detailed property descriptions * [Method Reference](./methods.md) - Detailed method descriptions * [TCP Programming](./tcp.md) - TCP development guide *** **Last updated**: 2026-01-10 --- --- url: /en/vbman/winsock/encoding.md --- # cWinsock Encoding Guide ## 📖 Table of Contents * [Overview](#overview) * [Encoding Types](#encoding-types) * [Default Encoding](#default-encoding) * [Encoding Selection Recommendations](#encoding-selection-recommendations) * [Common Issues](#common-issues) *** ## Overview `cWinsock` supports multiple text encoding methods to adapt to different application scenarios. Proper use of encoding is crucial for ensuring data transmission accuracy and compatibility. *** ## Encoding Types ### 🇨🇳 ScpAcp (ACP/GBK) **Value**: `0` **Description**: System default code page (ANSI Code Page) **Characteristics**: * GBK encoding on Chinese Windows * Consistent with VB6 internal string storage * Single-byte characters 1 byte, Chinese characters 2 bytes * Suitable for local applications in Chinese environment **Use Cases**: * Traditional VB6 applications * Applications with mainly Chinese characters * Compatible with existing VB6 systems **Example**: ```vb ' Default uses ACP/GBK encoding m_oClient.SendData "中文测试" m_oClient.GetData sData ``` *** ### 🌐 ScpUtf8 (UTF-8) **Value**: `65001` **Description**: UTF-8 encoding **Characteristics**: * International standard, supports all Unicode characters * Compatible with ASCII * Single-byte characters 1 byte, Chinese characters 3 bytes * Preferred encoding for network transmission **Use Cases**: * Web applications * Internationalized applications * Interacting with modern systems * Need to support multiple languages **Example**: ```vb ' Use UTF-8 encoding m_oClient.SendData "中文测试", ScpUtf8 m_oClient.GetData sData, , , ScpUtf8 ``` *** ### 🌟 ScpUnicode (Unicode) **Value**: `-1` **Description**: Unicode encoding (no conversion) **Characteristics**: * Keeps strings as wide characters (UTF-16) * No encoding conversion * Each character 2 bytes (most characters) **Use Cases**: * Internal data transmission * Need to preserve original string format * Don't want encoding conversion **Example**: ```vb ' Use Unicode (no conversion) m_oClient.SendData "中文测试", ScpUnicode m_oClient.GetData sData, , , ScpUnicode ``` *** ## Default Encoding ### SendData Default Encoding ```vb Public Sub SendData(Data As Variant, Optional ByVal CodePage As EnumScpCodePage = ScpAcp) ``` **Default Value**: `ScpAcp` (0) - ACP/GBK ### GetData/PeekData Default Encoding ```vb Public Sub GetData(Data As Variant, Optional ByVal VarType_ As Long, Optional ByVal MaxLen As Long = -1, Optional ByVal CodePage As EnumScpCodePage = ScpAcp) Public Sub PeekData(Data As Variant, Optional ByVal VarType_ As Long, Optional ByVal MaxLen As Long = -1, Optional ByVal CodePage As EnumScpCodePage = ScpAcp) ``` **Default Value**: `ScpAcp` (0) - ACP/GBK ### Design Reason * Consistent with traditional VB6 encoding * Compatible with most VB6 applications * Avoid garbled text from encoding inconsistencies *** ## Encoding Selection Recommendations ### 🎯 Scenario 1: New Network Applications **Recommendation**: Use UTF-8 ```vb ' Send m_oClient.SendData "Hello 世界", ScpUtf8 ' Receive Private Sub m_oClient_DataArrival(Client As cWinsock, ByVal bytesTotal As Long) Dim sData As String Client.GetData sData, , , ScpUtf8 Debug.Print sData ' "Hello 世界" End Sub ``` **Advantages**: * Internationalization support * Compatible with modern systems * Web standard encoding *** ### 🏢 Scenario 2: Traditional VB6 Applications **Recommendation**: Use default ACP/GBK ```vb ' Send (default ACP) m_oClient.SendData "中文测试" ' Receive (default ACP) Private Sub m_oClient_DataArrival(Client As cWinsock, ByVal bytesTotal As Long) Dim sData As String Client.GetData sData Debug.Print sData ' "中文测试" End Sub ``` **Advantages**: * Consistent with VB6 internal encoding * No extra encoding settings needed * Compatible with existing code *** ### 🌍 Scenario 3: Mixed Encoding Environment **Recommendation**: Dynamically select based on peer's encoding ```vb ' Detect peer encoding before sending Private Sub SendDataAdaptive(ByVal sText As String) If m_oRemoteEncoding = "UTF8" Then m_oClient.SendData sText, ScpUtf8 Else m_oClient.SendData sText, ScpAcp End If End Sub ' Receive with encoding detection Private Sub m_oClient_DataArrival(Client As cWinsock, ByVal bytesTotal As Long) Dim sData As String If m_oRemoteEncoding = "UTF8" Then Client.GetData sData, , , ScpUtf8 Else Client.GetData sData End If ProcessData sData End Sub ``` *** ### 🔧 Scenario 4: Protocol Encoding Negotiation **Recommendation**: Negotiate encoding when connection established ```vb ' Send encoding negotiation after connection Private Sub m_oClient_Connect(Client As cWinsock) ' Send supported encoding list Client.SendData "ENCODING:SUPPORT:ACP,UTF8", ScpUtf8 End Sub ' Server response Private Sub m_oServer_DataArrival(Client As cWinsock, ByVal bytesTotal As Long) Dim sData As String Client.GetData sData, , , ScpUtf8 If Left$(sData, 21) = "ENCODING:SUPPORT:" Then ' Select encoding Dim sEncodings() As String sEncodings = Split(Mid$(sData, 22), ",") ' Prefer UTF-8 Dim sSelected As String If InStr("UTF8", sEncodings(0)) > 0 Then sSelected = "UTF8" Else sSelected = "ACP" End If ' Respond with selected encoding Client.SendData "ENCODING:SELECT:" & sSelected, ScpUtf8 ' Save client's encoding Client.UserData = sSelected End If End Sub ``` *** ## Common Issues ### ❓ Issue 1: Chinese Garbled Text **Symptom**: Received Chinese displays as garbled text **Cause**: Different encoding used for sending and receiving **Solution**: ```vb ' ✅ Correct: Use same encoding for send and receive m_oClient.SendData "中文测试", ScpUtf8 ' When receiving Client.GetData sData, , , ScpUtf8 ' ❌ Wrong: Inconsistent encoding m_oClient.SendData "中文测试", ScpUtf8 ' Use UTF-8 ' When receiving Client.GetData sData ' Use default ACP → garbled ``` *** ### ❓ Issue 2: UTF-8 Byte Length Error **Symptom**: Byte count doesn't match expectation **Cause**: UTF-8 is variable-length encoding, Chinese characters occupy 3 bytes **Solution**: ```vb ' Calculate actual byte count Function GetByteCount(ByVal sText As String, ByVal eCodePage As EnumScpCodePage) As Long Dim oSocket As New cAsyncSocket Dim baData() As Byte baData = oSocket.ToTextArray(sText, eCodePage) GetByteCount = UBound(baData) + 1 End Function ' Use Dim lLen As Long lLen = GetByteCount("中文测试", ScpUtf8) Debug.Print lLen ' 12 (each Chinese character 3 bytes) ``` *** ### ❓ Issue 3: Communicating with Web Server **Symptom**: Web server returned content displays incorrectly **Cause**: Web server usually uses UTF-8, but client used default encoding **Solution**: ```vb ' Send HTTP request (use UTF-8) m_oClient.SendData "GET / HTTP/1.1" & vbCrLf & "Host: example.com" & vbCrLf & vbCrLf, ScpUtf8 ' Receive response (use UTF-8) Private Sub m_oClient_DataArrival(Client As cWinsock, ByVal bytesTotal As Long) Dim sData As String Client.GetData sData, , , ScpUtf8 ' Parse response Debug.Print sData End Sub ``` *** ### ❓ Issue 4: Database Encoding Conflict **Symptom**: Strings read from database display abnormally after network transmission **Cause**: Database encoding inconsistent with network transmission encoding **Solution**: ```vb ' Read from database (assume database uses UTF-8) Dim sData As String sData = GetFromDatabase() ' Send directly (database already UTF-8) ' No conversion needed m_oClient.SendData sData, ScpUtf8 ' Or convert to ACP before sending Dim baUtf8() As Byte Dim sAcp As String ' First convert to UTF-8 byte array baUtf8 = ConvertToUtf8Bytes(sData) ' Then convert to ACP string sAcp = ConvertFromUtf8Bytes(baUtf8) m_oClient.SendData sAcp ``` *** ### ❓ Issue 5: File Transfer Encoding **Symptom**: Content garbled after transferring text file **Cause**: File encoding inconsistent with network transmission encoding **Solution**: ```vb ' Read text file Private Function ReadFile(ByVal sFilePath As String, ByVal eCodePage As EnumScpCodePage) As String Dim iFileNum As Integer iFileNum = FreeFile Open sFilePath For Binary As #iFileNum Dim baData() As Byte ReDim baData(0 To LOF(iFileNum) - 1) As Byte Get #iFileNum, , baData Close #iFileNum Dim oSocket As New cAsyncSocket ReadFile = oSocket.FromTextArray(baData, eCodePage) End Function ' Send file Private Sub SendFile(ByVal sFilePath As String) Dim sContent As String ' Assume file is UTF-8 encoded sContent = ReadFile(sFilePath, ScpUtf8) ' Send using UTF-8 m_oClient.SendData sContent, ScpUtf8 End Sub ``` *** ## Encoding Conversion Utility Functions ### Encoding Detection ```vb ' Simple UTF-8 detection Function IsLikelyUtf8(ByVal sText As String) As Boolean ' Check for high-byte characters Dim i As Long For i = 1 To Len(sText) If AscW(Mid$(sText, i, 1)) > 255 Then IsLikelyUtf8 = True Exit Function End If Next IsLikelyUtf8 = False End Function ``` ### Encoding Conversion ```vb ' ACP to UTF-8 conversion Function AcpToUtf8(ByVal sText As String) As String Dim oSocket As New cAsyncSocket Dim baAcp() As Byte Dim baUtf8() As Byte ' ACP → Byte array baAcp = oSocket.ToTextArray(sText, ScpAcp) ' Byte array → UTF-8 string (needs extra handling) ' VB6 needs to use Win32 API for conversion ' Simplified demonstration here AcpToUtf8 = sText ' Actual implementation needs to call MultiByteToWideChar End Function ``` *** ## Best Practices ### ✅ Recommended Practices 1. **Unified Encoding**: Use same encoding for send and receive 2. **Explicit Specification**: Always explicitly specify encoding parameter, don't rely on default 3. **Documentation**: Record encoding used for each connection 4. **Encoding Negotiation**: Negotiate encoding at protocol level 5. **Error Handling**: Handle encoding conversion errors ```vb ' Example: Network class wrapper Public Sub SendText(ByVal oSocket As cWinsock, ByVal sText As String) On Error GoTo EH ' Use configured encoding Select Case m_eEncoding Case eEncoding.UTF8 oSocket.SendData sText, ScpUtf8 Case eEncoding.ACP oSocket.SendData sText, ScpAcp Case eEncoding.Unicode oSocket.SendData sText, ScpUnicode End Select Exit Sub EH: Debug.Print "Send data failed: " & Err.Description End Sub ``` ### ❌ Avoid 1. **Mixed Encoding**: Using different encodings on same connection 2. **Rely on Default**: Not specifying encoding parameter, relying on default 3. **Ignore Detection**: Not detecting encoding used by peer 4. **Blind Conversion**: Converting without verification *** **Last Updated**: 2026-01-09 --- --- url: /en/vbman/winsock/events.md --- # cWinsock Events Reference ## 📋 Event List | Event Name | Description | Trigger Timing | |------------|-------------|----------------| | `Connect` | Client connected successfully | TCP client successfully connects to server | | `CloseEvent` | Connection closed | TCP connection closed | | `ConnectionRequest` | New connection request | Server receives new connection request | | `DataArrival` | Data arrived | New data received | | `SendProgress` | Send progress | Triggered during data sending | | `SendComplete` | Send completed | Data sending completed | | `Error` | Error occurred | Socket error occurred | *** ## 🔗 Connect Event ### Description Triggered when a TCP client successfully connects to the server. ### Syntax ```vb Private Sub object_Connect(Client As cWinsock) ``` ### Parameters | Parameter | Type | Description | |-----------|------|-------------| | `Client` | cWinsock | Client object that triggered the event (i.e., Me) | ### Usage Example ```vb Private WithEvents m_oClient As cWinsock Private Sub m_oClient_Connect(Client As cWinsock) Debug.Print "Connected to server" Debug.Print "Remote address: " & Client.RemoteHostIP Debug.Print "Remote port: " & Client.RemotePort ' Send login request after connection Client.SendData "LOGIN|user|password" End Sub ``` *** ## 🚪 CloseEvent Event ### Description Triggered when a TCP connection is closed. ### Syntax ```vb Private Sub object_CloseEvent(Client As cWinsock) ``` ### Parameters | Parameter | Type | Description | |-----------|------|-------------| | `Client` | cWinsock | Client object that triggered the event | ### Important Notes For clients accepted by the server, when `CloseEvent` is triggered, it automatically: 1. Removes that client from the server's `Clients` collection 2. Cleans up related resources ### Usage Example ```vb Private Sub m_oClient_CloseEvent(Client As cWinsock) Debug.Print "Connection closed" ' Can try to reconnect here If m_bAutoReconnect Then Debug.Print "Attempting to reconnect in 3 seconds..." tmrReconnect.Enabled = True End If End Sub ``` **Server-side example:** ```vb Private Sub m_oServer_CloseEvent(Client As cWinsock) Debug.Print "Client " & Client.Tag & " disconnected" ' Update UI Dim i As Long For i = 0 To lstClients.ListCount - 1 If lstClients.List(i) = Client.Tag Then lstClients.RemoveItem i Exit For End If Next ' Update statistics UpdateClientCount End Sub ``` *** ## 🔔 ConnectionRequest Event ### Description Triggered when the server receives a new connection request. Supports connection interception via the `DisConnect` parameter. ### Syntax ```vb Private Sub object_ConnectionRequest(Client As cWinsock, ByRef DisConnect As Boolean) ``` ### Parameters | Parameter | Type | Description | |-----------|------|-------------| | `Client` | cWinsock | New client object | | `DisConnect` | Boolean | Set to `True` to reject connection and clean up resources | ### Connection Interception Mechanism ```vb Private Sub m_oServer_ConnectionRequest(Client As cWinsock, ByRef DisConnect As Boolean) ' Accept connection by default (DisConnect = False) ' 1. IP blacklist check If IsInBlacklist(Client.RemoteHostIP) Then Debug.Print "Reject blacklist IP: " & Client.RemoteHostIP DisConnect = True Exit Sub End If ' 2. Port range restriction If Client.RemotePort < 1024 Then Debug.Print "Reject privileged port: " & Client.RemotePort DisConnect = True Exit Sub End If ' 3. Whitelist mode If m_bWhitelistMode Then If Not IsInWhitelist(Client.RemoteHostIP) Then Debug.Print "IP not in whitelist: " & Client.RemoteHostIP DisConnect = True Exit Sub End If End If ' 4. Connection count limit If m_oServer.ClientCount >= m_lMaxClients Then Debug.Print "Maximum connection limit reached" DisConnect = True Exit Sub End If ' Accept connection Debug.Print "Accept new client: " & Client.RemoteHostIP & ":" & Client.RemotePort DisConnect = False End Sub ``` ### Advanced Example: Dynamic Whitelist ```vb Private Sub m_oServer_ConnectionRequest(Client As cWinsock, ByRef DisConnect As Boolean) ' Load whitelist from database or config file Dim sWhitelist() As String sWhitelist = LoadWhitelistFromDatabase() Dim bAllowed As Boolean bAllowed = False Dim i As Long For i = LBound(sWhitelist) To UBound(sWhitelist) If sWhitelist(i) = Client.RemoteHostIP Then bAllowed = True Exit For End If Next If Not bAllowed Then Debug.Print "Reject unauthorized IP: " & Client.RemoteHostIP DisConnect = True End If End Sub ``` ### Triggering in TCP vs UDP | Protocol | Trigger Timing | |----------|----------------| | TCP | Received new connection request (`accept` system call) | | UDP | First time receiving packet from new address:port | *** ## 📨 DataArrival Event ### Description Triggered when new data is received. **This is one of the most commonly used events.** ### Syntax ```vb Private Sub object_DataArrival(Client As cWinsock, ByVal bytesTotal As Long) ``` ### Parameters | Parameter | Type | Description | |-----------|------|-------------| | `Client` | cWinsock | Client object receiving data | | `bytesTotal` | Long | Number of bytes of data available | ### Basic Usage ```vb Private Sub m_oServer_DataArrival(Client As cWinsock, ByVal bytesTotal As Long) Dim sData As String ' Read string data Client.GetData sData Debug.Print "Received " & bytesTotal & " bytes: " & sData ' Process data... ProcessData Client, sData End Sub ``` ### Reading Byte Array ```vb Private Sub m_oClient_DataArrival(Client As cWinsock, ByVal bytesTotal As Long) Dim baData() As Byte ' Read byte array Client.GetData baData Debug.Print "Received " & bytesTotal & " bytes of data" ' Process binary data... ProcessBinaryData baData End Sub ``` ### Partial Data Reading ```vb Private Sub m_oServer_DataArrival(Client As cWinsock, ByVal bytesTotal As Long) Dim sHeader As String Dim sBody As String ' Read first 10 bytes as header Client.GetData sHeader, vbString, 10 Debug.Print "Header: " & sHeader ' Read remaining data (still in buffer) Client.GetData sBody Debug.Print "Body: " & sBody End Sub ``` ### Specified Encoding Reading ```vb Private Sub m_oClient_DataArrival(Client As cWinsock, ByVal bytesTotal As Long) Dim sData As String ' Read using UTF-8 encoding Client.GetData sData, vbString, -1, ucsScpUtf8 Debug.Print "UTF-8 data: " & sData End Sub ``` ### Event Proxy Mechanism **Important:** For client objects accepted by the server, their `DataArrival` event is triggered through the parent server object. ```vb ' Only need to subscribe to server events to handle all client data Private WithEvents m_oServer As cWinsock Private Sub m_oServer_DataArrival(Client As cWinsock, ByVal bytesTotal As Long) ' Client parameter is the specific client object Debug.Print "Data from " & Client.Tag Dim sData As String Client.GetData sData ' Can reply directly to that client Client.SendData "Echo: " & sData End Sub ``` *** ## 📊 SendProgress Event ### Description Triggered periodically during data sending, used to display send progress. ### Syntax ```vb Private Sub object_SendProgress(Client As cWinsock, ByVal bytesSent As Long, ByVal bytesRemaining As Long) ``` ### Parameters | Parameter | Type | Description | |-----------|------|-------------| | `Client` | cWinsock | Client object sending data | | `bytesSent` | Long | Number of bytes sent | | `bytesRemaining` | Long | Number of bytes remaining to send | ### Usage Example ```vb Private Sub m_oClient_SendProgress(Client As cWinsock, ByVal bytesSent As Long, ByVal bytesRemaining As Long) Dim lTotal As Long lTotal = bytesSent + bytesRemaining Dim dPercent As Double dPercent = (bytesSent / lTotal) * 100 Debug.Print "Send progress: " & Format$(dPercent, "0.00") & "% (" & bytesSent & "/" & lTotal & ")" ' Update progress bar If Not prgProgress Is Nothing Then prgProgress.Value = CInt(dPercent) End If End Sub ``` ### Practical Application: File Transfer Progress ```vb Private Sub m_oClient_SendProgress(Client As cWinsock, ByVal bytesSent As Long, ByVal bytesRemaining As Long) Static lStartTime As Long Static lLastUpdate As Long If lStartTime = 0 Then lStartTime = Timer If lLastUpdate = 0 Then lLastUpdate = lStartTime ' Update UI every 0.5 seconds If Timer - lLastUpdate >= 0.5 Then Dim lTotal As Long lTotal = bytesSent + bytesRemaining Dim dElapsed As Double dElapsed = Timer - lStartTime Dim dSpeed As Double dSpeed = bytesSent / dElapsed ' bytes/second ' Update UI lblStatus.Caption = "Sending: " & FormatSize(bytesSent) & " / " & FormatSize(lTotal) lblSpeed.Caption = "Speed: " & FormatSize(dSpeed) & "/s" lLastUpdate = Timer End If End Sub ``` *** ## ✅ SendComplete Event ### Description Triggered when data sending is completed. ### Syntax ```vb Private Sub object_SendComplete(Client As cWinsock) ``` ### Parameters | Parameter | Type | Description | |-----------|------|-------------| | `Client` | cWinsock | Client object that finished sending | ### Usage Example ```vb Private Sub m_oClient_SendComplete(Client As cWinsock) Debug.Print "Data sending completed" ' Reset send status m_bSending = False ' Update UI cmdSend.Enabled = True lblStatus.Caption = "Ready" End Sub ``` ### Practical Application: Command Queue ```vb Private m_lCommandQueue() As String Private m_lQueueIndex As Long Private Sub SendNextCommand() If m_lQueueIndex <= UBound(m_lCommandQueue) Then m_oClient.SendData m_lCommandQueue(m_lQueueIndex) m_lQueueIndex = m_lQueueIndex + 1 End If End Sub Private Sub m_oClient_SendComplete(Client As cWinsock) Debug.Print "Command send completed, sending next..." SendNextCommand End Sub ``` *** ## ❌ Error Event ### Description Triggered when a Socket error occurs. ### Syntax ```vb Private Sub object_Error(Client As cWinsock, ByVal Number As Long, Description As String, ByVal Scode As Long) ``` ### Parameters | Parameter | Type | Description | |-----------|------|-------------| | `Client` | cWinsock | Client object where error occurred | | `Number` | Long | Error code | | `Description` | String | Error description | | `Scode` | Long | SCODE (usually same as Number) | ### Common Error Codes | Error Code | Description | |------------|-------------| | 10053 | Connection forcibly closed by remote host | | 10054 | Remote host closed the connection | | 10060 | Connection timeout | | 10061 | Connection refused | | 10065 | Target host unreachable | | 10048 | Address already in use | ### Usage Example ```vb Private Sub m_oClient_Error(Client As cWinsock, ByVal Number As Long, Description As String, ByVal Scode As Long) Debug.Print "Socket error [" & Number & "]: " & Description Select Case Number Case 10053, 10054 ' Connection closed Debug.Print "Remote host disconnected" Case 10060 ' Connection timeout Debug.Print "Connection timeout, please check network" Case 10061 ' Connection refused Debug.Print "Server refused connection, please check port and firewall" Case Else ' Other errors Debug.Print "Unknown error: " & Description End Select End Sub ``` ### Error Recovery ```vb Private Sub m_oServer_Error(Client As cWinsock, ByVal Number As Long, Description As String, ByVal Scode As Long) Debug.Print "Server error [" & Number & "]: " & Description ' Remove error client If Not Client Is Nothing Then m_oServer.RemoveClient Client End If ' If serious error, restart server If Number >= 10000 Then Debug.Print "Serious error, restarting server..." m_oServer.Close_ m_oServer.Listen m_lServerPort End If End Sub ``` *** ## 🎯 Event Trigger Order ### TCP Client Connection Flow ``` 1. Connect() call 2. Internal hostname resolution 3. Connect event triggered 4. Can start sending data 5. SendProgress event (multiple times) 6. SendComplete event triggered 7. DataArrival event (receive data) 8. CloseEvent event (connection closed) ``` ### TCP Server Accept Connection Flow ``` 1. Listen() call 2. Receive new connection request 3. ConnectionRequest event triggered (can intercept) 4. If accepted, create client object 5. Client DataArrival event (triggered through server) 6. Client CloseEvent event (triggered on disconnect) ``` ### UDP Communication Flow ``` 1. Bind() call (UDP server) 2. Receive packet 3. First time receiving from that address:port → ConnectionRequest event 4. DataArrival event triggered 5. Can reply via SendData ``` *** ## 📌 Notes 1. **Event Processing Time** * Avoid executing time-consuming operations in event handlers * Use `DoEvents` to release control * Or put time-consuming operations in queue for asynchronous processing 2. **Object Lifecycle** * Don't `Set Client = Nothing` in event handlers * Client objects managed by server, automatically cleaned up 3. **Thread Safety** * Events triggered in main thread, can access UI directly * But avoid re-entrancy issues 4. **Error Handling** * Always use `On Error GoTo` to handle errors in events * Prevent one client's error from affecting other clients *** **Last Updated**: 2026-01-09 --- --- url: /en/vbman/winsock/methods.md --- # cWinsock Methods Reference ## 📋 Method List | Method Name | Return Type | Description | |-------------|-------------|-------------| | `Connect` | Sub | Connect to remote server | | `Listen` | Sub | Start listening on port | | `Bind` | Sub | Bind local port (UDP) | | `SendData` | Sub | Send data | | `GetData` | Sub | Receive data | | `PeekData` | Sub | Peek at data without removing | | `Close_` | Sub | Close connection | | `GetErrorDescription` | String | Get error description | | `AcceptFrom` | Sub | Accept connection (internal method) | | `SetUdpClientInfo` | Sub | Set UDP client info (internal method) | | `RemoveClient` | Sub | Remove client (internal method) | | `RaiseDataArrivalEvent` | Sub | Trigger data arrival event (internal method) | *** ## 🔗 Connect Method ### Description Connect to the specified remote server (TCP client mode). ### Syntax ```vb Public Sub Connect(Optional RemoteHost As String, Optional ByVal RemotePort As Long) ``` ### Parameters | Parameter | Type | Description | |-----------|------|-------------| | `RemoteHost` | String (optional) | Remote hostname or IP address. If not provided, uses `RemoteHost` property value | | `RemotePort` | Long (optional) | Remote port number. If not provided, uses `RemotePort` property value | ### Usage Example ```vb ' Connect using parameters m_oClient.Connect "127.0.0.1", 8080 ' Connect using properties m_oClient.RemoteHost = "example.com" m_oClient.RemotePort = 80 m_oClient.Connect ' Connect to specific host m_oClient.RemoteHost = "192.168.1.100" m_oClient.Connect , 8080 ' Only specify port, use already set RemoteHost ``` ### Connection Flow ``` 1. Call Connect() 2. Close existing connection (if any) 3. Resolve hostname → sckResolvingHost 4. Hostname resolved → sckHostResolved 5. Start connecting → sckConnecting 6. Connection successful → sckConnected 7. Trigger Connect event ``` ### Error Handling ```vb Private Sub cmdConnect_Click() On Error GoTo EH m_oClient.Connect "example.com", 8080 Exit Sub EH: Debug.Print "Connection error: " & Err.Description Select Case Err.Number Case 10060 MsgBox "Connection timeout, please check network" Case 10061 MsgBox "Server refused connection, please check port" Case Else MsgBox "Connection failed: " & Err.Description End Select End Sub ``` *** ## 🎧 Listen Method ### Description Start listening on the specified port, waiting for client connections (TCP server mode). ### Syntax ```vb Public Sub Listen(Optional ByVal Port As Long) ``` ### Parameters | Parameter | Type | Description | |-----------|------|-------------| | `Port` | Long (optional) | Port number to listen on. If not provided, uses `LocalPort` property value | ### Usage Example ```vb ' Listen using parameter m_oServer.Listen 8080 ' Listen using property m_oServer.LocalPort = 8080 m_oServer.Listen ' Listen on multiple ports (need multiple cWinsock objects) Dim oServer1 As New cWinsock Dim oServer2 As New cWinsock oServer1.Listen 8080 oServer2.Listen 8081 ``` ### Server Startup Flow ```vb Private Sub StartServer() On Error GoTo EH ' Set protocol m_oServer.Protocol = sckTCPProtocol ' Start listening m_oServer.Listen 8080 Debug.Print "Server started, listening on port: " & m_oServer.LocalPort ' Update UI btnStart.Enabled = False btnStop.Enabled = True lblStatus.Caption = "Listening..." Exit Sub EH: Debug.Print "Failed to start server: " & Err.Description MsgBox "Cannot start server: " & Err.Description, vbExclamation End Sub ``` ### ⚠️ Notes * Must set `Protocol = sckTCPProtocol` before calling `Listen()` * Port must not be already in use * `State` will become `sckListening` *** ## 📌 Bind Method ### Description Bind to local port (UDP server mode). ### Syntax ```vb Public Sub Bind(Optional ByVal LocalPort As Long, Optional LocalIP As String) ``` ### Parameters | Parameter | Type | Description | |-----------|------|-------------| | `LocalPort` | Long (optional) | Local port number to bind | | `LocalIP` | String (optional) | Local IP address to bind (optional) | ### Usage Example ```vb ' Bind port m_oUdp.Protocol = sckUDPProtocol m_oUdp.Bind 8888 ' Bind to specific IP m_oUdp.Bind 8888, "192.168.1.100" ``` ### UDP Server Startup ```vb Private Sub StartUdpServer() On Error GoTo EH ' Set protocol m_oUdp.Protocol = sckUDPProtocol ' Bind port m_oUdp.Bind 8888 Debug.Print "UDP server started, bound to port: " & m_oUdp.LocalPort Exit Sub EH: Debug.Print "UDP bind failed: " & Err.Description MsgBox "Cannot bind UDP port: " & Err.Description, vbExclamation End Sub ``` *** ## 📤 SendData Method ### Description Send data to remote host. ### Syntax ```vb Public Sub SendData(Data As Variant, Optional ByVal CodePage As EnumScpCodePage = ScpAcp) ``` ### Parameters | Parameter | Type | Description | |-----------|------|-------------| | `Data` | Variant | Data to send, can be string or byte array | | `CodePage` | EnumScpCodePage (optional) | Text encoding, default `ScpAcp` (GBK/ACP) | ### Encoding Options | Constant | Value | Description | |----------|-------|-------------| | `ScpAcp` | 0 | System default code page (GBK on Chinese Windows) | | `ScpOem` | 1 | OEM code page | | `ScpUtf8` | 65001 | UTF-8 encoding | | `ScpUnicode` | -1 | Unicode, no encoding conversion | ### Sending String ```vb ' Default uses ACP/GBK encoding m_oClient.SendData "中文测试" ' Use UTF-8 encoding m_oClient.SendData "中文测试", ScpUtf8 ' Use Unicode (no conversion) m_oClient.SendData "中文测试", ScpUnicode ``` ### Sending Byte Array ```vb ' Send byte array Dim baData() As Byte baData = GetBinaryData() m_oClient.SendData baData ``` ### UDP Server Sending ```vb ' In UDP server mode, need to specify remote address Private Sub cmdUdpSend_Click() ' Set target m_oUdp.RemoteHost = "127.0.0.1" m_oUdp.RemotePort = 9999 ' Send data m_oUdp.SendData "Hello, UDP!" End Sub ' Reply to specific client (virtual client) Private Sub m_oUdp_DataArrival(Client As cWinsock, ByVal bytesTotal As Long) Dim sData As String Client.GetData sData ' Reply directly through Client object ' cWinsock automatically uses correct remote address:port Client.SendData "Reply: " & sData End Sub ``` ### Large Data Sending ```vb ' Send large data in chunks Private Sub SendLargeFile(ByVal sFilePath As String) Dim baChunk() As Byte Dim lChunkSize As Long lChunkSize = 8192 ' 8KB per chunk ' Open file... ' Loop read and send Do While Not EOF ' Read data chunk ReadChunk baChunk, lChunkSize ' Send m_oClient.SendData baChunk ' Wait for send completion (via SendComplete event) Do While m_bSending DoEvents Loop Loop End Sub ``` *** ## 📥 GetData Method ### Description Read data from receive buffer. ### Syntax ```vb Public Sub GetData(Data As Variant, Optional ByVal VarType_ As Long, Optional ByVal MaxLen As Long = -1, Optional ByVal CodePage As EnumScpCodePage = ScpAcp) ``` ### Parameters | Parameter | Type | Description | |-----------|------|-------------| | `Data` | Variant | Variable to receive data | | `VarType_` | Long (optional) | Expected data type (e.g., `vbString`, `vbByte + vbArray`) | | `MaxLen` | Long (optional) | Maximum bytes to read, -1 means read all | | `CodePage` | EnumScpCodePage (optional) | Text encoding, default `ScpAcp` | ### Reading String ```vb Private Sub m_oClient_DataArrival(Client As cWinsock, ByVal bytesTotal As Long) Dim sData As String ' Read all data Client.GetData sData Debug.Print "Received: " & sData End Sub ``` ### Reading Byte Array ```vb Private Sub m_oClient_DataArrival(Client As cWinsock, ByVal bytesTotal As Long) Dim baData() As Byte ' Read byte array Client.GetData baData Debug.Print "Received " & bytesTotal & " bytes" End Sub ``` ### Partial Reading ```vb Private Sub m_oClient_DataArrival(Client As cWinsock, ByVal bytesTotal As Long) Dim sHeader As String Dim sBody As String ' Read first 10 bytes as header Client.GetData sHeader, vbString, 10 Debug.Print "Header: " & sHeader ' Read remaining data Client.GetData sBody Debug.Print "Body: " & sBody End Sub ``` ### Specified Encoding Reading ```vb Private Sub m_oClient_DataArrival(Client As cWinsock, ByVal bytesTotal As Long) Dim sData As String ' Read using UTF-8 encoding Client.GetData sData, vbString, -1, ScpUtf8 Debug.Print "UTF-8 data: " & sData End Sub ``` ### Protocol Parsing ```vb Private Type tPacketHeader Magic As Long ' Magic number Length As Long ' Data length Type As Long ' Data type End Type Private Sub m_oServer_DataArrival(Client As cWinsock, ByVal bytesTotal As Long) Dim tHeader As tPacketHeader Dim baBody() As Byte ' Read header Client.GetData tHeader ' Verify magic number If tHeader.Magic = &H12345678 Then ' Read data body ReDim baBody(0 To tHeader.Length - 1) As Byte Client.GetData baBody Debug.Print "Data type: " & tHeader.Type Debug.Print "Data length: " & tHeader.Length End If End Sub ``` *** ## 👁️ PeekData Method ### Description Peek at data without removing from buffer. ### Syntax ```vb Public Sub PeekData(Data As Variant, Optional ByVal VarType_ As Long, Optional ByVal MaxLen As Long = -1, Optional ByVal CodePage As EnumScpCodePage = ScpAcp) ``` ### Parameters Same as `GetData`. ### Usage Example ```vb Private Sub m_oClient_DataArrival(Client As cWinsock, ByVal bytesTotal As Long) Dim sPeek As String Dim sActual As String ' Peek at data first Client.PeekData sPeek Debug.Print "Peek data: " & sPeek ' Then read data Client.GetData sActual Debug.Print "Actual data: " & sActual End Sub ``` ### Protocol Detection ```vb Private Sub m_oServer_DataArrival(Client As cWinsock, ByVal bytesTotal As Long) Dim sPeek As String ' Peek at first few characters to detect protocol Client.PeekData sPeek, vbString, 4 If Left$(sPeek, 4) = "HTTP" Then Debug.Print "HTTP request" HandleHttpRequest Client ElseIf Left$(sPeek, 4) = "CHAT" Then Debug.Print "Chat protocol" HandleChatMessage Client Else Debug.Print "Unknown protocol" End If End Sub ``` *** ## 🔒 Close\_ Method ### Description Close connection or stop listening. ### Syntax ```vb Public Sub Close_() ``` ### Usage Example ```vb ' Close client connection Private Sub cmdDisconnect_Click() m_oClient.Close_ Debug.Print "Disconnected" End Sub ' Stop server Private Sub cmdStopServer_Click() m_oServer.Close_ Debug.Print "Server stopped" End Sub ' Close specific client Private Sub DisconnectClient(ByVal oClient As cWinsock) oClient.Close_ m_oServer.RemoveClient oClient End Sub ``` ### Auto Close ```vb ' Auto close when form unloads Private Sub Form_Unload(Cancel As Integer) On Error Resume Next m_oClient.Close_ m_oServer.Close_ m_oUdp.Close_ End Sub ``` *** ## 📝 GetErrorDescription Method ### Description Get description of error code. ### Syntax ```vb Public Function GetErrorDescription(ByVal ErrorCode As Long) As String ``` ### Usage Example ```vb Private Sub m_oClient_Error(Client As cWinsock, ByVal Number As Long, Description As String, ByVal Scode As Long) ' Use description from parameter Debug.Print "Error: " & Description ' Or use GetErrorDescription to get Debug.Print "Error description: " & Client.GetErrorDescription(Number) End Sub ' Independent use Dim sDesc As String sDesc = m_oClient.GetErrorDescription(10060) Debug.Print sDesc ' "Connection timeout" ``` *** ## 🤝 Friend Methods The following methods are for internal use, usually don't need to call directly: ### AcceptFrom Accept new connection (called by `OnAccept` event). ### SetUdpClientInfo Set UDP virtual client info (called by `OnReceive` event). ### RemoveClient Remove client (called by `CloseEvent` or manually). ### RaiseDataArrivalEvent Trigger data arrival event (called by client object, triggered through parent server). *** ## 📌 Method Usage Scenarios Summary ### TCP Client Flow ```vb 1. m_oClient.Connect("127.0.0.1", 8080) 2. Wait for m_oClient_Connect event 3. m_oClient.SendData("Hello") 4. Wait for m_oClient_DataArrival event 5. Client.GetData sData 6. m_oClient.Close_() ``` ### TCP Server Flow ```vb 1. m_oServer.Listen(8080) 2. Wait for m_oServer_ConnectionRequest event 3. Set DisConnect = False to accept 4. Wait for m_oServer_DataArrival event 5. Client.GetData sData 6. Client.SendData("Reply") 7. Wait for m_oServer_CloseEvent event ``` ### UDP Flow ```vb 1. m_oUdp.Bind(8888) 2. Wait for m_oUdp_DataArrival event 3. Client.GetData sData 4. Client.SendData("Reply") 5. m_oUdp.Close_() ``` *** **Last Updated**: 2026-01-09 --- --- url: /en/vbman/winsock/properties.md --- # cWinsock Properties Reference\r\n\r\n## 📋 Properties List\r\n\r\n| Property Name | Type | Access | Description |\r\n|---------------|------|--------|-------------|\r\n| `State` | WinsockState | Read-only | Current Socket state |\r\n| `Protocol` | WinsockProtocol | Read/Write | Protocol type (TCP/UDP) |\r\n| `RecvBuffer` | Byte() | Read/Write | Custom receive buffer |\r\n| `LocalPort` | Long | Read/Write | Local port |\r\n| `RemoteHost` | String | Read/Write | Remote hostname |\r\n| `RemotePort` | Long | Read/Write | Remote port |\r\n| `RemoteHostIP` | String | Read-only | Resolved remote IP address |\r\n| `LocalHostName` | String | Read-only | Local hostname |\r\n| `LocalIP` | String | Read-only | Local IP address |\r\n| `Tag` | String | Read/Write | User-defined tag (pure business identifier, no longer used internally) |\r\n| `ClientId` | Long | Read-only | Server-assigned unique connection identifier (auto-increment, no duplicates) |\r\n| `UserData` | Variant | Read/Write | User-defined data |\r\n| `SocketHandle` | Long | Read-only | Socket handle |\r\n| `BytesReceived` | Long | Read-only | Available data byte count |\r\n| `IsServer` | Boolean | Read-only | Whether in server mode |\r\n| `IsAcceptedClient` | Boolean | Read-only | Whether accepted by server |\r\n| `ParentServer` | cWinsock | Read-only | Parent server object (client only) |\r\n| `Clients` | Collection | Read-only | Collection of all connected clients (server only) |\r\n| `ClientCount` | Long | Read-only | Client connection count (server only) |\r\n| `CurrentUser` | Variant | Read/Write | Bound username (user binding feature) |\r\n| `CurrentUserToken` | String | Read/Write | User authentication token (user binding feature) |\r\n| `CurrentUserInfo` | cJson | Read/Write | User extended info (user binding feature) |\r\n| `CountUsers` | Long | Read-only | Current bound user count (user binding feature) |\r\n| `CountGroups` | Long | Read-only | Current group count (user binding feature) |\r\n| `PacketHandler` | cPacketProtocol | Read/Write | Packet protocol handler object (advanced configuration) |\r\n| `PacketProtocol` | PacketProtocolType | Read/Write | Packet protocol type (quick setup) |\r\n| `Delimiter` | String | Read/Write | Delimiter protocol delimiter (default vbCrLf) |\r\n| `FixedLength` | Long | Read/Write | Fixed-length protocol message length |\r\n| `HeaderBytes` | Long | Read/Write | Length-header protocol header bytes (2 or 4, default 4) |\r\n| `HeaderEndian` | EndianEnum | Read/Write | Length-header protocol byte order (default little-endian) |\r\n| `MaxPacketSize` | Long | Read/Write | Single packet max bytes (default 1MB), prevent malicious oversized packets |\r\n| `MaxBufferSize` | Long | Read/Write | Buffer accumulation limit (default 4MB), prevent memory exhaustion |\r\n| `Heartbeat` | cHeartbeat | Read-only | Heartbeat manager object (advanced configuration) |\r\n| `AutoHeartbeat` | Boolean | Read/Write | Enable/disable auto heartbeat (embedded cTimer) |\r\n| `HeartbeatTimeout` | Long | Read/Write | Server heartbeat timeout seconds (default 120) |\r\n| `HeartbeatInterval` | Long | Read/Write | Client heartbeat interval seconds (default 50) |\r\n| `HeartbeatData` | Byte() | Read/Write | Heartbeat packet content (default single byte 0) |\r\n| `IdleSeconds` | Long | Read-only | Current idle seconds |\r\n\r\n---\r\n\r\n## 🔄 State Property\r\n\r\n### Description\r\n\r\nReturns the current Socket state.\r\n\r\n### Syntax\r\n\r\n`vb\r\nProperty Get State() As WinsockState\r\n`\r\n\r\n### Return Values\r\n\r\n| Constant | Value | Description |\r\n|----------|-------|-------------|\r\n| `sckClosed` | 0 | Closed |\r\n| `sckOpen` | 1 | Open (after UDP binding) |\r\n| `sckListening` | 2 | Listening (TCP server) |\r\n| `sckConnectionPending` | 3 | Connection pending |\r\n| `sckResolvingHost` | 4 | Resolving hostname |\r\n| `sckHostResolved` | 5 | Hostname resolved |\r\n| `sckConnecting` | 6 | Connecting |\r\n| `sckConnected` | 7 | Connected |\r\n| `sckClosing` | 8 | Closing |\r\n| `sckError` | 9 | Error occurred |\r\n\r\n### Usage Example\r\n\r\n`vb\r\nPrivate Sub cmdConnect_Click()\r\n If m_oClient.State = sckClosed Then\r\n m_oClient.Connect "127.0.0.1", 8080\r\n Else\r\n MsgBox "Socket not closed, current state: " & GetStateName(m_oClient.State)\r\n End If\r\nEnd Sub\r\n\r\nPrivate Function GetStateName(ByVal eState As WinsockState) As String\r\n Select Case eState\r\n Case sckClosed: GetStateName = "Closed"\r\n Case sckOpen: GetStateName = "Open"\r\n Case sckListening: GetStateName = "Listening"\r\n Case sckConnected: GetStateName = "Connected"\r\n Case sckClosing: GetStateName = "Closing"\r\n Case sckError: GetStateName = "Error"\r\n Case Else: GetStateName = "Unknown"\r\n End Select\r\nEnd Function\r\n`\r\n\r\n---\r\n\r\n## 🌐 Protocol Property\r\n\r\n### Description\r\n\r\nGets or sets the protocol type used by the Socket.\r\n\r\n### Syntax\r\n\r\n`vb\r\nProperty Get Protocol() As WinsockProtocol\r\nProperty Let Protocol(ByVal Value As WinsockProtocol)\r\n`\r\n\r\n### Values\r\n\r\n| Constant | Value | Description |\r\n|----------|-------|-------------|\r\n| `sckTCPProtocol` | 1 | TCP protocol (reliable, connection-oriented) |\r\n| `sckUDPProtocol` | 2 | UDP protocol (unreliable, connectionless) |\r\n\r\n### Usage Example\r\n\r\n`vb\r\n' Set to TCP protocol\r\nm_oSocket.Protocol = sckTCPProtocol\r\n\r\n' Set to UDP protocol\r\nm_oSocket.Protocol = sckUDPProtocol\r\n\r\n' Check current protocol\r\nIf m_oSocket.Protocol = sckTCPProtocol Then\r\n Debug.Print "Using TCP protocol"\r\nElse\r\n Debug.Print "Using UDP protocol"\r\nEnd If\r\n`\r\n\r\n### ⚠️ Notes\r\n\r\n- Can only be modified when `State = sckClosed`\r\n- After modification, need to call `Connect()`, `Listen()` or `Bind()` again\r\n\r\n---\r\n\r\n## 📦 RecvBuffer Property\r\n\r\n### Description\r\n\r\nSets or gets custom receive buffer. Usually used for advanced scenarios.\r\n\r\n### Syntax\r\n\r\n`vb\r\nProperty Let RecvBuffer(ByRef Value() As Byte)\r\n`\r\n\r\n### Usage Example\r\n\r\n`vb\r\n' Set custom buffer\r\nDim baCustomBuffer() As Byte\r\nReDim baCustomBuffer(0 To 8191) ' 8KB buffer\r\nm_oSocket.RecvBuffer = baCustomBuffer\r\n`\r\n\r\n---\r\n\r\n## 🔌 LocalPort Property\r\n\r\n### Description\r\n\r\nGets or sets local port number.\r\n\r\n### Syntax\r\n\r\n`vb\r\nProperty Get LocalPort() As Long\r\nProperty Let LocalPort(ByVal Value As Long)\r\n`\r\n\r\n### Usage Example\r\n\r\n`vb\r\n' Set local port (must be done before calling Connect/Listen/Bind)\r\nm_oServer.LocalPort = 8080\r\nm_oServer.Listen\r\n\r\n' Get actual bound port\r\nDebug.Print "Local port: " & m_oSocket.LocalPort\r\n`\r\n\r\n### ⚠️ Notes\r\n\r\n- Can only be set when `State = sckClosed`\r\n- Range: 0-65535\r\n- 0 means auto-assigned by system\r\n\r\n---\r\n\r\n## 🌍 RemoteHost Property\r\n\r\n### Description\r\n\r\nGets or sets remote hostname (domain name or IP).\r\n\r\n### Syntax\r\n\r\n`vb\r\nProperty Get RemoteHost() As String\r\nProperty Let RemoteHost(ByVal Value As String)\r\n`\r\n\r\n### Usage Example\r\n\r\n`vb\r\n' Set remote host (can use domain name)\r\nm_oClient.RemoteHost = "example.com"\r\nm_oClient.RemotePort = 80\r\nm_oClient.Connect\r\n\r\n' Use IP address\r\nm_oClient.RemoteHost = "192.168.1.100"\r\nm_oClient.RemotePort = 8080\r\nm_oClient.Connect\r\n\r\n' Get remote hostname\r\nDebug.Print "Remote host: " & m_oClient.RemoteHost\r\n`\r\n\r\n---\r\n\r\n## 🔢 RemotePort Property\r\n\r\n### Description\r\n\r\nGets or sets remote port number.\r\n\r\n\r\n\r\n### Syntax\r\n\r\n`vb\r\nProperty Get RemotePort() As Long\r\nProperty Let RemotePort(ByVal Value As Long)\r\n`\r\n\r\n### Usage Example\r\n\r\n`vb\r\n' Set remote port\r\nm_oClient.RemotePort = 8080\r\n\r\n' Get remote port\r\nDebug.Print "Remote port: " & m_oClient.RemotePort\r\n`\r\n\r\n---\r\n\r\n## 🖥️ RemoteHostIP Property\r\n\r\n### Description\r\n\r\nGets resolved remote IP address (read-only).\r\n\r\n\r\n\r\n### Syntax\r\n\r\n`vb\r\nProperty Get RemoteHostIP() As String\r\n`\r\n\r\n### Usage Example\r\n\r\n`vb\r\nPrivate Sub m_oClient_Connect(Client As cWinsock)\r\n Debug.Print "Connection successful!"\r\n Debug.Print "Hostname: " & Client.RemoteHost\r\n Debug.Print "IP address: " & Client.RemoteHostIP\r\n Debug.Print "Port: " & Client.RemotePort\r\nEnd Sub\r\n`\r\n\r\n### Special Case: UDP Server Virtual Client\r\n\r\n`vb\r\nPrivate Sub m_oUdp_DataArrival(Client As cWinsock, ByVal bytesTotal As Long)\r\n ' In UDP server mode, virtual client's RemoteHostIP returns sender IP\r\n Debug.Print "Received from " & Client.RemoteHostIP & ":" & Client.RemotePort\r\nEnd Sub\r\n`\r\n\r\n---\r\n\r\n## 💻 LocalHostName Property\r\n\r\n### Description\r\n\r\nGets local hostname.\r\n\r\n\r\n\r\n### Syntax\r\n\r\n`vb\r\nProperty Get LocalHostName() As String\r\n`\r\n\r\n### Usage Example\r\n\r\n`vb\r\nDebug.Print "Local hostname: " & m_oSocket.LocalHostName\r\n`\r\n\r\n---\r\n\r\n## 🌐 LocalIP Property\r\n\r\n### Description\r\n\r\nGets local IP address.\r\n\r\n\r\n\r\n### Syntax\r\n\r\n`vb\r\nProperty Get LocalIP() As String\r\n`\r\n\r\n### Usage Example\r\n\r\n`vb\r\nDebug.Print "Local IP: " & m_oSocket.LocalIP\r\n`\r\n\r\n---\r\n\r\n## 🏷️ Tag Property\r\n\r\n### Description\r\n\r\nUser-defined tag for business identification or grouping. Can be freely read/written, **internal management no longer relies on this property**.\r\n\r\n\r\n\r\n### Syntax\r\n\r\n`vb\r\nProperty Get Tag() As String\r\nProperty Let Tag(ByVal Value As String)\r\n`\r\n\r\n### Usage Example\r\n\r\n`vb\r\n' Set business tag for client in ConnectionRequest\r\nPrivate Sub m_oServer_ConnectionRequest(Client As cWinsock, ByRef DisConnect As Boolean)\r\n Client.Tag = "Client-" & Client.RemoteHostIP\r\n Debug.Print "New client Tag: " & Client.Tag\r\nEnd Sub\r\n\r\n' Find client by Tag (need to iterate manually)\r\nPrivate Function FindClientByTag(ByVal sTag As String) As cWinsock\r\n Dim oClient As cWinsock\r\n For Each oClient In m_oServer.Clients\r\n If oClient.Tag = sTag Then\r\n Set FindClientByTag = oClient\r\n Exit Function\r\n End If\r\n Next\r\n Set FindClientByTag = Nothing\r\nEnd Function\r\n`\r\n\r\n---\r\n\r\n## 🆔 ClientId Property\r\n\r\n### Description\r\n\r\nServer-assigned unique connection identifier (read-only). Auto-increment number, starting from `1`, not reused after disconnect, never duplicates.\r\n\r\n- Server's own (Listen socket) `ClientId = 0`.\r\n- Both TCP and UDP client connections are auto-assigned.\r\n\r\n\r\n\r\n### Syntax\r\n\r\n`vb\r\nProperty Get ClientId() As Long\r\n`\r\n\r\n### Usage Example\r\n\r\n`vb\r\n' Identify client in ConnectionRequest or DataArrival\r\nPrivate Sub m_oServer_ConnectionRequest(Client As cWinsock, ByRef DisConnect As Boolean)\r\n Debug.Print "New client connected, ID: " & Client.ClientId & " from " & Client.RemoteHostIP\r\nEnd Sub\r\n\r\n' Use ID for logging or key mapping\r\nPrivate Sub m_oServer_DataArrival(Client As cWinsock, ByVal bytesTotal As Long)\r\n Debug.Print "Client #" & Client.ClientId & " sent " & bytesTotal & " bytes"\r\nEnd Sub\r\n`\r\n\r\n| Feature | Description |\r\n|---------|-------------|\r\n| Readability | `#1`, `#42` instantly recognizable |\r\n| Uniqueness | Monotonically increasing, no duplicates within lifecycle |\r\n| Type | `Long`, easy to compare and store |\r\n\r\n---\r\n\r\n## 💾 UserData Property\r\n\r\n### Description\r\n\r\nUser-defined data storage, can store any type of data.\r\n\r\n\r\n\r\n### Syntax\r\n\r\n`vb\r\nProperty Get UserData() As Variant\r\nProperty Let UserData(ByVal Value As Variant)\r\nProperty Set UserData(ByVal Value As Variant)\r\n`\r\n\r\n### Usage Example\r\n\r\n`vb\r\n' Store string\r\nm_oClient.UserData = "User info: Zhang San"\r\n\r\n' Store number\r\nm_oClient.UserData = 12345\r\n\r\n' Store object\r\nDim oUserInfo As New CUserInfo\r\noUserInfo.Name = "Zhang San"\r\noUserInfo.Age = 25\r\nSet m_oClient.UserData = oUserInfo\r\n\r\n' Read data\r\nDim sInfo As String\r\nsInfo = m_oClient.UserData\r\nDebug.Print sInfo\r\n\r\n' Read object\r\nDim oUserData As CUserInfo\r\nSet oUserData = m_oClient.UserData\r\nDebug.Print oUserInfo.Name & ", " & oUserData.Age\r\n`\r\n\r\n### Advanced Usage: Client Session Data\r\n\r\n`vb\r\nPrivate Type tSessionData\r\n LoginTime As Date\r\n LastActivity As Date\r\n LoginAttempts As Long\r\n Authenticated As Boolean\r\nEnd Type\r\n\r\nPrivate Sub m_oServer_ConnectionRequest(Client As cWinsock, ByRef DisConnect As Boolean)\r\n Dim tSession As tSessionData\r\n tSession.LoginTime = Now\r\n tSession.LastActivity = Now\r\n tSession.LoginAttempts = 0\r\n tSession.Authenticated = False\r\n \r\n Client.UserData = tSession\r\nEnd Sub\r\n\r\nPrivate Sub CheckSessionTimeout()\r\n Dim oClient As cWinsock\r\n Dim tSession As tSessionData\r\n \r\n For Each oClient In m_oServer.Clients\r\n tSession = oClient.UserData\r\n If DateDiff("s", tSession.LastActivity, Now) > 300 Then ' 5 minutes of inactivity\r\n Debug.Print "Session timeout, disconnecting: " & oClient.ClientId\r\n oClient.Close_\r\n End If\r\n Next\r\nEnd Sub\r\n`\r\n\r\n---\r\n\r\n## 🔑 SocketHandle Property\r\n\r\n### Description\r\n\r\nGets underlying Socket handle (read-only).\r\n\r\n\r\n\r\n### Syntax\r\n\r\n`vb\r\nProperty Get SocketHandle() As Long\r\n`\r\n\r\n### Usage Example\r\n\r\n`vb\r\n' Get Socket handle\r\nDebug.Print "Socket handle: " & m_oSocket.SocketHandle\r\n\r\n' Used for advanced operations (e.g., Win32 API interaction)\r\r\nIf m_oSocket.SocketHandle <> 0 Then\r\n Call SomeWin32Function(m_oSocket.SocketHandle)\r\nEnd If\r\n`\r\n\r\n---\r\n\r\n## 📊 BytesReceived Property\r\n\r\n### Description\r\n\r\nGets available byte count in receive buffer (read-only).\r\n\r\n\r\n\r\n### Syntax\r\n\r\n`vb\r\nProperty Get BytesReceived() As Long\r\n`\r\n\r\n### Usage Example\r\n\r\n`vb\r\nPrivate Sub m_oClient_DataArrival(Client As cWinsock, ByVal bytesTotal As Long)\r\n Debug.Print "Event notification: " & bytesTotal & " bytes"\r\n Debug.Print "Buffer total: " & Client.BytesReceived & " bytes"\r\n \r\n ' Read only partial data\r\n If Client.BytesReceived > 100 Then\r\n Dim sData As String\r\n Client.GetData sData, vbString, 100 ' Read only first 100 bytes\r\n Debug.Print "Read partial data: " & sData\r\n End If\r\nEnd Sub\r\n`\r\n\r\n---\r\n\r\n## 🏢 IsServer Property\r\n\r\n### Description\r\n\r\nDetermines if current object is in server mode (read-only).\r\n\r\n\r\n\r\n### Syntax\r\n\r\n`vb\r\nProperty Get IsServer() As Boolean\r\n`\r\n\r\n### Usage Example\r\n\r\n`vb\r\nPrivate Sub m_oServer_DataArrival(Client As cWinsock, ByVal bytesTotal As Long)\r\n If Client.IsServer Then\r\n Debug.Print "Data from server"\r\n Else\r\n Debug.Print "Data from client"\r\n End If\r\nEnd Sub\r\n`\r\n\r\n---\r\n\r\n## 🔗 IsAcceptedClient Property\r\n\r\n### Description\r\n\r\nDetermines if current object is a client accepted by server (read-only).\r\n\r\n\r\n\r\n### Syntax\r\n\r\n`vb\r\nProperty Get IsAcceptedClient() As Boolean\r\n`\r\n\r\n### Usage Example\r\n\r\n`vb\r\nPrivate Sub SomeFunction(oSocket As cWinsock)\r\n If oSocket.IsAcceptedClient Then\r\n Debug.Print "This is a client accepted by server"\r\n Debug.Print "Parent server: " & oSocket.ParentServer.Tag\r\n Else\r\n Debug.Print "This is an independent client or server object"\r\n End If\r\nEnd Sub\r\n`\r\n\r\n---\r\n\r\n## 👆 ParentServer Property\r\n\r\n### Description\r\n\r\nGets parent server object (only valid for server-accepted clients).\r\n\r\n\r\n\r\n### Syntax\r\n\r\n`vb\r\nProperty Get ParentServer() As cWinsock\r\n`\r\n\r\n### Usage Example\r\n\r\n`vb\r\nPrivate Sub m_oServer_ConnectionRequest(Client As cWinsock, ByRef DisConnect As Boolean)\r\n ' Server sets ParentServer\r\n ' Client can access parent server\r\n \r\n Debug.Print "New client's parent server: " & Client.ParentServer.Tag\r\nEnd Sub\r\n`\r\n\r\n### Advanced Usage: Client Broadcast Message\r\n\r\n`vb\r\n' In some client event, broadcast to other clients through parent server\r\nPrivate Sub ClientBroadcastToOthers(ByVal oSender As cWinsock, ByVal sMessage As String)\r\n Dim oClient As cWinsock\r\n For Each oClient In oSender.ParentServer.Clients\r\n If Not oClient Is oSender Then ' Don't send to self\r\n oClient.SendData sMessage\r\n End If\r\n Next\r\nEnd Sub\r\n`\r\n\r\n---\r\n\r\n## 👥 Clients Property\r\n\r\n### Description\r\n\r\nGets collection of all connected clients (only valid for server objects).\r\n\r\n\r\n\r\n### Syntax\r\n\r\n`vb\r\nProperty Get Clients() As Collection\r\n`\r\n\r\n### Usage Example\r\n\r\n`vb\r\n' Iterate through all clients\r\nPrivate Sub ListAllClients()\r\n Debug.Print "Current connections: " & m_oServer.ClientCount\r\n \r\n Dim oClient As cWinsock\r\n For Each oClient In m_oServer.Clients\r\n Debug.Print oClient.Tag & ": " & oClient.RemoteHostIP & ":" & oClient.RemotePort\r\n Next\r\nEnd Sub\r\n\r\n' Find specific client\r\nPrivate Function FindClientByIP(ByVal sIP As String) As cWinsock\r\n Dim oClient As cWinsock\r\n For Each oClient In m_oServer.Clients\r\n If oClient.RemoteHostIP = sIP Then\r\n Set FindClientByIP = oClient\r\n Exit Function\r\n End If\r\n Next\r\n Set FindClientByIP = Nothing\r\nEnd Function\r\n\r\n' Broadcast to all clients\r\nPrivate Sub BroadcastToAll(ByVal sMessage As String)\r\n Dim oClient As cWinsock\r\n For Each oClient In m_oServer.Clients\r\n On Error Resume Next\r\n oClient.SendData sMessage\r\n On Error GoTo 0\r\n Next\r\nEnd Sub\r\n`\r\n\r\n---\r\n\r\n## 🔢 ClientCount Property\r\n\r\n### Description\r\n\r\nGets current number of connected clients (read-only, only valid for server objects).\r\n\r\n\r\n\r\n### Syntax\r\n\r\n`vb\r\nProperty Get ClientCount() As Long\r\n`\r\n\r\n### Usage Example\r\n\r\n`vb\r\n' Display connection count\r\nlblClientCount.Caption = "Current connections: " & m_oServer.ClientCount\r\n\r\n' Limit maximum connections\r\nPrivate Sub m_oServer_ConnectionRequest(Client As cWinsock, ByRef DisConnect As Boolean)\r\n If m_oServer.ClientCount >= m_lMaxClients Then\r\n Debug.Print "Maximum connection limit reached: " & m_lMaxClients\r\n DisConnect = True\r\n End If\r\nEnd Sub\r\n`\r\n\r\n---\r\n\r\n## 👤 CurrentUser Property\r\n\r\n### Description\r\n\r\nGets or sets bound username (for user binding feature). After binding user with `BindUser` method, this property is automatically set to the username.\r\n\r\n\r\n\r\n### Syntax\r\n\r\n`vb\r\nPublic CurrentUser As Variant\r\n`\r\n\r\n### Usage Example\r\n\r\n`vb\r\n' Bind user when client connects\r\nPrivate Sub m_oServer_DataArrival(Client As cWinsock, ByVal bytesTotal As Long)\r\n Dim sData As String\r\n Client.GetData sData\r\n \r\n If Left$(sData, 6) = "LOGIN:" Then\r\n Dim sUsername As String\r\n sUsername = Mid$(sData, 7)\r\n \r\n ' Bind user\r\n m_oServer.BindUser sUsername, Client\r\n \r\n ' Verify binding successful\r\n Debug.Print "Client.CurrentUser = " & Client.CurrentUser\r\n End If\r\nEnd Sub\r\n\r\n' Check if user is logged in\r\nPrivate Sub CheckUserLogin(ByVal oClient As cWinsock)\r\n If LenB(CStr(oClient.CurrentUser)) = 0 Then\r\n Debug.Print "User not logged in"\r\n Else\r\n Debug.Print "Current user: " & oClient.CurrentUser\r\n End If\r\nEnd Sub\r\n`\r\n\r\n### Difference from Tag Property\r\n\r\n| Property | Purpose | Setting Method |\r\n|----------|---------|----------------|\r\n| `Tag` | User-defined business identifier | Manually set |\r\n| `ClientId` | System-assigned connection number | Auto-assigned by server |\r\n| `CurrentUser` | Identifies logged-in user | Bound via `BindUser` |\r\n\r\n### Auto Cleanup\r\n\r\nWhen client disconnects (calls `Close_` or object is destroyed), system automatically unbinds user, no manual handling needed.\r\n\r\n---\r\n\r\n## 🔑 CurrentUserToken Property\r\n\r\n### Description\r\n\r\nGets or sets user authentication token (for user binding feature). When binding user with `BindUser` method and passing `Token` parameter, this property is automatically set to the corresponding value.\r\n\r\n\r\n\r\n### Syntax\r\n\r\n`vb\r\nPublic CurrentUserToken As String\r\n`\r\n\r\n### Usage Example\r\n\r\n`vb\r\n' Bind user with Token\r\nm_oServer.BindUser "alice", Client, "jwt_token_xyz123"\r\n\r\n' Verify Token later\r\nIf Client.CurrentUserToken = "jwt_token_xyz123" Then\r\n Debug.Print "Token verification passed"\r\nEnd If\r\n\r\n' Get current user's Token\r\nDebug.Print "User " & Client.CurrentUser & "'s Token: " & Client.CurrentUserToken\r\n`\r\n\r\n---\r\n\r\n## 📋 CurrentUserInfo Property\r\n\r\n### Description\r\n\r\nGets or sets user extended info (for user binding feature). When binding user with `BindUser` method and passing `Info` parameter (cJson object), this property is automatically set to the corresponding value. Can be used to store additional user metadata such as login time, IP address, permission level, etc.\r\n\r\n\r\n\r\n### Syntax\r\n\r\n`vb\r\nPublic CurrentUserInfo As cJson\r\n`\r\n\r\n### Usage Example\r\n\r\n`vb\r\n' Bind user with extended info\r\nDim oInfo As New cJson\r\noInfo.Add "loginTime", Now\r\noInfo.Add "ip", Client.RemoteHostIP\r\noInfo.Add "role", "admin"\r\nm_oServer.BindUser "alice", Client, , oInfo\r\n\r\n' Read user extended info\r\nDebug.Print "Login time: " & Client.CurrentUserInfo.Item("loginTime")\r\nDebug.Print "Role: " & Client.CurrentUserInfo.Item("role")\r\n\r\n' Dynamically add info\r\nClient.CurrentUserInfo.Add "lastActivity", Now\r\n`\r\n\r\n### Difference from UserData\r\n\r\n| Property | Purpose | Lifecycle |\r\n|----------|---------|-----------|\r\n| `UserData` | General custom data storage | Manually managed by user |\r\n| `CurrentUserInfo` | User-bound structured info (JSON) | Auto-managed with `BindUser`/`UnbindUser` |\r\n\r\n---\r\n\r\n## 🔢 CountUsers Property\r\n\r\n### Description\r\n\r\nGets current number of bound users (read-only). Users bound via `BindUser` method are counted.\r\n\r\n\r\n\r\n### Syntax\r\n\r\n`vb\r\nProperty Get CountUsers() As Long\r\n`\r\n\r\n### Usage Example\r\n\r\n`vb\r\n' Display current bound user count\r\nDebug.Print "Current bound users: " & m_oServer.CountUsers\r\n\r\n' Monitor user login status\r\nPrivate Sub UpdateUserCount()\r\n lblUserCount.Caption = "Online users: " & m_oServer.CountUsers\r\nEnd Sub\r\n\r\n' Check in DataArrival\r\nPrivate Sub m_oServer_DataArrival(Client As cWinsock, ByVal bytesTotal As Long)\r\n Debug.Print "Current total bound users: " & m_oServer.CountUsers\r\nEnd Sub\r\n`\r\n\r\n---\r\n\r\n## 👥 CountGroups Property\r\n\r\n### Description\r\n\r\nGets current number of groups (read-only). Groups created via `AddGroup` method are counted.\r\n\r\n\r\n\r\n### Syntax\r\n\r\n`vb\r\nProperty Get CountGroups() As Long\r\n`\r\n\r\n### Usage Example\r\n\r\n`vb\r\n' Display current group count\r\nDebug.Print "Current group count: " & m_oServer.CountGroups\r\n\r\n' Create default groups on initialization\r\nPrivate Sub InitializeGroups()\r\n If m_oServer.CountGroups = 0 Then\r\n m_oServer.AddGroup "Default"\r\n m_oServer.AddGroup "Admins"\r\n End If\r\nEnd Sub\r\n`\r\n\r\n---\r\n\r\n## 📦 PacketHandler Property\r\n\r\n### Description\r\n\r\nGets or sets packet protocol handler object. Each cWinsock instance holds independent protocol instance, multi-client互不干扰.\r\n\r\n\r\n\r\n### Syntax\r\n\r\n`vb\r\nProperty Get PacketHandler() As cPacketProtocol\r\nProperty Set PacketHandler(ByVal Value As cPacketProtocol)\r\n`\r\n\r\n### Usage Example\r\n\r\n`vb\r\n' Advanced configuration: directly operate protocol object\r\nDim oProtocol As cPacketProtocol\r\nSet oProtocol = New cPacketProtocol\r\noProtocol.ProtocolType = ppLengthHeader\r\noProtocol.HeaderBytes = 4\r\r\noProtocol.Endian = eeBigEndian\r\n\r\nSet m_oServer.PacketHandler = oProtocol\r\n`\r\n\r\n---\r\n\r\n## 📦 PacketProtocol Property\r\n\r\n### Description\r\n\r\nQuick setup for packet protocol type. Setting automatically creates protocol handler (if not existing). Set to `ppNone` to disable protocol.\r\n\r\n\r\n\r\n### Syntax\r\n\r\n`vb\r\nProperty Get PacketProtocol() As PacketProtocolType\r\r\nProperty Let PacketProtocol(ByVal Value As PacketProtocolType)\r\n`\r\n\r\n### Values\r\n\r\n| Constant | Value | Description |\r\n|----------|-------|-------------|\r\n| `ppNone` | 0 | No protocol (default) |\r\n| `ppDelimiter` | 1 | Character delimiter protocol |\r\n| `ppFixedLength` | 2 | Fixed-length protocol |\r\n| `ppLengthHeader` | 3 | Length-header protocol |\r\n\r\n### Usage Example\r\n\r\n`vb\r\n' Set delimiter protocol\r\nm_oServer.PacketProtocol = ppDelimiter\r\nm_oServer.Delimiter = vbCrLf\r\n\r\n' Set length-header protocol\r\nm_oServer.PacketProtocol = ppLengthHeader\r\nm_oServer.HeaderBytes = 4\r\n\r\n' Disable protocol\r\nm_oServer.PacketProtocol = ppNone\r\n`\r\n\r\n---\r\n\r\n## 📦 Delimiter Property\r\n\r\n### Description\r\n\r\nSets or gets delimiter protocol delimiter. Default is `vbCrLf`. Only effective when `PacketProtocol = ppDelimiter`.\r\n\r\n\r\n\r\n### Syntax\r\n\r\n`vb\r\nProperty Get Delimiter() As String\r\r\nProperty Let Delimiter(ByVal Value As String)\r\n`\r\n\r\n### Usage Example\r\n\r\n`vb\r\n' Use newline as delimiter (suitable for text line protocol)\r\nm_oServer.PacketProtocol = ppDelimiter\r\nm_oServer.Delimiter = vbCrLf\r\n\r\n' Use null character as delimiter (suitable for binary-text mixed protocol)\r\nm_oServer.Delimiter = vbNullChar\r\n\r\n' Use custom delimiter\r\r\nm_oServer.Delimiter = ""\r\n`\r\n\r\n---\r\n\r\n## 📦 FixedLength Property\r\n\r\n### Description\r\n\r\nSets or gets fixed-length protocol message length. Only effective when `PacketProtocol = ppFixedLength`.\r\n\r\n\r\n\r\n### Syntax\r\n\r\n`vb\r\nProperty Get FixedLength() As Long\r\nProperty Let FixedLength(ByVal Value As Long)\r\n`\r\n\r\n### Usage Example\r\n\r\n`vb\r\n' Each message fixed 256 bytes\r\nm_oServer.PacketProtocol = ppFixedLength\r\nm_oServer.FixedLength = 256\r\n`\r\n\r\n---\r\n\r\n## 📦 HeaderBytes Property\r\n\r\n### Description\r\n\r\nSets or gets length-header protocol header bytes. 2 means Integer (max 65535 bytes), 4 means Long. Default is 4. Only effective when `PacketProtocol = ppLengthHeader`.\r\n\r\n\r\n\r\n### Syntax\r\n\r\n`vb\r\nProperty Get HeaderBytes() As Long\r\nProperty Let HeaderBytes(ByVal Value As Long)\r\n`\r\n\r\n### Values\r\n\r\n| Value | Description | Max Message Length |\r\n|-------|-------------|-------------------|\r\n| 2 | 2-byte header (Unsigned Integer) | 65,535 bytes |\r\n| 4 | 4-byte header (Unsigned Long) | 2,147,483,647 bytes |\r\n\r\n### Usage Example\r\n\r\n`vb\r\n' Small messages use 2-byte header to save bandwidth\r\nm_oServer.PacketProtocol = ppLengthHeader\r\nm_oServer.HeaderBytes = 2\r\n\r\n' Large messages use 4-byte header\r\nm_oServer.HeaderBytes = 4\r\n`\r\n\r\n---\r\n\r\n## 📦 HeaderEndian Property\r\n\r\n### Description\r\n\r\nSets or gets length-header protocol byte order. Default is little-endian (`eeLittleEndian`). Only effective when `PacketProtocol = ppLengthHeader`.\r\n\r\n\r\n\r\n### Syntax\r\n\r\n`vb\r\r\nProperty Get HeaderEndian() As EndianEnum\r\nProperty Let HeaderEndian(ByVal Value As EndianEnum)\r\n`\r\n\r\n### Values\r\n\r\n| Constant | Value | Description |\r\n|----------|-------|-------------|\r\n| `eeLittleEndian` | 0 | Little-endian (default, x86/x64) |\r\n| `eeBigEndian` | 1 | Big-endian (network byte order) |\r\n\r\n### Usage Example\r\n\r\n`vb\r\n' Communicate with Java/network protocols (usually use big-endian)\r\nm_oServer.PacketProtocol = ppLengthHeader\r\nm_oServer.HeaderEndian = eeBigEndian\r\n`\r\n\r\n---\r\n\r\n## 📦 MaxPacketSize Property\r\n\r\n### Description\r\n\r\nSingle packet max byte limit. During length-header protocol parsing, if declared message length exceeds this value, error is thrown and packet discarded. Prevents malicious oversized packet declarations exhausting memory.\r\n\r\n\r\n\r\n### Syntax\r\n\r\n`vb\r\nProperty Get MaxPacketSize() As Long\r\nProperty Let MaxPacketSize(ByVal Value As Long)\r\n`\r\n\r\n### Default Value\r\n\r\n1MB (1048576 bytes)\r\n\r\n### Usage Example\r\n\r\n`vb\r\n' Adjust max packet limit\r\nm_oServer.PacketProtocol = ppLengthHeader\r\r\nm_oServer.MaxPacketSize = 524288 ' 512KB\r\n\r\n' New clients automatically inherit this configuration\r\n`\r\n\r\n### Notes\r\n\r\n- Only effective for `ppLengthHeader` protocol\r\n- Throws clear error message when exceeded\r\n- New clients automatically inherit server configuration\r\n\r\n---\r\n\r\n## 📦 MaxBufferSize Property\r\n\r\n### Description\r\n\r\nReceive buffer accumulation limit. Decode checks before merging buffer, if exceeded, error is thrown and packet discarded. Prevents large amounts of incomplete packets slowly consuming memory (e.g., attacker sending many incomplete packets).\r\n\r\n\r\n\r\n### Syntax\r\n\r\n`vb\r\nProperty Get MaxBufferSize() As Long\r\nProperty Let MaxBufferSize(ByVal Value As Long)\r\n`\r\n\r\n### Default Value\r\n\r\n4MB (4194304 bytes)\r\n\r\n### Usage Example\r\n\r\n`vb\r\n' Adjust buffer limit\r\nm_oServer.PacketProtocol = ppLengthHeader\r\nm_oServer.MaxBufferSize = 8388608 ' 8MB\r\n`\r\n\r\n### Notes\r\n\r\n- Effective for all protocol types\r\n- Throws clear error message when exceeded\r\n- New clients automatically inherit server configuration\r\n\r\n---\r\n\r\n## 💓 Heartbeat Property\r\n\r\n### Description\r\n\r\\r\nGets heartbeat manager object for advanced configuration. Heartbeat manager embeds `cTimer` auto-drive, no external timer needed.\r\n\r\n\r\n\r\n### Syntax\r\n\r\n`vb\r\nProperty Get Heartbeat() As cHeartbeat\r\n`\r\n\r\n### Usage Example\r\n\r\n`vb\r\n' Advanced configuration\r\nIf Not m_oServer.Heartbeat Is Nothing Then\r\n Debug.Print "Heartbeat sent count: " & m_oServer.Heartbeat.HeartbeatCount\r\n Debug.Print "Timer interval: " & m_oServer.Heartbeat.TimerInterval & "ms"\r\nEnd If\r\n`\r\n\r\n---\r\n\r\n## 💓 AutoHeartbeat Property\r\n\r\n### Description\r\n\r\nEnable or disable auto heartbeat. When enabled, embedded `cTimer` auto-drive, no external timer or `PollHeartbeat()` call needed.\r\n\r\n\r\n\r\n### Syntax\r\n\r\n`vb\r\nProperty Get AutoHeartbeat() As Boolean\r\nProperty Let AutoHeartbeat(ByVal Value As Boolean)\r\n`\r\n\r\n### Usage Example\r\n\r\n`vb\r\n' Server: Enable heartbeat detection\r\nm_oServer.AutoHeartbeat = True\r\nm_oServer.HeartbeatTimeout = 120 ' 2 minutes timeout\r\n\r\n' Client: Enable heartbeat keep-alive\r\nm_oClient.AutoHeartbeat = True\r\r\nm_oClient.HeartbeatInterval = 50 ' 50 seconds interval\r\n\r\n' Disable heartbeat\r\nm_oServer.AutoHeartbeat = False\r\n`\r\n\r\n---\r\n\r\n## 💓 HeartbeatTimeout Property\r\n\r\n### Description\r\n\r\nServer heartbeat timeout seconds. Client idle time exceeding this value will be auto-disconnected. Default 120 seconds (2 minutes). Only effective in server mode with `AutoHeartbeat = True`.\r\n\r\n\r\n\r\n### Syntax\r\n\r\n`vb\r\r\nProperty Get HeartbeatTimeout() As Long\r\nProperty Let HeartbeatTimeout(ByVal Value As Long)\r\n`\r\n\r\n### Usage Example\r\n\r\n`vb\r\nm_oServer.AutoHeartbeat = True\r\r\nm_oServer.HeartbeatTimeout = 180 ' 3 minutes timeout\r\n`\r\n\r\n---\r\n\r\n## 💓 HeartbeatInterval Property\r\n\r\n### Description\r\n\r\nClient heartbeat interval seconds. When idle time exceeds this value, client auto-sends heartbeat packet. Default 50 seconds. Only effective in client mode with `AutoHeartbeat = True`.\r\n\r\n\r\n\r\n### Syntax\r\n\r\n`vb\r\nProperty Get HeartbeatInterval() As Long\r\nProperty Let HeartbeatInterval(ByVal Value As Long)\r\n`\r\n\r\n### Usage Example\r\n\r\n`vb\r\nm_oClient.AutoHeartbeat = True\r\nm_oClient.HeartbeatInterval = 30 ' 30 seconds no activity then send heartbeat\r\n`\r\n\r\n---\r\n\r\n## 💓 HeartbeatData Property\r\n\r\n### Description\r\n\r\nHeartbeat packet content (byte array). Default is single byte `&H00`. Can customize heartbeat packet format based on protocol.\r\n\r\n\r\n\r\n### Syntax\r\n\r\n`vb\r\nProperty Get HeartbeatData() As Byte()\r\nProperty Let HeartbeatData(ByRef Value() As Byte)\r\n`\r\n\r\n### Usage Example\r\n\r\n`vb\r\n' Custom heartbeat packet content\r\nDim baHB(0 To 3) As Byte\r\nbaHB(0) = &HFF\r\nbaHB(1) = &H0\r\nbaHB(2) = &H0\r\nbaHB(3) = &HFF\r\nm_oClient.HeartbeatData = baHB\r\n`\r\n\r\n---\r\n\r\n## 💓 IdleSeconds Property\r\n\r\n### Description\r\n\r\nCurrent connection idle seconds (read-only). Calculated from last send/receive time. Can be used to determine connection activity level.\r\n\r\n\r\n\r\n### Syntax\r\n\r\n`vb\r\nProperty Get IdleSeconds() As Long\r\n`\r\n\r\n### Usage Example\r\n\r\n`vb\r\n' Check client activity level\r\nDim oClient As cWinsock\r\r\nFor Each oClient In m_oServer.Clients\r\n Debug.Print "Client #" & oClient.ClientId & " idle: " & oClient.IdleSeconds & " seconds"\r\nNext\r\n`\r\n\r\n---\r\n\r\n## 📌 Property Usage Scenarios Summary\r\n\r\n### Common Client Properties\r\n\r\n`vb\r\n' Set before connecting\r\nm_oClient.Protocol = sckTCPProtocol\r\nm_oClient.RemoteHost = "192.168.1.100"\r\nm_oClient.RemotePort = 8080\r\nm_oClient.Connect\r\n\r\n' Get after connecting\r\nDebug.Print "IP: " & m_oClient.RemoteHostIP\r\nDebug.Print "Port: " & m_oClient.RemotePort\r\r\nDebug.Print "State: " & m_oClient.State\r\n\r\n' Custom tags\r\nm_oClient.Tag = "Client-001"\r\r\nm_oClient.UserData = "User info"\r\n`\r\n\r\n### Common Server Properties\r\n\r\n`vb\r\n' Start server\r\nm_oServer.Protocol = sckTCPProtocol\r\nm_oServer.LocalPort = 8080\r\nm_oServer.Listen\r\n\r\n' Set packet protocol\r\nm_oServer.PacketProtocol = ppDelimiter\r\nm_oServer.Delimiter = vbCrLf\r\n\r\n' Set heartbeat\r\nm_oServer.AutoHeartbeat = True\r\nm_oServer.HeartbeatTimeout = 120\r\n\r\n' Manage clients\r\nDebug.Print "Connections: " & m_oServer.ClientCount\r\n\r\nDim oClient As cWinsock\r\r\nFor Each oClient In m_oServer.Clients\r\r\n Debug.Print "Client #" & oClient.ClientId & ": " & oClient.RemoteHostIP & " (idle " & oClient.IdleSeconds & " seconds)"\r\n oClient.SendData "Broadcast message"\r\nNext\r\n`\r\n\r\n---\r\n\r\n**Last Updated**: 2026-06-19\r\n --- --- url: /en/vbman/winsock/sync-methods.md --- # cWinsock Synchronous Methods Detailed Guide ## 📋 Table of Contents * [Overview](#overview) * [Synchronous Methods List](#synchronous-methods-list) * [Event Mask Enumeration](#event-mask-enumeration) * [Methods Detailed](#methods-detailed) * [SyncConnect](#syncconnect---synchronous-connect) * [SyncSendText](#syncsendtext---synchronous-send-text) * [SyncSendArray](#syncsendarray---synchronous-send-byte-array) * [SyncSend](#syncsend---synchronous-send-buffer) * [SyncReceiveText](#syncreceivetext---synchronous-receive-text) * [SyncReceiveArray](#syncreceivearray---synchronous-receive-byte-array) * [SyncReceive](#syncreceive---synchronous-receive-to-buffer) * [SyncWaitForEvent](#syncwaitforevent---wait-for-event) * [SyncCancelWait](#synccancelwait---cancel-wait) * [Usage Scenarios](#usage-scenarios) * [Async vs Sync](#async-vs-sync) * [Important Notes](#important-notes) * [Complete Examples](#complete-examples) *** ## Overview `cWinsock` provides a complete set of synchronous (blocking) network operation methods, allowing developers to perform network communication without using the event-driven model. Synchronous methods block the current thread until the operation completes, times out, or an error occurs. ### Core Features * ⏱️ **Timeout Control** - All synchronous operations support timeout settings * 🔄 **Message Pump Mechanism** - Processes message queue via PeekMessage/DispatchMessage, does not block UI * 🎯 **Simple API** - Functional calls, returns Boolean to indicate success/failure * 🌐 **Comprehensive Support** - Covers connection, send, receive, event waiting * 💻 **Flexible Encoding** - Supports multiple text encodings (ACP/GBK, UTF-8, Unicode) ### Applicable Scenarios * Simple client applications (e.g., HTTP client) * Network operations that need to execute sequentially * Scenarios without complex event handling * Rapid prototype development *** ## Synchronous Methods List | Method Name | Return Type | Description | |------------|-------------|-------------| | `SyncConnect` | Boolean | Synchronously connect to remote server | | `SyncSendText` | Boolean | Synchronously send string | | `SyncSendArray` | Boolean | Synchronously send byte array | | `SyncSend` | Boolean | Synchronously send buffer data | | `SyncReceiveText` | String | Synchronously receive string | | `SyncReceiveArray` | Boolean | Synchronously receive to byte array | | `SyncReceive` | Boolean | Synchronously receive to buffer | | `SyncWaitForEvent` | Boolean | Wait for specified socket event | | `SyncCancelWait` | Sub | Cancel waiting operation | *** ## Event Mask Enumeration `WinSocketEventMaskEnum` is used to specify the event types to wait for in `SyncWaitForEvent`. ### Enumeration Values | Enum Name | Value | Description | |-----------|-------|-------------| | `wskSfdRead` | 2^0 | Readable event | | `wskSfdWrite` | 2^1 | Writable event | | `wskSfdOob` | 2^2 | Out-of-band data | | `wskSfdAccept` | 2^3 | Accept connection | | `wskSfdConnect` | 2^4 | Connection completed | | `wskSfdClose` | 2^5 | Connection closed | | `wskSfdAll` | 2^6 - 1 | All events (default) | | `[_wskSfdResolve]` | 2^15 | Internal: Domain name resolution | | `[_wskSfdForceRead]` | 2^14 | Internal: Force read | ### Usage Example ```vb ' Wait for readable event If ws.SyncWaitForEvent(5000, wskSfdRead) Then Debug.Print "Socket readable" End If ' Wait for writable or readable event If ws.SyncWaitForEvent(5000, wskSfdRead Or wskSfdWrite) Then Debug.Print "Socket ready" End If ' Wait for any event If ws.SyncWaitForEvent(5000, wskSfdAll) Then Debug.Print "Event triggered" End If ``` *** ## Methods Detailed ### SyncConnect - Synchronous Connect ### Description Synchronously connect to the specified remote server with timeout control. Returns `True` on successful connection, `False` on timeout or failure. ### Syntax ```vb Public Function SyncConnect(HostAddress As String, ByVal HostPort As Long, Optional ByVal TimeOut As Long) As Boolean ``` ### Parameters | Parameter | Type | Description | |-----------|------|-------------| | `HostAddress` | String | Remote host name or IP address | | `HostPort` | Long | Remote port number | | `TimeOut` | Long (Optional) | Timeout in milliseconds, uses underlying default value if not specified | ### Return Value * `True` - Connection successful * `False` - Connection failed or timed out ### Usage Example ```vb Private Sub TestSyncConnect() Dim ws As New cWinsock Dim bResult As Boolean ' Connect to example.com port 80, timeout 5 seconds bResult = ws.SyncConnect("example.com", 80, 5000) If bResult Then Debug.Print "Connected successfully!" Debug.Print "Remote IP: " & ws.RemoteHostIP Debug.Print "Local IP: " & ws.LocalIP Debug.Print "Local Port: " & ws.LocalPort Else Debug.Print "Connection failed or timed out" End If ws.Close_ End Sub ``` ### Error Handling ```vb Private Sub TestConnectWithError() Dim ws As New cWinsock On Error GoTo EH If ws.SyncConnect("invalid-host-name-12345.com", 80, 3000) Then Debug.Print "Connected successfully" Else Debug.Print "Connection failed" End If Exit Sub EH: Debug.Print "Connection error: " & Err.Description & " (Error number: " & Err.Number & ")" ws.Close_ End Sub ``` *** ### SyncSendText - Synchronous Send Text ### Description Synchronously send string data with timeout control. ### Syntax ```vb Public Function SyncSendText( _ Text As String, _ Optional ByVal TimeOut As Long, _ Optional HostAddress As String, _ Optional ByVal HostPort As Long, _ Optional ByVal CodePage As EnumScpCodePage = wcpUtf8) As Boolean ``` ### Parameters | Parameter | Type | Description | |-----------|------|-------------| | `Text` | String | Text to send | | `TimeOut` | Long (Optional) | Timeout in milliseconds | | `HostAddress` | String (Optional) | Target host address (for UDP server mode) | | `HostPort` | Long (Optional) | Target port (for UDP server mode) | | `CodePage` | EnumScpCodePage (Optional) | Text encoding, default `wcpUtf8` | ### Return Value * `True` - Send successful * `False` - Send failed or timed out ### Usage Example ```vb Private Sub TestSyncSendText() Dim ws As New cWinsock ' Connect If ws.SyncConnect("example.com", 80, 5000) Then ' Send HTTP request Dim sRequest As String sRequest = "GET / HTTP/1.1" & vbCrLf & _ "Host: example.com" & vbCrLf & vbCrLf If ws.SyncSendText(sRequest, 5000, , , wcpUtf8) Then Debug.Print "Send successful" Else Debug.Print "Send failed" End If End If ws.Close_ End Sub ``` ### Using Different Encodings ```vb ' Use GBK encoding (default) ws.SyncSendText "中文测试", 5000, , , wcpAcp ' Use UTF-8 encoding (recommended) ws.SyncSendText "中文测试", 5000, , , wcpUtf8 ' Use Unicode (no conversion) ws.SyncSendText "中文测试", 5000, , , wcpUnicode ``` *** ### SyncSendArray - Synchronous Send Byte Array ### Description Synchronously send byte array data with timeout control. ### Syntax ```vb Public Function SyncSendArray( _ Buffer() As Byte, _ Optional ByVal TimeOut As Long, _ Optional HostAddress As String, _ Optional ByVal HostPort As Long, _ Optional ByVal Flags As Long = 0) As Boolean ``` ### Parameters | Parameter | Type | Description | |-----------|------|-------------| | `Buffer` | Byte() | Byte array to send | | `TimeOut` | Long (Optional) | Timeout in milliseconds | | `HostAddress` | String (Optional) | Target host address | | `HostPort` | Long (Optional) | Target port | | `Flags` | Long (Optional) | Send flags | ### Return Value * `True` - Send successful * `False` - Send failed or timed out ### Usage Example ```vb Private Sub TestSyncSendArray() Dim ws As New cWinsock Dim baData() As Byte ' Prepare data baData = StrConv("Hello World", vbFromUnicode) ' Connect and send If ws.SyncConnect("127.0.0.1", 8080, 5000) Then If ws.SyncSendArray(baData, 5000) Then Debug.Print "Byte array sent successfully" End If End If ws.Close_ End Sub ``` *** ### SyncSend - Synchronous Send Buffer ### Description Synchronously send data from a specified buffer pointer, for high-performance scenarios. ### Syntax ```vb Public Function SyncSend( _ ByVal BufPtr As Long, _ ByVal BufLen As Long, _ Optional ByVal TimeOut As Long, _ Optional HostAddress As String, _ Optional ByVal HostPort As Long, _ Optional ByVal Flags As Long = 0) As Boolean ``` ### Parameters | Parameter | Type | Description | |-----------|------|-------------| | `BufPtr` | Long | Buffer pointer | | `BufLen` | Long | Buffer length | | `TimeOut` | Long (Optional) | Timeout in milliseconds | | `HostAddress` | String (Optional) | Target host address | | `HostPort` | Long (Optional) | Target port | | `Flags` | Long (Optional) | Send flags | ### Return Value * `True` - Send successful * `False` - Send failed or timed out ### Usage Example ```vb ' Note: This method requires memory pointer operations, usually for advanced scenarios Private Sub TestSyncSend() Dim ws As New cWinsock Dim sData As String Dim lPtr As Long sData = "Hello World" ' Get string pointer (using StrPtr) lPtr = StrPtr(sData) If ws.SyncConnect("127.0.0.1", 8080, 5000) Then If ws.SyncSend(lPtr, LenB(sData), 5000) Then Debug.Print "Send successful" End If End If ws.Close_ End Sub ``` *** ### SyncReceiveText - Synchronous Receive Text ### Description Synchronously receive text data with timeout control. Can specify the minimum number of bytes to receive. ### Syntax ```vb Public Function SyncReceiveText( _ Optional ByVal NeedLen As Long = 1, _ Optional ByVal TimeOut As Long, _ Optional HostAddress As String, _ Optional HostPort As Long, _ Optional ByVal CodePage As EnumScpCodePage = wcpUtf8) As String ``` ### Parameters | Parameter | Type | Description | |-----------|------|-------------| | `NeedLen` | Long (Optional) | Minimum bytes to receive, default 1 | | `TimeOut` | Long (Optional) | Timeout in milliseconds | | `HostAddress` | String (Optional) | Source host address (for UDP mode) | | `HostPort` | Long (Optional) | Source port (for UDP mode) | | `CodePage` | EnumScpCodePage (Optional) | Text encoding, default `wcpUtf8` | ### Return Value * Success: Returns received text * Failure: Returns empty string ### Usage Example ```vb Private Sub TestSyncReceiveText() Dim ws As New cWinsock Dim sResponse As String ' Connect If ws.SyncConnect("example.com", 80, 5000) Then ' Send request Dim sRequest As String sRequest = "GET / HTTP/1.1" & vbCrLf & _ "Host: example.com" & vbCrLf & vbCrLf If ws.SyncSendText(sRequest, 5000, , , wcpUtf8) Then ' Receive response (at least 100 bytes, timeout 5 seconds) sResponse = ws.SyncReceiveText(100, 5000, , , wcpUtf8) If Len(sResponse) > 0 Then Debug.Print "Response received:" Debug.Print sResponse Debug.Print "Length: " & Len(sResponse) & " characters" Else Debug.Print "Receive failed or timed out" End If End If End If ws.Close_ End Sub ``` ### Read Fixed Length ```vb ' Read first 100 bytes Dim sHeader As String sHeader = ws.SyncReceiveText(100, 3000, , , wcpUtf8) Debug.Print "Header: " & sHeader ``` *** ### SyncReceiveArray - Synchronous Receive Byte Array ### Description Synchronously receive byte array data with timeout control. ### Syntax ```vb Public Function SyncReceiveArray( _ Buffer() As Byte, _ Optional ByVal NeedLen As Long, _ Optional ByVal TimeOut As Long, _ Optional HostAddress As String, _ Optional ByVal HostPort As Long, _ Optional ByVal Flags As Long = 0) As Boolean ``` ### Parameters | Parameter | Type | Description | |-----------|------|-------------| | `Buffer` | Byte() | Byte array to receive data | | `NeedLen` | Long (Optional) | Minimum bytes to receive | | `TimeOut` | Long (Optional) | Timeout in milliseconds | | `HostAddress` | String (Optional) | Source host address | | `HostPort` | Long (Optional) | Source port | | `Flags` | Long (Optional) | Receive flags | ### Return Value * `True` - Receive successful * `False` - Receive failed or timed out ### Usage Example ```vb Private Sub TestSyncReceiveArray() Dim ws As New cWinsock Dim baBuffer() As Byte ' Connect If ws.SyncConnect("127.0.0.1", 8080, 5000) Then ' Send request If ws.SyncSendText("GET_DATA", 5000, , , wcpUtf8) Then ' Receive response (max 8192 bytes) ReDim baBuffer(0 To 8191) As Byte If ws.SyncReceiveArray(baBuffer, 1, 5000) Then ' Get actual received length Dim lReceived As Long lReceived = UBound(baBuffer) + 1 Debug.Print "Received " & lReceived & " bytes" Else Debug.Print "Receive failed or timed out" End If End If End If ws.Close_ End Sub ``` *** ### SyncReceive - Synchronous Receive to Buffer ### Description Synchronously receive data from socket to a specified buffer pointer, for high-performance scenarios. ### Syntax ```vb Public Function SyncReceive( _ ByVal BufPtr As Long, _ ByVal BufLen As Long, _ ByRef Received As Long, _ Optional ByVal TimeOut As Long, _ Optional HostAddress As String, _ Optional ByVal HostPort As Long, _ Optional ByVal Flags As Long = 0) As Boolean ``` ### Parameters | Parameter | Type | Description | |-----------|------|-------------| | `BufPtr` | Long | Buffer pointer | | `BufLen` | Long | Buffer length | | `Received` | Long (ByRef) | Actual bytes received | | `TimeOut` | Long (Optional) | Timeout in milliseconds | | `HostAddress` | String (Optional) | Source host address | | `HostPort` | Long (Optional) | Source port | | `Flags` | Long (Optional) | Receive flags | ### Return Value * `True` - Receive successful, `Received` contains actual bytes received * `False` - Receive failed or timed out ### Usage Example ```vb Private Sub TestSyncReceive() Dim ws As New cWinsock Dim baBuffer() As Byte Dim lReceived As Long ' Prepare buffer ReDim baBuffer(0 To 8191) As Byte ' Connect If ws.SyncConnect("127.0.0.1", 8080, 5000) Then ' Send request If ws.SyncSendText("GET_DATA", 5000, , , wcpUtf8) Then ' Receive response If ws.SyncReceive(VarPtr(baBuffer(0)), 8192, lReceived, 5000) Then Debug.Print "Actually received: " & lReceived & " bytes" ' Only use actually received portion If lReceived > 0 Then ReDim Preserve baBuffer(0 To lReceived - 1) End If Else Debug.Print "Receive failed or timed out" End If End If End If ws.Close_ End Sub ``` *** ### SyncWaitForEvent - Wait for Event ### Description Wait for specified socket event to occur with timeout control. Can be used to poll for specific events or implement custom protocols. ### Syntax ```vb Public Function SyncWaitForEvent( _ ByVal TimeOut As Long, _ Optional ByVal EventMask As WinSocketEventMaskEnum = wskSfdAll) As Boolean ``` ### Parameters | Parameter | Type | Description | |-----------|------|-------------| | `TimeOut` | Long | Timeout in milliseconds | | `EventMask` | WinSocketEventMaskEnum (Optional) | Event mask, default `wskSfdAll` | ### Return Value * `True` - Specified event occurred * `False` - Timeout or error ### Usage Example ```vb Private Sub TestWaitForEvent() Dim ws As New cWinsock ' Connect If ws.SyncConnect("example.com", 80, 5000) Then ' Wait for writable event (indicates socket ready to send data) If ws.SyncWaitForEvent(5000, wskSfdWrite) Then Debug.Print "Socket writable, can send data" ' Send data ws.SyncSendText "Hello", 5000, , , wcpUtf8 End If ' Wait for readable event (indicates data available to read) If ws.SyncWaitForEvent(5000, wskSfdRead) Then Debug.Print "Socket readable, can receive data" Dim sData As String sData = ws.SyncReceiveText(1, 5000, , , wcpUtf8) Debug.Print "Received: " & sData End If End If ws.Close_ End Sub ``` ### Wait for Multiple Events ```vb ' Wait for readable or writable event Dim lMask As Long lMask = wskSfdRead Or wskSfdWrite If ws.SyncWaitForEvent(5000, lMask) Then ' Check BytesReceived to determine which event If ws.BytesReceived > 0 Then Debug.Print "Data available to read" Else Debug.Print "Socket writable" End If End If ``` *** ### SyncCancelWait - Cancel Wait ### Description Cancel the currently running synchronous wait operation (such as `SyncWaitForEvent`, `SyncReceiveText`, etc.). ### Syntax ```vb Public Sub SyncCancelWait() ``` ### Usage Scenarios * Cancel ongoing network operations when form closes * Interrupt wait when user cancels operation * Notify stop in multi-threaded scenarios ### Usage Example ```vb Private WithEvents m_oWinsock As cWinsock Private m_bCancelled As Boolean Private Sub cmdStart_Click() Set m_oWinsock = New cWinsock If m_oWinsock.SyncConnect("example.com", 80, 5000) Then ' Start waiting for data Dim sData As String m_bCancelled = False Do ' Check if cancelled If m_bCancelled Then Debug.Print "User cancelled operation" m_oWinsock.SyncCancelWait Exit Do End If ' Receive data sData = m_oWinsock.SyncReceiveText(1, 1000, , , wcpUtf8) If Len(sData) > 0 Then Debug.Print "Received: " & sData Else Debug.Print "Timeout, continuing to wait..." End If DoEvents ' Allow UI to respond Loop Until False End If m_oWinsock.Close_ End Sub Private Sub cmdCancel_Click() m_bCancelled = True End Sub Private Sub Form_Unload(Cancel As Integer) ' Cancel wait when form closes If Not m_oWinsock Is Nothing Then m_oWinsock.SyncCancelWait m_oWinsock.Close_ End If End Sub ``` *** ## Usage Scenarios ### Scenario 1: HTTP Client ```vb Private Function HttpGet(ByVal sUrl As String, ByVal sPath As String) As String Dim ws As New cWinsock Dim sHost As String Dim nPort As Long Dim sRequest As String Dim sResponse As String ' Parse URL (simplified) sHost = ExtractHost(sUrl) nPort = ExtractPort(sUrl, 80) ' Connect If Not ws.SyncConnect(sHost, nPort, 5000) Then HttpGet = "Connection failed" Exit Function End If ' Build request sRequest = "GET " & sPath & " HTTP/1.1" & vbCrLf & _ "Host: " & sHost & vbCrLf & _ "Connection: close" & vbCrLf & vbCrLf ' Send request If Not ws.SyncSendText(sRequest, 5000, , , wcpUtf8) Then HttpGet = "Send failed" ws.Close_ Exit Function End If ' Receive response sResponse = ws.SyncReceiveText(1, 5000, , , wcpUtf8) ws.Close_ HttpGet = sResponse End Function ' Usage Dim sHtml As String sHtml = HttpGet("http://example.com", "/") Debug.Print sHtml ``` ### Scenario 2: Echo Client ```vb Private Sub EchoClient() Dim ws As New cWinsock ' Connect to Echo server If ws.SyncConnect("127.0.0.1", 7, 5000) Then Debug.Print "Connected to Echo server" ' Send message Dim sMessage As String sMessage = "Hello, Echo Server!" If ws.SyncSendText(sMessage, 5000, , , wcpUtf8) Then Debug.Print "Sent: " & sMessage ' Receive echo Dim sReply As String sReply = ws.SyncReceiveText(Len(sMessage), 5000, , , wcpUtf8) Debug.Print "Received: " & sReply End If End If ws.Close_ End Sub ``` ### Scenario 3: File Upload (Simplified) ```vb Private Sub UploadFile(ByVal sFilePath As String, ByVal sServer As String, ByVal nPort As Long) Dim ws As New cWinsock Dim baBuffer() As Byte Dim nFileNum As Integer Dim lFileSize As Long Dim lOffset As Long Dim lChunkSize As Long ' Connect to server If Not ws.SyncConnect(sServer, nPort, 5000) Then Debug.Print "Connection failed" Exit Sub End If ' Open file nFileNum = FreeFile Open sFilePath For Binary As #nFileNum lFileSize = LOF(nFileNum) ' Send file header Dim sHeader As String sHeader = "UPLOAD:" & CStr(lFileSize) & vbCrLf ws.SyncSendText sHeader, 5000, , , wcpUtf8 ' Send in chunks lChunkSize = 8192 ' 8KB per chunk lOffset = 1 Do While lOffset <= lFileSize ReDim baBuffer(0 To lChunkSize - 1) As Byte Get #nFileNum, lOffset, baBuffer ' Adjust last chunk size If lOffset + lChunkSize > lFileSize + 1 Then ReDim Preserve baBuffer(0 To lFileSize + 1 - lOffset) As Byte End If ' Send chunk If Not ws.SyncSendArray(baBuffer, 5000) Then Debug.Print "Send failed at offset: " & lOffset Exit Do End If lOffset = lOffset + lChunkSize ' Update progress Debug.Print "Sent: " & Format((lOffset - 1) / lFileSize * 100, "0.00") & "%" DoEvents Loop Close #nFileNum ws.Close_ Debug.Print "Upload complete" End Sub ``` *** ## Async vs Sync ### Async Event-Driven Mode **Advantages:** * ✅ Does not block UI thread * ✅ Suitable for high-concurrency scenarios * ✅ Timely response * ✅ Can handle multiple clients **Disadvantages:** * ❌ Code scattered across multiple events * ❌ Logic flow not intuitive * ❌ Need to maintain state variables ```vb ' Async mode Private WithEvents ws As cWinsock Private m_bWaiting As Boolean Private m_sResponse As String Private Sub cmdConnect_Click() Set ws = New cWinsock ws.Connect "example.com", 80 m_bWaiting = True Do While m_bWaiting DoEvents Loop End Sub Private Sub ws_Connect(Client As cWinsock) Client.SendData "GET / HTTP/1.1" & vbCrLf End Sub Private Sub ws_DataArrival(Client As cWinsock, ByVal bytesTotal As Long) Client.GetData m_sResponse m_bWaiting = False End Sub ``` ### Sync Blocking Mode **Advantages:** * ✅ Linear code, clear logic * ✅ Easy to understand and debug * ✅ Suitable for simple sequential operations * ✅ No need to maintain state variables **Disadvantages:** * ❌ Blocks current execution flow * ❌ Not suitable for high concurrency * ❌ Need to manually call DoEvents to maintain UI responsiveness ```vb ' Sync mode Private Sub cmdConnect_Click() Dim ws As New cWinsock ' Connect If ws.SyncConnect("example.com", 80, 5000) Then ' Send If ws.SyncSendText("GET / HTTP/1.1" & vbCrLf, 5000, , , wcpUtf8) Then ' Receive Dim sResponse As String sResponse = ws.SyncReceiveText(1, 5000, , , wcpUtf8) Debug.Print sResponse End If End If ws.Close_ End Sub ``` ### Selection Recommendations | Scenario | Recommended Mode | Reason | |----------|-----------------|--------| | Simple HTTP client | Sync | Sequential operations, simple logic | | TCP server | Async | Need to handle multiple clients | | High-concurrency applications | Async | Avoid blocking | | Rapid prototyping | Sync | Fast development | | File transfer | Sync | Simple request-response | | Real-time communication | Async | Timely response | *** ## Important Notes ### ⚠️ Important Considerations 1. **Message Pump Mechanism** * Synchronous methods use `PeekMessage`/`DispatchMessage` internally to process message queue * **Does not block UI message loop**, forms can still respond * No need to manually call `DoEvents` 2. **Timeout Settings** * Recommend setting reasonable timeout for all synchronous operations * Adjust timeout based on network environment (recommend 3-30 seconds) * Automatically returns failure status on timeout 3. **Error Handling** * All synchronous methods should be used with `On Error` * Check return value to determine if operation was successful * Use `GetErrorDescription` to get error description 4. **Resource Cleanup** * Be sure to call `Close_` after operations complete * Cancel ongoing wait operations when form unloads * Use `SyncCancelWait` to interrupt long waits 5. **Encoding Issues** * Default encoding is `wcpUtf8` * Ensure send and receive use the same encoding * Clearly specify encoding protocol when communicating with other systems 6. **State Checking** * Ensure socket is connected before calling synchronous methods * Use `State` property to check connection status * Use `BytesReceived` to check available data ### ⚠️ Performance Considerations 1. **Avoid Frequent Small Data Sends** * Merge small data blocks together * Use buffer for batch processing 2. **Set Reasonable Timeout** * Too short timeout may cause false judgments * Too long timeout reduces response speed 3. **Memory Management** * Release large byte arrays promptly * Avoid repeated memory allocation in loops ### ⚠️ Thread Safety * Synchronous methods are **NOT** supported in multi-threaded scenarios * All operations should be executed in the main thread * Do not call synchronous methods in background threads *** ## Complete Examples ### Complete HTTP Client Example ```vb ' Form1.frm Option Explicit Private WithEvents m_oWinsock As cWinsock Private m_bCancelled As Boolean Private Sub cmdGet_Click() Dim sUrl As String Dim sHost As String Dim nPort As Long Dim sPath As String Dim sRequest As String Dim sResponse As String ' Get URL sUrl = txtUrl.Text ' Parse URL ParseUrl sUrl, sHost, nPort, sPath If Len(sHost) = 0 Then MsgBox "Invalid URL", vbExclamation Exit Sub End If ' Create socket Set m_oWinsock = New cWinsock m_bCancelled = False ' Disable buttons cmdGet.Enabled = False cmdCancel.Enabled = True ' Connect If Not m_oWinsock.SyncConnect(sHost, nPort, 5000) Then MsgBox "Connection failed: " & m_oWinsock.GetErrorDescription(Err.LastDllError), vbExclamation ResetUI Exit Sub End If Debug.Print "Connected to " & sHost & ":" & nPort ' Check cancel If m_bCancelled Then ResetUI Exit Sub End If ' Build request sRequest = "GET " & sPath & " HTTP/1.1" & vbCrLf & _ "Host: " & sHost & vbCrLf & _ "User-Agent: cWinsock/1.0" & vbCrLf & _ "Connection: close" & vbCrLf & vbCrLf ' Send request If Not m_oWinsock.SyncSendText(sRequest, 5000, , , wcpUtf8) Then MsgBox "Send failed", vbExclamation ResetUI Exit Sub End If Debug.Print "Request sent" ' Check cancel If m_bCancelled Then ResetUI Exit Sub End If ' Receive response sResponse = m_oWinsock.SyncReceiveText(1, 10000, , , wcpUtf8) If Len(sResponse) > 0 Then Debug.Print "Response received, length: " & Len(sResponse) txtResponse.Text = sResponse Else MsgBox "Receive timeout or failed", vbExclamation End If ' Cleanup ResetUI End Sub Private Sub cmdCancel_Click() m_bCancelled = True If Not m_oWinsock Is Nothing Then m_oWinsock.SyncCancelWait End If End Sub Private Sub Form_Unload(Cancel As Integer) If Not m_oWinsock Is Nothing Then m_oWinsock.SyncCancelWait m_oWinsock.Close_ Set m_oWinsock = Nothing End If End Sub Private Sub ResetUI() If Not m_oWinsock Is Nothing Then m_oWinsock.Close_ Set m_oWinsock = Nothing End If cmdGet.Enabled = True cmdCancel.Enabled = False End Sub Private Sub ParseUrl(ByVal sUrl As String, ByRef sHost As String, ByRef nPort As Long, ByRef sPath As String) Dim sTemp As String Dim nPos As Long Dim nPortPos As Long Dim nPathPos As Long ' Remove protocol prefix If InStr(1, sUrl, "://") > 0 Then sUrl = Mid$(sUrl, InStr(sUrl, "://") + 3) End If ' Find path start position nPathPos = InStr(1, sUrl, "/") If nPathPos = 0 Then nPathPos = Len(sUrl) + 1 End If ' Extract host and port sTemp = Left$(sUrl, nPathPos - 1) ' Find port nPortPos = InStr(1, sTemp, ":") If nPortPos > 0 Then sHost = Left$(sTemp, nPortPos - 1) nPort = Val(Mid$(sTemp, nPortPos + 1)) Else sHost = sTemp nPort = 80 End If ' Extract path sPath = Mid$(sUrl, nPathPos) If Len(sPath) = 0 Then sPath = "/" End If End Sub ``` ### Simple Chat Client Example ```vb Private WithEvents m_oWinsock As cWinsock Private Sub cmdConnect_Click() Set m_oWinsock = New cWinsock If m_oWinsock.SyncConnect(txtServer.Text, Val(txtPort.Text), 5000) Then Debug.Print "Connected to server" txtSend.Enabled = True cmdConnect.Enabled = False cmdDisconnect.Enabled = True Else MsgBox "Connection failed", vbExclamation End If End Sub Private Sub cmdDisconnect_Click() If Not m_oWinsock Is Nothing Then m_oWinsock.SyncCancelWait m_oWinsock.Close_ Set m_oWinsock = Nothing End If txtSend.Enabled = False cmdConnect.Enabled = True cmdDisconnect.Enabled = False End Sub Private Sub cmdSend_Click() If m_oWinsock Is Nothing Then Exit Sub Dim sMessage As String sMessage = "[" & txtNick.Text & "]: " & txtSend.Text If m_oWinsock.SyncSendText(sMessage, 5000, , , wcpUtf8) Then txtReceive.Text = txtReceive.Text & sMessage & vbCrLf txtSend.Text = "" Else MsgBox "Send failed", vbExclamation End If End Sub Private Sub tmrReceive_Timer() If m_oWinsock Is Nothing Or m_oWinsock.State <> sckConnected Then Exit Sub ' Check if data available If m_oWinsock.BytesReceived > 0 Then Dim sData As String sData = m_oWinsock.SyncReceiveText(1, 100, , , wcpUtf8) If Len(sData) > 0 Then txtReceive.Text = txtReceive.Text & sData & vbCrLf txtReceive.SelStart = Len(txtReceive.Text) End If End If End Sub ``` *** ## Summary The synchronous methods of `cWinsock` provide a simple, intuitive way of network programming, especially suitable for: * 🎯 **Simple Client Applications** - HTTP, Echo, Chat, etc. * 📚 **Learning Network Programming** - Linear code is easy to understand * ⚡ **Rapid Prototyping** - Quickly validate ideas * 🔄 **Sequential Operations** - Tasks that need to be executed step by step For more complex servers or high-concurrency scenarios, it is recommended to use the asynchronous event-driven mode. *** **Last Updated**: 2026-01-26 --- --- url: /zh/vbman/winsock/tcp.md --- # cWinsock TCP 编程指南 ## 📖 目录 * [概述](#概述) * [TCP 客户端编程](#tcp-客户端编程) * [TCP 服务器编程](#tcp-服务器编程) * [高级功能](#高级功能) * [常见问题](#常见问题) *** ## 概述 TCP（Transmission Control Protocol）是一种面向连接的、可靠的传输协议，适合需要保证数据完整性和顺序的应用场景。 ### TCP 特点 * ✅ **面向连接**: 需要先建立连接 * ✅ **可靠传输**: 保证数据到达、顺序和完整性 * ✅ **流量控制**: 避免网络拥塞 * ✅ **拥塞控制**: 自动调整传输速率 * ❌ **开销较大**: 相比 UDP 有更多协议开销 ### 适用场景 * 文件传输 * 聊天应用 * 远程控制 * 数据库连接 * Web 服务 *** ## TCP 客户端编程 ### 基本流程 ``` 1. 创建 cWinsock 对象 2. 设置协议为 TCP 3. 连接到服务器 4. 等待 Connect 事件 5. 发送/接收数据 6. 关闭连接 ``` ### 完整示例 ```vb ' 声明客户端对象 Private WithEvents m_oClient As cWinsock ' 连接按钮 Private Sub cmdConnect_Click() On Error GoTo EH If m_oClient Is Nothing Then Set m_oClient = New cWinsock End If ' 设置协议 m_oClient.Protocol = sckTCPProtocol ' 连接服务器 m_oClient.Connect txtHost.Text, CLng(txtPort.Text) ' 更新 UI cmdConnect.Enabled = False cmdDisconnect.Enabled = False lblStatus.Caption = "连接中..." Exit Sub EH: Debug.Print "连接错误: " & Err.Description lblStatus.Caption = "连接失败" End Sub ' 连接成功事件 Private Sub m_oClient_Connect(Client As cWinsock) Debug.Print "已连接到 " & Client.RemoteHostIP & ":" & Client.RemotePort ' 更新 UI cmdConnect.Enabled = False cmdDisconnect.Enabled = True lblStatus.Caption = "已连接" End Sub ' 断开连接按钮 Private Sub cmdDisconnect_Click() If Not m_oClient Is Nothing Then m_oClient.Close_ End If ' 更新 UI cmdConnect.Enabled = True cmdDisconnect.Enabled = False lblStatus.Caption = "已断开" End Sub ' 发送数据按钮 Private Sub cmdSend_Click() On Error GoTo EH If Not m_oClient Is Nothing And m_oClient.State = sckConnected Then m_oClient.SendData txtSend.Text Debug.Print "已发送: " & txtSend.Text ' 清空输入框 txtSend.Text = "" Else MsgBox "未连接", vbExclamation End If Exit Sub EH: Debug.Print "发送错误: " & Err.Description End Sub ' 数据到达事件 Private Sub m_oClient_DataArrival(Client As cWinsock, ByVal bytesTotal As Long) Dim sData As String ' 接收数据 Client.GetData sData Debug.Print "收到数据 (" & bytesTotal & " 字节): " & sData ' 显示在界面上 txtReceive.SelStart = Len(txtReceive.Text) txtReceive.SelText = sData & vbCrLf txtReceive.SelStart = Len(txtReceive.Text) End Sub ' 连接关闭事件 Private Sub m_oClient_CloseEvent(Client As cWinsock) Debug.Print "连接已关闭" ' 更新 UI cmdConnect.Enabled = True cmdDisconnect.Enabled = False lblStatus.Caption = "连接已关闭" End Sub ' 错误事件 Private Sub m_oClient_Error(Client As cWinsock, ByVal Number As Long, Description As String, ByVal Scode As Long) Debug.Print "错误 [" & Number & "]: " & Description ' 更新 UI lblStatus.Caption = "错误: " & Description End Sub ' 窗体卸载 Private Sub Form_Unload(Cancel As Integer) On Error Resume Next m_oClient.Close_ End Sub ``` *** ## TCP 服务器编程 ### 基本流程 ``` 1. 创建 cWinsock 对象 2. 设置协议为 TCP 3. 监听端口 4. 等待 ConnectionRequest 事件 5. 接受或拒绝连接 6. 通过 DataArrival 处理客户端数据 7. 客户端断开时清理 ``` ### 完整示例 ```vb ' 声明服务器对象 Private WithEvents m_oServer As cWinsock ' 启动服务器按钮 Private Sub cmdStart_Click() On Error GoTo EH If m_oServer Is Nothing Then Set m_oServer = New cWinsock End If ' 设置协议 m_oServer.Protocol = sckTCPProtocol ' 开始监听 m_oServer.Listen CLng(txtPort.Text) Debug.Print "服务器已启动，监听端口: " & m_oServer.LocalPort ' 更新 UI cmdStart.Enabled = False cmdStop.Enabled = True lblStatus.Caption = "监听中..." lblClientCount.Caption = "0" Exit Sub EH: Debug.Print "启动服务器失败: " & Err.Description MsgBox "无法启动服务器: " & Err.Description, vbExclamation End Sub ' 停止服务器按钮 Private Sub cmdStop_Click() On Error Resume Next If Not m_oServer Is Nothing Then m_oServer.Close_ End If Debug.Print "服务器已停止" ' 更新 UI cmdStart.Enabled = True cmdStop.Enabled = False lblStatus.Caption = "已停止" lstClients.Clear End Sub ' 新连接请求事件 Private Sub m_oServer_ConnectionRequest(Client As cWinsock, ByRef DisConnect As Boolean) Debug.Print "新客户端连接: " & Client.RemoteHostIP & ":" & Client.RemotePort ' 检查连接数限制 If m_oServer.ClientCount >= 100 Then Debug.Print "达到最大连接数，拒绝连接" DisConnect = True Exit Sub End If ' IP 黑名单检查 If IsInBlacklist(Client.RemoteHostIP) Then Debug.Print "IP 在黑名单中，拒绝连接: " & Client.RemoteHostIP DisConnect = True Exit Sub End If ' 接受连接（DisConnect = False） Debug.Print "接受连接: Client #" & Client.ClientId ' 更新客户端列表 UpdateClientList End Sub ' 数据到达事件（所有客户端数据通过此事件触发） Private Sub m_oServer_DataArrival(Client As cWinsock, ByVal bytesTotal As Long) Dim sData As String ' 接收数据 Client.GetData sData Debug.Print "来自 " & Client.RemoteHostIP & " 的数据: " & sData ' 显示在日志中 LogMessage "Client #" & Client.ClientId & ": " & sData ' 回显给客户端 Client.SendData "Echo: " & sData End Sub ' 连接关闭事件 Private Sub m_oServer_CloseEvent(Client As cWinsock) Debug.Print "客户端 " & Client.ClientId & " 已断开" ' 更新客户端列表 UpdateClientList End Sub ' 错误事件 Private Sub m_oServer_Error(Client As cWinsock, ByVal Number As Long, Description As String, ByVal Scode As Long) Debug.Print "错误 [" & Number & "]: " & Description If Client.IsServer Then ' 服务器错误 LogMessage "服务器错误: " & Description Else ' 客户端错误 LogMessage "客户端 " & Client.ClientId & " 错误: " & Description End If End Sub ' 更新客户端列表 Private Sub UpdateClientList() lstClients.Clear lblClientCount.Caption = m_oServer.ClientCount Dim oClient As cWinsock For Each oClient In m_oServer.Clients lstClients.AddItem "Client #" & oClient.ClientId & " - " & oClient.RemoteHostIP & ":" & oClient.RemotePort Next End Sub ' 添加日志 Private Sub LogMessage(ByVal sMsg As String) txtLog.SelStart = Len(txtLog.Text) txtLog.SelText = Format$(Now, "hh:mm:ss") & " - " & sMsg & vbCrLf txtLog.SelStart = Len(txtLog.Text) End Sub ' 窗体卸载 Private Sub Form_Unload(Cancel As Integer) On Error Resume Next m_oServer.Close_ End Sub ' 黑名单检查 Private Function IsInBlacklist(ByVal sIP As String) As Boolean ' 从配置文件或数据库加载黑名单 ' 这里简化演示 IsInBlacklist = False End Function ``` *** ## 高级功能 ### 🔄 心跳检测 cWinsock 内置心跳管理器，内嵌 `cTimer` 自动驱动，无需手动实现。 **服务端：超时检测** ```vb ' 启动服务器时配置心跳 m_oServer.AutoHeartbeat = True m_oServer.HeartbeatTimeout = 120 ' 2分钟无活动则超时 ' 超时事件 Private Sub m_oServer_ClientTimeout(Client As cWinsock) Debug.Print "客户端 " & Client.ClientId & " 超时，已自动断开" UpdateClientList End Sub ``` **客户端：心跳保活** ```vb ' 连接后启用心跳 m_oClient.AutoHeartbeat = True m_oClient.HeartbeatInterval = 50 ' 50秒无活动则发心跳 ' 心跳事件 Private Sub m_oClient_HeartbeatSent(Client As cWinsock) Debug.Print "心跳已发送，空闲: " & Client.IdleSeconds & "秒" End Sub ``` **自定义心跳包** ```vb ' 默认心跳包为单字节 &H00，可自定义 Dim baHB(0 To 3) As Byte baHB(0) = &H50 ' P baHB(1) = &H49 ' I baHB(2) = &H4E ' N baHB(3) = &H47 ' G m_oClient.HeartbeatData = baHB ``` **工作原理**： * 心跳管理器内嵌 `cTimer`，每 10 秒触发一次检查 * 服务端：检查所有客户端的 `IdleSeconds`，超时则触发 `ClientTimeout` 并自动断开 * 客户端：如果空闲超过 `HeartbeatInterval` 则发送心跳包，有数据收发时智能跳过 * 每次收发数据自动重置 `LastActivityTime` *** ### 📦 数据封包协议 cWinsock 内置三种封包协议，自动处理 TCP 分包/粘包问题。 **分隔符协议**（适合文本协议） ```vb m_oServer.PacketProtocol = ppDelimiter m_oServer.Delimiter = vbCrLf ' 换行分隔，适合行式协议 ' 发送自动追加分隔符 Client.SendData "Hello" ' 实际发送: "Hello" + vbCrLf ' 接收自动解包 Private Sub m_oServer_MessageArrival(Client As cWinsock, ByVal bytesTotal As Long) Debug.Print "完整消息: " & Client.GetDataText() End Sub ``` **定长协议**（适合固定长度消息） ```vb m_oServer.PacketProtocol = ppFixedLength m_oServer.FixedLength = 256 ' 每条消息固定256字节 ``` **长度头协议**（适合二进制协议） ```vb m_oServer.PacketProtocol = ppLengthHeader m_oServer.HeaderBytes = 4 ' 4字节长度头 m_oServer.HeaderEndian = eeLittleEndian ' 小端序 ' 发送自动添加长度头 Client.SendData "Hello" ' 实际发送: [4字节长度] + "Hello" ' 接收自动剥离长度头 Private Sub m_oServer_MessageArrival(Client As cWinsock, ByVal bytesTotal As Long) Dim baData() As Byte baData = Client.GetDataByteArray() ProcessBinaryMessage baData End Sub ``` **配置继承**：新客户端自动继承服务器的协议和心跳配置，每个客户端持有独立实例，缓冲区互不干扰。 *** ### 🔄 自动重连 ```vb ' 自动重连客户端 Private WithEvents m_oClient As cWinsock Private m_bAutoReconnect As Boolean Private m_lReconnectInterval As Long Private Sub StartClient() Set m_oClient = New cWinsock m_oClient.Protocol = sckTCPProtocol m_bAutoReconnect = True m_lReconnectInterval = 5 ' 5 秒 ConnectToServer End Sub Private Sub ConnectToServer() On Error GoTo EH m_oClient.Connect "127.0.0.1", 8080 Debug.Print "正在连接..." Exit Sub EH: Debug.Print "连接失败: " & Err.Description If m_bAutoReconnect Then Debug.Print m_lReconnectInterval & " 秒后重连..." tmrReconnect.Interval = m_lReconnectInterval * 1000 tmrReconnect.Enabled = True End If End Sub Private Sub m_oClient_CloseEvent(Client As cWinsock) Debug.Print "连接已关闭" If m_bAutoReconnect Then Debug.Print m_lReconnectInterval & " 秒后重连..." tmrReconnect.Interval = m_lReconnectInterval * 1000 tmrReconnect.Enabled = True End If End Sub Private Sub tmrReconnect_Timer() tmrReconnect.Enabled = False ConnectToServer End Sub ``` *** ### 🚦 流量控制 ```vb ' 带流量控制的文件传输 Private m_oClient As cWinsock Private m_lChunkSize As Long Private m_bSending As Boolean Private Sub SendFile(ByVal sFilePath As String) Dim iFileNum As Integer Dim baChunk() As Byte Dim lFileSize As Long Dim lSent As Long iFileNum = FreeFile Open sFilePath For Binary As #iFileNum lFileSize = LOF(iFileNum) m_lChunkSize = 8192 ' 8KB 每块 lSent = 0 m_bSending = True Do While lSent < lFileSize And m_bSending ' 读取数据块 ReDim baChunk(0 To m_lChunkSize - 1) As Byte Get #iFileNum, , baChunk ' 发送 m_oClient.SendData baChunk lSent = lSent + m_lChunkSize ' 更新进度 UpdateProgress lSent, lFileSize ' 等待发送完成 Do While m_bSending DoEvents If Not m_oClient.State = sckConnected Then Exit Do Loop If Not m_oClient.State = sckConnected Then Exit Do Loop Close #iFileNum Debug.Print "文件传输完成" End Sub Private Sub m_oClient_SendComplete(Client As cWinsock) m_bSending = False End Sub ``` *** ## 常见问题 ### ❓ 问题 1: 连接被拒绝 **现象**: `Error 10061` - 连接被拒绝 **原因**: * 服务器未启动 * 端口被防火墙阻止 * IP 地址或端口错误 **解决方案**: ```vb ' 检查服务器是否启动 If m_oServer.State <> sckListening Then MsgBox "服务器未启动", vbExclamation Exit Sub End If ' 检查端口 If Not IsPortOpen(txtPort.Text) Then MsgBox "端口 " & txtPort.Text & " 未开放", vbExclamation End If ``` *** ### ❓ 问题 2: 连接超时 **现象**: `Error 10060` - 连接超时 **原因**: * 网络不通 * 服务器响应慢 * 防火墙阻止 **解决方案**: ```vb ' 增加重试机制 Private Function ConnectWithRetry(ByVal sHost As String, ByVal lPort As Long, ByVal lRetries As Long) As Boolean Dim i As Long For i = 1 To lRetries On Error Resume Next m_oClient.Connect sHost, lPort If Err.Number = 0 Then ConnectWithRetry = True Exit Function End If Debug.Print "重连 " & i & "/" & lRetries & " 失败: " & Err.Description ' 等待后重试 Sleep 2000 Next ConnectWithRetry = False End Function ``` *** ### ❓ 问题 3: 数据丢失 **现象**: 发送的数据对方没有收到 **原因**: * 网络问题 * 缓冲区溢出 * 对方未正确读取 **解决方案**: ```vb ' 确认对方收到 Private Sub SendWithAck(ByVal sData As String) Dim sAck As String ' 发送数据 m_oClient.SendData "DATA:" & sData ' 等待确认 sAck = WaitForAck(5000) ' 5 秒超时 If sAck = "ACK" Then Debug.Print "对方已确认收到" Else Debug.Print "未收到确认，重发" m_oClient.SendData "DATA:" & sData End If End Sub ``` *** **最后更新**: 2026-06-09 --- --- url: /en/vbman/winsock/tcp.md --- # cWinsock TCP Programming Guide ## 📖 Table of Contents * [Overview](#overview) * [TCP Client Programming](#tcp-client-programming) * [TCP Server Programming](#tcp-server-programming) * [Advanced Features](#advanced-features) * [FAQ](#faq) *** ## Overview TCP (Transmission Control Protocol) is a connection-oriented, reliable transport protocol, suitable for application scenarios requiring data integrity and sequence guarantees. ### TCP Characteristics * ✅ **Connection-oriented**: Requires connection establishment first * ✅ **Reliable transmission**: Guarantees data arrival, order, and integrity * ✅ **Flow control**: Prevents network congestion * ✅ **Congestion control**: Automatically adjusts transmission rate * ❌ **Higher overhead**: More protocol overhead compared to UDP ### Applicable Scenarios * File transfer * Chat applications * Remote control * Database connections * Web services *** ## TCP Client Programming ### Basic Flow ``` 1. Create cWinsock object 2. Set protocol to TCP 3. Connect to server 4. Wait for Connect event 5. Send/Receive data 6. Close connection ``` ### Complete Example ```vb ' Declare client object Private WithEvents m_oClient As cWinsock ' Connect button Private Sub cmdConnect_Click() On Error GoTo EH If m_oClient Is Nothing Then Set m_oClient = New cWinsock End If ' Set protocol m_oClient.Protocol = sckTCPProtocol ' Connect to server m_oClient.Connect txtHost.Text, CLng(txtPort.Text) ' Update UI cmdConnect.Enabled = False cmdDisconnect.Enabled = False lblStatus.Caption = "Connecting..." Exit Sub EH: Debug.Print "Connection error: " & Err.Description lblStatus.Caption = "Connection failed" End Sub ' Connection success event Private Sub m_oClient_Connect(Client As cWinsock) Debug.Print "Connected to " & Client.RemoteHostIP & ":" & Client.RemotePort ' Update UI cmdConnect.Enabled = False cmdDisconnect.Enabled = True lblStatus.Caption = "Connected" End Sub ' Disconnect button Private Sub cmdDisconnect_Click() If Not m_oClient Is Nothing Then m_oClient.Close_ End If ' Update UI cmdConnect.Enabled = True cmdDisconnect.Enabled = False lblStatus.Caption = "Disconnected" End Sub ' Send data button Private Sub cmdSend_Click() On Error GoTo EH If Not m_oClient Is Nothing And m_oClient.State = sckConnected Then m_oClient.SendData txtSend.Text Debug.Print "Sent: " & txtSend.Text ' Clear input box txtSend.Text = "" Else MsgBox "Not connected", vbExclamation End If Exit Sub EH: Debug.Print "Send error: " & Err.Description End Sub ' Data arrival event Private Sub m_oClient_DataArrival(Client As cWinsock, ByVal bytesTotal As Long) Dim sData As String ' Receive data Client.GetData sData Debug.Print "Received data (" & bytesTotal & " bytes): " & sData ' Display on interface txtReceive.SelStart = Len(txtReceive.Text) txtReceive.SelText = sData & vbCrLf txtReceive.SelStart = Len(txtReceive.Text) End Sub ' Connection close event Private Sub m_oClient_CloseEvent(Client As cWinsock) Debug.Print "Connection closed" ' Update UI cmdConnect.Enabled = True cmdDisconnect.Enabled = False lblStatus.Caption = "Connection closed" End Sub ' Error event Private Sub m_oClient_Error(Client As cWinsock, ByVal Number As Long, Description As String, ByVal Scode As Long) Debug.Print "Error [" & Number & "]: " & Description ' Update UI lblStatus.Caption = "Error: " & Description End Sub ' Form unload Private Sub Form_Unload(Cancel As Integer) On Error Resume Next m_oClient.Close_ End Sub ``` *** ## TCP Server Programming ### Basic Flow ``` 1. Create cWinsock object 2. Set protocol to TCP 3. Listen on port 4. Wait for ConnectionRequest event 5. Accept or reject connection 6. Process client data through DataArrival 7. Cleanup when client disconnects ``` ### Complete Example ```vb ' Declare server object Private WithEvents m_oServer As cWinsock ' Start server button Private Sub cmdStart_Click() On Error GoTo EH If m_oServer Is Nothing Then Set m_oServer = New cWinsock End If ' Set protocol m_oServer.Protocol = sckTCPProtocol ' Start listening m_oServer.Listen CLng(txtPort.Text) Debug.Print "Server started, listening on port: " & m_oServer.LocalPort ' Update UI cmdStart.Enabled = False cmdStop.Enabled = True lblStatus.Caption = "Listening..." lblClientCount.Caption = "0" Exit Sub EH: Debug.Print "Failed to start server: " & Err.Description MsgBox "Unable to start server: " & Err.Description, vbExclamation End Sub ' Stop server button Private Sub cmdStop_Click() On Error Resume Next If Not m_oServer Is Nothing Then m_oServer.Close_ End If Debug.Print "Server stopped" ' Update UI cmdStart.Enabled = True cmdStop.Enabled = False lblStatus.Caption = "Stopped" lstClients.Clear End Sub ' New connection request event Private Sub m_oServer_ConnectionRequest(Client As cWinsock, ByRef DisConnect As Boolean) Debug.Print "New client connection: " & Client.RemoteHostIP & ":" & Client.RemotePort ' Check connection limit If m_oServer.ClientCount >= 100 Then Debug.Print "Maximum connections reached, rejecting connection" DisConnect = True Exit Sub End If ' IP blacklist check If IsInBlacklist(Client.RemoteHostIP) Then Debug.Print "IP in blacklist, rejecting connection: " & Client.RemoteHostIP DisConnect = True Exit Sub End If ' Accept connection (DisConnect = False) Debug.Print "Accept connection: Client #" & Client.ClientId ' Update client list UpdateClientList End Sub ' Data arrival event (all client data triggers through this event) Private Sub m_oServer_DataArrival(Client As cWinsock, ByVal bytesTotal As Long) Dim sData As String ' Receive data Client.GetData sData Debug.Print "Data from client " & Client.ClientId & " (" & Client.RemoteHostIP & "): " & sData ' Display in log LogMessage "Client #" & Client.ClientId & ": " & sData ' Echo to client Client.SendData "Echo: " & sData End Sub ' Connection close event Private Sub m_oServer_CloseEvent(Client As cWinsock) Debug.Print "Client " & Client.ClientId & " disconnected"" ' Update client list UpdateClientList End Sub ' Error event Private Sub m_oServer_Error(Client As cWinsock, ByVal Number As Long, Description As String, ByVal Scode As Long) Debug.Print "Error [" & Number & "]: " & Description If Client.IsServer Then ' Server error LogMessage "Server error: " & Description Else ' Client error LogMessage "Client " & Client.ClientId & " error: " & Description End If End Sub ' Update client list Private Sub UpdateClientList() lstClients.Clear lblClientCount.Caption = m_oServer.ClientCount Dim oClient As cWinsock For Each oClient In m_oServer.Clients lstClients.AddItem "Client #" & oClient.ClientId & " - " & oClient.RemoteHostIP & ":" & oClient.RemotePort Next End Sub ' Add log Private Sub LogMessage(ByVal sMsg As String) txtLog.SelStart = Len(txtLog.Text) txtLog.SelText = Format$(Now, "hh:mm:ss") & " - " & sMsg & vbCrLf txtLog.SelStart = Len(txtLog.Text) End Sub ' Form unload Private Sub Form_Unload(Cancel As Integer) On Error Resume Next m_oServer.Close_ End Sub ' Blacklist check Private Function IsInBlacklist(ByVal sIP As String) As Boolean ' Load blacklist from config file or database ' Simplified demo here IsInBlacklist = False End Function ``` *** ## Advanced Features ### 🔄 Heartbeat Detection cWinsock's built-in heartbeat manager, embedded `cTimer` automatic drive, no manual implementation needed. **Server: Timeout Detection** ```vb ' Configure heartbeat when starting server m_oServer.AutoHeartbeat = True m_oServer.HeartbeatTimeout = 120 ' 2 minutes no activity then timeout ' Timeout event Private Sub m_oServer_ClientTimeout(Client As cWinsock) Debug.Print "Client " & Client.ClientId & " timeout, automatically disconnected" UpdateClientList End Sub ``` **Client: Heartbeat Keepalive** ```vb ' Enable heartbeat after connection m_oClient.AutoHeartbeat = True m_oClient.HeartbeatInterval = 50 ' 50 seconds no activity then send heartbeat ' Heartbeat event Private Sub m_oClient_HeartbeatSent(Client As cWinsock) Debug.Print "Heartbeat sent, idle: " & Client.IdleSeconds & " seconds" End Sub ``` **Custom Heartbeat Packet** ```vb ' Default heartbeat packet is single byte &H00, can be customized Dim baHB(0 To 3) As Byte baHB(0) = &H50 ' P baHB(1) = &H49 ' I baHB(2) = &H4E ' N baHB(3) = &H47 ' G m_oClient.HeartbeatData = baHB ``` **Working Principle:** * Heartbeat manager embedded `cTimer`, triggers check every 10 seconds * Server: Checks all clients' `IdleSeconds`, triggers `ClientTimeout` and auto-disconnects if timeout * Client: If idle exceeds `HeartbeatInterval` sends heartbeat packet, intelligently skips when data is sent/received * Each send/receive automatically resets `LastActivityTime` *** ### 📦 Data Packet Protocol cWinsock has three built-in packet protocols, automatically handles TCP fragmentation/sticky packet issues. **Delimiter Protocol** (Suitable for text protocols) ```vb m_oServer.PacketProtocol = ppDelimiter m_oServer.Delimiter = vbCrLf ' Newline delimiter, suitable for line-based protocols ' Send automatically appends delimiter Client.SendData "Hello" ' Actually sends: "Hello" + vbCrLf ' Receive automatic unpacket Private Sub m_oServer_MessageArrival(Client As cWinsock, ByVal bytesTotal As Long) Debug.Print "Complete message: " & Client.GetDataText() End Sub ``` **Fixed Length Protocol** (Suitable for fixed-length messages) ```vb m_oServer.PacketProtocol = ppFixedLength m_oServer.FixedLength = 256 ' Each message fixed 256 bytes ``` **Length Header Protocol** (Suitable for binary protocols) ```vb m_oServer.PacketProtocol = ppLengthHeader m_oServer.HeaderBytes = 4 ' 4-byte length header m_oServer.HeaderEndian = eeLittleEndian ' Little-endian ' Send automatically adds length header Client.SendData "Hello" ' Actually sends: [4-byte length] + "Hello" ' Receive automatically strips length header Private Sub m_oServer_MessageArrival(Client As cWinsock, ByVal bytesTotal As Long) Dim baData() As Byte baData = Client.GetDataByteArray() ProcessBinaryMessage baData End Sub ``` **Configuration Inheritance**: New clients automatically inherit server's protocol and heartbeat configuration, each client holds independent instance, buffers don't interfere with each other. *** ### 🔄 Auto Reconnect ```vb ' Auto reconnect client Private WithEvents m_oClient As cWinsock Private m_bAutoReconnect As Boolean Private m_lReconnectInterval As Long Private Sub StartClient() Set m_oClient = New cWinsock m_oClient.Protocol = sckTCPProtocol m_bAutoReconnect = True m_lReconnectInterval = 5 ' 5 seconds ConnectToServer End Sub Private Sub ConnectToServer() On Error GoTo EH m_oClient.Connect "127.0.0.1", 8080 Debug.Print "Connecting..." Exit Sub EH: Debug.Print "Connection failed: " & Err.Description If m_bAutoReconnect Then Debug.Print "Reconnecting in " & m_lReconnectInterval & " seconds..." tmrReconnect.Interval = m_lReconnectInterval * 1000 tmrReconnect.Enabled = True End If End Sub Private Sub m_oClient_CloseEvent(Client As cWinsock) Debug.Print "Connection closed" If m_bAutoReconnect Then Debug.Print "Reconnecting in " & m_lReconnectInterval & " seconds..." tmrReconnect.Interval = m_lReconnectInterval * 1000 tmrReconnect.Enabled = True End If End Sub Private Sub tmrReconnect_Timer() tmrReconnect.Enabled = False ConnectToServer End Sub ``` *** ### 🚦 Flow Control ```vb ' Flow-controlled file transfer Private m_oClient As cWinsock Private m_lChunkSize As Long Private m_bSending As Boolean Private Sub SendFile(ByVal sFilePath As String) Dim iFileNum As Integer Dim baChunk() As Byte Dim lFileSize As Long Dim lSent As Long iFileNum = FreeFile Open sFilePath For Binary As #iFileNum lFileSize = LOF(iFileNum) m_lChunkSize = 8192 ' 8KB per chunk lSent = 0 m_bSending = True Do While lSent < lFileSize And m_bSending ' Read data chunk ReDim baChunk(0 To m_lChunkSize - 1) As Byte Get #iFileNum, , baChunk ' Send m_oClient.SendData baChunk lSent = lSent + m_lChunkSize ' Update progress UpdateProgress lSent, lFileSize ' Wait for send complete Do While m_bSending DoEvents If Not m_oClient.State = sckConnected Then Exit Do Loop If Not m_oClient.State = sckConnected Then Exit Do Loop Close #iFileNum Debug.Print "File transfer complete" End Sub Private Sub m_oClient_SendComplete(Client As cWinsock) m_bSending = False End Sub ``` *** ## FAQ ### ❓ Issue 1: Connection Refused **Symptom**: `Error 10061` - Connection refused **Causes**: * Server not started * Port blocked by firewall * Wrong IP address or port **Solution**: ```vb ' Check if server is started If m_oServer.State <> sckListening Then MsgBox "Server not started", vbExclamation Exit Sub End If ' Check port If Not IsPortOpen(txtPort.Text) Then MsgBox "Port " & txtPort.Text & " not open", vbExclamation End If ``` *** ### ❓ Issue 2: Connection Timeout **Symptom**: `Error 10060` - Connection timeout **Causes**: * Network unreachable * Server slow response * Firewall blocking **Solution**: ```vb ' Add retry mechanism Private Function ConnectWithRetry(ByVal sHost As String, ByVal lPort As Long, ByVal lRetries As Long) As Boolean Dim i As Long For i = 1 To lRetries On Error Resume Next m_oClient.Connect sHost, lPort If Err.Number = 0 Then ConnectWithRetry = True Exit Function End If Debug.Print "Retry " & i & "/" & lRetries & " failed: " & Err.Description ' Wait before retry Sleep 2000 Next ConnectWithRetry = False End Function ``` *** ### ❓ Issue 3: Data Loss **Symptom**: Sent data not received by other party **Causes**: * Network issues * Buffer overflow * Other party not reading correctly **Solution**: ```vb ' Confirm other party received Private Sub SendWithAck(ByVal sData As String) Dim sAck As String ' Send data m_oClient.SendData "DATA:" & sData ' Wait for acknowledgment sAck = WaitForAck(5000) ' 5 second timeout If sAck = "ACK" Then Debug.Print "Other party confirmed receipt" Else Debug.Print "No acknowledgment received, resending" m_oClient.SendData "DATA:" & sData End If End Sub ``` *** **Last Updated**: 2026-06-09 --- --- url: /zh/vbman/winsock/tls.md --- # cWinsock TLS/SSL 支持 ## 概述 `cWinsock` 支持通过链式函数配置 TLS，实现加密 TCP 通信。内部已将 `cAsyncSocket` 替换为 `cTlsSocket`（严格超集，TLS 未启用时行为完全一致）。 ## 链式函数 ### Tls — 客户端 TLS（无需证书） 客户端连接 TLS 服务器时使用，只需启用加密，无需本地证书。 ```vb Public Function Tls() As cWinsock ``` **适用场景：** 连接 wss:// 服务器、https:// 网站、TLS TCP 服务器等。 ### TlsCertFile — 证书文件模式 服务端 Listen 时出示证书，最常用方式。 ```vb Public Function TlsCertFile( _ ByVal CertFile As String, _ Optional ByVal Password As String, _ Optional ByVal AlpnProtocols As String = "http/1.1") As cWinsock ``` **参数：** | 参数 | 类型 | 必要 | 说明 | |------|------|------|------| | `CertFile` | String | 是 | 证书文件路径。PFX/P12 或 PEM 格式，PEM 支持用 `\|` 分隔多文件 | | `Password` | String | 否 | 证书密码，PEM 无加密私钥时留空 | | `AlpnProtocols` | String | 否 | ALPN 协议协商，默认 `"http/1.1"` | ### TlsCertSubject — Windows 证书存储模式 从 Windows 系统证书库查找证书。 ```vb Public Function TlsCertSubject( _ ByVal CertSubject As String, _ Optional ByVal AlpnProtocols As String = "http/1.1") As cWinsock ``` ### TlsCertMemory — 内存证书集合模式 高级用法，从内存中的 Collection 加载证书。 ```vb Public Function TlsCertMemory( _ ByVal Certificates As Collection, _ ByVal PrivateKey As Collection, _ Optional ByVal AlpnProtocols As String = "http/1.1") As cWinsock ``` ## 新增事件 ### ServerCertificateVerify 客户端连接 TLS 服务器时，用于验证服务器证书。 ```vb Event ServerCertificateVerify(Client As cWinsock, Issuers As Object, ByRef Confirmed As Boolean) ``` * `Issuers`：服务器证书链信息 * `Confirmed`：设为 `True` 信任证书，设为 `False` 拒绝连接 * 默认行为：自动信任（`Confirmed = True`） ## 使用示例 ### 客户端 TLS 连接 ```vb Dim ws As New cWinsock ws.Tls.Connect "example.com", 443 ``` ### 服务端 TLS 监听 ```vb Dim svr As New cWinsock svr.TlsCertFile("C:\certs\server.pfx", "password").Listen 443 ``` ### 条件启用 ```vb If Config.UseTLS Then ws.Tls End If ws.Connect Config.Host, Config.Port ``` ### 链式配置 ```vb Dim svr As New cWinsock svr.TlsCertFile("cert.pem").Delimiter(vbCrLf).AutoHeartbeat = True svr.Listen 9000 ``` ### 同步 TLS 连接 ```vb Dim ws As New cWinsock ws.Tls If ws.SyncConnect("example.com", 443, 5000) Then ' TLS 连接成功 End If ``` ### 证书验证（自定义） ```vb Private Sub m_oSocket_ServerCertificateVerify(Client As cWinsock, Issuers As Object, ByRef Confirmed As Boolean) ' 仅信任特定证书 If 检查证书是否可信 Then Confirmed = True Else Confirmed = False End If End Sub ``` ## 证书来源说明 三种证书模式的详细介绍，参见 [TLS 证书配置总览](../tls/overview.md)： | 证书模式 | 详见 | |----------|------| | TlsCertFile（证书文件） | [证书文件模式](../tls/certfile.md) | | TlsCertSubject（Windows 证书存储） | [Windows 证书存储模式](../tls/certsubject.md) | | TlsCertMemory（内存证书集合） | [内存证书集合模式](../tls/certmemory.md) | ## 内部机制 ### TLS 模式枚举 ```vb Private Enum EnumTlsMode TlsNone ' 未启用（默认，纯 TCP） TlsModeClient ' 客户端 TLS（Connect 时启用加密） TlsModeCertFile ' 证书文件（Listen 时出示证书） TlsModeSubject ' Windows 证书存储 TlsModeMemory ' 内存证书集合 End Enum ``` ### 核心替换 * `cAsyncSocket` → `cTlsSocket`：所有 `New cAsyncSocket` 改为 `New cTlsSocket` * `Connect`：TLS 模式时传 `UseTls:=True` * `Listen`：TLS 模式时先调用 `InitServerTls` 初始化证书 * `AcceptFrom`：参数类型改为 `cTlsSocket`，Accept 传 `UseTls` 标志 * `SyncConnect`：TLS 模式时传 `UseTls:=True` * `Close_`：重置 TLS 状态 ### 向后兼容 不调用任何 Tls 函数时，行为与改造前完全一致。`cTlsSocket` 在 TLS 未启用时，与 `cAsyncSocket` 行为完全相同。 ## 注意事项 1. **UDP 不受影响**：TLS 仅适用于 TCP，UDP 模式下 Tls 函数调用无效 2. **AcceptFrom 跨类访问**：使用 `TlsModeInternal` Friend Property 读取父级 TLS 状态 3. **编译依赖**：项目需包含 `cTlsSocket.cls` 及其依赖的 TLS 模块 4. **向后兼容**：不调用任何 Tls 函数时，行为与改造前完全一致 5. **证书来源优先级**：内存集合 > 证书文件 > Windows 证书存储 --- --- url: /en/vbman/winsock/tls.md --- # cWinsock TLS/SSL Support ## Overview `cWinsock` supports TLS/SSL encrypted communication for both TCP server and client modes. Through chained function configuration, TLS certificates can be easily set up to achieve encrypted data transmission. ## Function Signatures ### Server-Side Certificate Configuration #### TlsCertFile — Certificate File Mode ```vb Public Function TlsCertFile( _ ByVal CertFile As String, _ Optional ByVal Password As String, _ Optional ByVal AlpnProtocols As String = "http/1.1") As cWinsock ``` | Parameter | Type | Required | Description | |-----------|------|----------|-------------| | `CertFile` | String | Yes | Certificate file path, supports PFX/P12 and PEM formats | | `Password` | String | No | Certificate password | | `AlpnProtocols` | String | No | ALPN protocol negotiation, default `"http/1.1"` | #### TlsCertSubject — Windows Certificate Store Mode ```vb Public Function TlsCertSubject( _ ByVal CertSubject As String, _ Optional ByVal AlpnProtocols As String = "http/1.1") As cWinsock ``` | Parameter | Type | Required | Description | |-----------|------|----------|-------------| | `CertSubject` | String | Yes | Certificate subject name | | `AlpnProtocols` | String | No | ALPN protocol negotiation | #### TlsCertMemory — Memory Certificate Collection Mode ```vb Public Function TlsCertMemory( _ ByVal Certificates As Collection, _ ByVal PrivateKey As Collection, _ Optional ByVal AlpnProtocols As String = "http/1.1") As cWinsock ``` ### Client-Side TLS Enable (No Certificate Needed) ```vb ' Client only needs to call .Tls before Connect, no certificate needed m_oClient.Tls.Connect "example.com", 443 ``` ## Usage Examples ### TLS TCP Server ```vb Dim svr As New cWinsock ' PFX certificate with password svr.TlsCertFile("C:\certs\server.pfx", "password").Listen 443 ' PEM certificate (multiple files separated by |) svr.TlsCertFile("C:\certs\fullchain.pem|C:\certs\privkey.pem").Listen 443 ' Windows Certificate Store svr.TlsCertSubject("tcp.example.com").Listen 443 ``` ### TLS TCP Client ```vb Dim cli As New cWinsock ' Connect to TLS server (no certificate needed for client) cli.Tls.Connect "example.com", 443 ' Or connect first, then upgrade to TLS cli.Connect "example.com", 443 cli.Tls ' Upgrade current connection to TLS ``` ### Complete TLS Client Example ```vb Private WithEvents m_oClient As cWinsock Private Sub Form_Load() Set m_oClient = New cWinsock ' Set TCP protocol m_oClient.Protocol = sckTCPProtocol ' Connect and enable TLS m_oClient.Tls.Connect "example.com", 443 Debug.Print "Connecting to TLS server..." End Sub Private Sub m_oClient_Connect(Client As cWinsock) Debug.Print "TLS connection established" ' Send encrypted data Client.SendData "Hello, Secure World!" End Sub Private Sub m_oClient_DataArrival(Client As cWinsock, ByVal bytesTotal As Long) Dim sData As String Client.GetData sData Debug.Print "Received (encrypted): " & sData End Sub Private Sub Form_Unload(Cancel As Integer) On Error Resume Next m_oClient.Close_ End Sub ``` ### TLS Server with Packet Protocol ```vb Private WithEvents m_oServer As cWinsock Private Sub Form_Load() Set m_oServer = New cWinsock ' Set packet protocol m_oServer.PacketProtocol = ppLengthHeader m_oServer.HeaderBytes = 4 ' Start TLS server m_oServer.TlsCertFile("C:\certs\server.pfx", "password").Listen 443 Debug.Print "TLS server started on port 443" End Sub Private Sub m_oServer_ConnectionRequest(Client As cWinsock, ByRef DisConnect As Boolean) Debug.Print "New TLS client: " & Client.RemoteHostIP End Sub Private Sub m_oServer_MessageArrival(Client As cWinsock, ByVal bytesTotal As Long) Dim sData As String sData = Client.GetDataText() Debug.Print "Received: " & sData ' Reply with encrypted data Client.SendData "Echo: " & sData End Sub ``` ## Supported TLS Versions * TLS 1.2 * TLS 1.3 ## Certificate Format Support | Format | Extension | Description | |--------|-----------|-------------| | PKCS#12 | `.pfx`, `.p12` | Binary format, contains certificate chain + private key | | PEM | `.pem`, `.crt`, `.key` | Base64 text format | ## Certificate Chain For PEM format, you can use `|` to separate multiple certificate files: ```vb ' fullchain.pem contains server certificate + intermediate certificates ' privkey.pem contains private key svr.TlsCertFile("C:\certs\fullchain.pem|C:\certs\privkey.pem").Listen 443 ``` ## ALPN Protocol Negotiation Application-Layer Protocol Negotiation (ALPN) allows client and server to negotiate application protocol during TLS handshake. ```vb ' Default is "http/1.1", can be customized svr.TlsCertFile("C:\certs\server.pfx", "", "my-protocol").Listen 443 ``` ## Underlying Implementation ``` cWinsock ──uses──→ cTlsSocket ──uses──→ OpenSSL ``` All TLS operations are handled by `cTlsSocket` class, based on OpenSSL implementation. ## Certificate Verification ### Server Certificate Verification (Client-side) Clients can customize certificate verification logic through events: ```vb Private Sub m_oClient_ServerCertificateVerify( _ ByVal Certificate As String, _ ByVal Trusted As Boolean, _ Allow As Boolean) ' Certificate: Base64 encoded certificate ' Trusted: Whether certificate is in system trust store ' Allow: Set to True to allow connection, False to reject If Trusted Then Allow = True Else ' Custom verification logic Allow = VerifyCustom(Certificate) End If End Sub ``` ### Skip Certificate Verification (Development Only) ```vb ' Allow all certificates (insecure, for development only) Private Sub m_oClient_ServerCertificateVerify(ByVal Certificate As String, ByVal Trusted As Boolean, Allow As Boolean) Allow = True End Sub ``` ## Error Handling ### Common TLS Errors | Error | Cause | Solution | |-------|-------|----------| | Certificate not found | File path error or certificate not installed | Check file path or certificate store | | Password error | Wrong PFX password | Confirm password correct | | Certificate expired | Certificate past validity period | Update certificate | | Handshake failed | Protocol mismatch or certificate issue | Check TLS version and certificate chain | ## Related Documentation * [TLS Certificate Configuration Overview](../tls/overview.md) * [Certificate File Mode](../tls/certfile.md) * [Windows Certificate Store Mode](../tls/certsubject.md) * [Memory Certificate Collection Mode](../tls/certmemory.md) * [cHttpServer TLS Support](../httpserver/tls.md) * [cWebSocket TLS Support](../websocket/tls.md) *** **Last Updated**: 2026-06-09 --- --- url: /zh/vbman/winsock/udp.md --- # cWinsock UDP 编程指南 ## 📖 目录 * [概述](#概述) * [UDP 基本编程](#udp-基本编程) * [UDP 服务器虚拟客户端](#udp-服务器虚拟客户端) * [UDP 广播与多播](#udp-广播与多播) * [高级功能](#高级功能) * [常见问题](#常见问题) *** ## 概述 UDP（User Datagram Protocol）是一种无连接的、不可靠的传输协议，适合对实时性要求高、可以容忍少量数据丢失的应用场景。 ### UDP 特点 * ✅ **无连接**: 不需要建立连接 * ✅ **低延迟**: 无连接开销 * ✅ **简单高效**: 协议开销小 * ✅ **支持广播**: 可以同时发送给多个接收者 * ❌ **不可靠**: 不保证数据到达、顺序和完整性 * ❌ **无流量控制**: 可能导致网络拥塞 ### 适用场景 * 实时游戏 * 视频直播 * 音频通话 * DNS 查询 * 网络发现 * IoT 设备通信 *** ## UDP 基本编程 ### UDP 客户端 ```vb ' 声明 UDP 对象 Private WithEvents m_oUdp As cWinsock ' 初始化 Private Sub Form_Load() Set m_oUdp = New cWinsock m_oUdp.Protocol = sckUDPProtocol m_oUdp.Bind 0 ' 0 表示系统自动分配端口 Debug.Print "UDP 客户端已绑定到端口: " & m_oUdp.LocalPort End Sub ' 发送数据 Private Sub cmdSend_Click() ' 设置远程地址和端口 m_oUdp.RemoteHost = "127.0.0.1" m_oUdp.RemotePort = 8888 ' 发送数据 m_oUdp.SendData "Hello, UDP!" Debug.Print "已发送到 " & m_oUdp.RemoteHost & ":" & m_oUdp.RemotePort End Sub ' 接收数据 Private Sub m_oUdp_DataArrival(Client As cWinsock, ByVal bytesTotal As Long) Dim sData As String ' 接收数据 Client.GetData sData Debug.Print "收到数据 (" & bytesTotal & " 字节): " & sData Debug.Print "来自: " & Client.RemoteHostIP & ":" & Client.RemotePort End Sub ' 关闭 Private Sub Form_Unload(Cancel As Integer) On Error Resume Next m_oUdp.Close_ End Sub ``` ### UDP 服务器 ```vb ' 声明 UDP 服务器对象 Private WithEvents m_oUdpServer As cWinsock ' 启动服务器 Private Sub cmdStart_Click() Set m_oUdpServer = New cWinsock m_oUdpServer.Protocol = sckUDPProtocol m_oUdpServer.Bind 8888 Debug.Print "UDP 服务器已绑定到端口: 8888" End Sub ' 数据到达 Private Sub m_oUdpServer_DataArrival(Client As cWinsock, ByVal bytesTotal As Long) Dim sData As String ' 接收数据 Client.GetData sData Debug.Print "收到来自 " & Client.RemoteHostIP & ":" & Client.RemotePort & " 的数据" Debug.Print "内容: " & sData ' 回复 Client.SendData "Reply: " & sData Debug.Print "已回复" End Sub ' 关闭 Private Sub cmdStop_Click() m_oUdpServer.Close_ Debug.Print "UDP 服务器已停止" End Sub ``` *** ## UDP 服务器虚拟客户端 ### 概述 UDP 是无连接协议，但 `cWinsock` 为每个不同的远程地址:端口组合创建虚拟客户端对象，模拟连接行为。 ### 工作原理 ``` 首次收到来自 192.168.1.100:5000 的数据 ↓ 创建虚拟客户端对象，Tag = "192.168.1.100:5000" ↓ 触发 ConnectionRequest 事件 ↓ 触发 DataArrival 事件 ↓ 可以向该虚拟客户端回复数据 ``` ### 示例代码 ```vb Private WithEvents m_oUdpServer As cWinsock ' 启动服务器 Private Sub cmdStart_Click() Set m_oUdpServer = New cWinsock m_oUdpServer.Protocol = sckUDPProtocol m_oUdpServer.Bind 8888 Debug.Print "UDP 服务器已启动" End Sub ' 新连接请求（首次收到某个地址:端口的数据） Private Sub m_oUdpServer_ConnectionRequest(Client As cWinsock, ByRef DisConnect As Boolean) Debug.Print "新 UDP 客户端: " & Client.RemoteHostIP & ":" & Client.RemotePort Debug.Print "Tag: " & Client.Tag ' 可以在这里进行拦截 If IsInBlacklist(Client.RemoteHostIP) Then Debug.Print "拒绝黑名单 IP: " & Client.RemoteHostIP DisConnect = True End If End Sub ' 数据到达 Private Sub m_oUdpServer_DataArrival(Client As cWinsock, ByVal bytesTotal As Long) Dim sData As String ' 接收数据 Client.GetData sData Debug.Print "来自 Client #" & Client.ClientId & " 的数据: " & sData ' 直接向该虚拟客户端回复 Client.SendData "Echo: " & sData End Sub ' 连接关闭（虚拟客户端超时） Private Sub m_oUdpServer_CloseEvent(Client As cWinsock) Debug.Print "UDP 客户端 " & Client.ClientId & " 已断开" ' 更新客户端列表 UpdateClientList End Sub ' 更新客户端列表 Private Sub UpdateClientList() lstClients.Clear lblCount.Caption = m_oUdpServer.ClientCount Dim oClient As cWinsock For Each oClient In m_oUdpServer.Clients lstClients.AddItem oClient.Tag & " - " & oClient.RemoteHostIP & ":" & oClient.RemotePort Next End Sub ``` ### 虚拟客户端超时处理 ```vb Private Sub tmrCleanup_Timer() Dim oClient As cWinsock Dim tSession As tSessionData For Each oClient In m_oUdpServer.Clients tSession = oClient.UserData ' 检查超时（5 分钟无活动） If DateDiff("s", tSession.LastActivity, Now) > 300 Then Debug.Print "清理超时客户端: " & oClient.ClientId oClient.Close_ End If Next End Sub Private Sub m_oUdpServer_DataArrival(Client As cWinsock, ByVal bytesTotal As Long) Dim sData As String Client.GetData sData ' 更新活动时间 Dim tSession As tSessionData If IsEmpty(Client.UserData) Then tSession.FirstSeen = Now Else tSession = Client.UserData End If tSession.LastActivity = Now Client.UserData = tSession ' 处理数据... ProcessData Client, sData End Sub ``` *** ## UDP 广播与多播 ### 广播 ```vb ' 向局域网广播 Private Sub cmdBroadcast_Click() ' 绑定到任意端口 m_oUdp.Bind 0 ' 设置广播地址 m_oUdp.RemoteHost = "255.255.255.255" m_oUdp.RemotePort = 9999 ' 发送广播消息 m_oUdp.SendData "Broadcast message" Debug.Print "已发送广播" End Sub ' 接收广播 Private Sub m_oUdp_DataArrival(Client As cWinsock, ByVal bytesTotal As Long) Dim sData As String Client.GetData sData Debug.Print "收到广播: " & sData Debug.Print "来自: " & Client.RemoteHostIP & ":" & Client.RemotePort End Sub ``` ### 局域网设备发现 ```vb ' 发送发现请求 Private Sub cmdDiscover_Click() m_oUdp.RemoteHost = "255.255.255.255" m_oUdp.RemotePort = 9999 m_oUdp.SendData "DISCOVER_SERVERS" End Sub ' 服务器响应发现 Private Sub m_oUdpServer_DataArrival(Client As cWinsock, ByVal bytesTotal As Long) Dim sData As String Client.GetData sData If sData = "DISCOVER_SERVERS" Then ' 响应自己的信息 Client.SendData "SERVER_INFO:" & GetLocalIP() & ":" & m_oUdpServer.LocalPort End If End Sub ' 客户端收集响应 Private Sub m_oUdp_DataArrival(Client As cWinsock, ByVal bytesTotal As Long) Dim sData As String Client.GetData sData If Left$(sData, 12) = "SERVER_INFO:" Then Dim sInfo As String sInfo = Mid$(sData, 13) Debug.Print "发现服务器: " & sInfo ' 添加到列表 lstServers.AddItem sInfo End If End Sub ``` ### 多播（组播） ```vb ' 加入多播组 Private Sub JoinMulticastGroup(ByVal sGroupIP As String, ByVal lPort As Long) ' 注意：cWinsock 本身不直接支持多播 ' 需要使用底层 socket API 或 cAsyncSocket ' 这里演示基本用法 m_oUdp.Bind lPort m_oUdp.RemoteHost = sGroupIP m_oUdp.RemotePort = lPort Debug.Print "已加入多播组: " & sGroupIP End Sub ' 发送到多播组 Private Sub cmdSendMulticast_Click() m_oUdp.SendData "Multicast message" Debug.Print "已发送到多播组" End Sub ``` *** ## 高级功能 ### ✅ 可靠 UDP（带确认） ```vb ' 可靠 UDP 发送 Private Type tReliablePacket Sequence As Long ' 序列号 Total As Long ' 总包数 Index As Long ' 当前包索引 Data As String ' 数据 Acked As Boolean ' 已确认 Timestamp As Double ' 发送时间 End Type Private m_lSequence As Long Private m_lWindowSize As Long ' 发送数据 Private Sub SendReliable(ByVal sData As String) Dim lChunkSize As Long lChunkSize = 1000 ' 每包 1KB Dim lTotalChunks As Long lTotalChunks = (Len(sData) \ lChunkSize) + 1 Dim i As Long For i = 0 To lTotalChunks - 1 Dim lStart As Long lStart = i * lChunkSize + 1 Dim lEnd As Long lEnd = Min(lStart + lChunkSize - 1, Len(sData)) Dim sChunk As String sChunk = Mid$(sData, lStart, lEnd - lStart + 1) ' 发送数据包 m_oUdp.SendData "PKT:" & m_lSequence & ":" & lTotalChunks & ":" & i & ":" & sChunk Debug.Print "发送包 " & i + 1 & "/" & lTotalChunks m_lSequence = m_lSequence + 1 ' 控制发送速率 If (i + 1) Mod m_lWindowSize = 0 Then Sleep 50 ' 窗口满后等待 End If Next End Sub ' 接收并确认 Private Sub m_oUdp_DataArrival(Client As cWinsock, ByVal bytesTotal As Long) Dim sData As String Client.GetData sData If Left$(sData, 4) = "PKT:" Then ' 解析数据包 Dim sParts() As String sParts = Split(Mid$(sData, 5), ":") Dim lSeq As Long Dim lTotal As Long Dim lIndex As Long Dim sPayload As String lSeq = CLng(sParts(0)) lTotal = CLng(sParts(1)) lIndex = CLng(sParts(2)) sPayload = sParts(3) Debug.Print "收到包 " & lIndex + 1 & "/" & lTotal & " (序列号: " & lSeq & ")" ' 发送确认 Client.SendData "ACK:" & lSeq & ":" & lIndex ' 处理数据... ProcessPacket lSeq, lIndex, lTotal, sPayload ElseIf Left$(sData, 4) = "ACK:" Then ' 收到确认 Dim sAckParts() As String sAckParts = Split(Mid$(sData, 5), ":") Dim lAckSeq As Long Dim lAckIndex As Long lAckSeq = CLng(sAckParts(0)) lAckIndex = CLng(sAckParts(1)) ' 标记为已确认 MarkPacketAcked lAckSeq, lAckIndex Debug.Print "收到确认: " & lAckSeq & ":" & lAckIndex End If End Sub ``` *** ### 📊 数据包顺序重组 ```vb ' 数据包重组 Private Type tReassemblyBuffer Packets() As String ReceivedCount As Long TotalCount As Long End Type Private m_oReassembly As Collection ' 初始化重组缓冲区 Private Sub InitReassembly(ByVal lSequence As Long, ByVal lTotal As Long) Dim tBuffer As tReassemblyBuffer ReDim tBuffer.Packets(0 To lTotal - 1) As String tBuffer.ReceivedCount = 0 tBuffer.TotalCount = lTotal m_oReassembly.Add tBuffer, CStr(lSequence) End Sub ' 添加数据包 Private Sub AddPacket(ByVal lSequence As Long, ByVal lIndex As Long, ByVal sData As String) Dim tBuffer As tReassemblyBuffer On Error Resume Next tBuffer = m_oReassembly(CStr(lSequence)) On Error GoTo 0 If tBuffer.TotalCount = 0 Then ' 新序列 Debug.Print "新序列: " & lSequence End If ' 存储数据包 tBuffer.Packets(lIndex) = sData tBuffer.ReceivedCount = tBuffer.ReceivedCount + 1 ' 更新缓冲区 If tBuffer.ReceivedCount = tBuffer.TotalCount Then ' 所有包都收到，重组数据 Dim sComplete As String Dim i As Long For i = 0 To tBuffer.TotalCount - 1 sComplete = sComplete & tBuffer.Packets(i) Next Debug.Print "序列 " & lSequence & " 重组完成，总大小: " & Len(sComplete) ' 处理完整数据 ProcessCompleteData sComplete ' 删除缓冲区 m_oReassembly.Remove CStr(lSequence) Else ' 更新缓冲区 m_oReassembly.Remove CStr(lSequence) m_oReassembly.Add tBuffer, CStr(lSequence) End If End Sub ``` *** ### 🕐 超时重传 ```vb ' 超时重传机制 Private Type tPendingPacket Sequence As Long Index As Long Data As String Timestamp As Double RetryCount As Long End Type Private m_oPendingPackets As Collection Private Const PACKET_TIMEOUT As Double = 5 ' 5 秒超时 Private Const MAX_RETRIES As Long = 3 ' 发送带超时的数据包 Private Sub SendWithTimeout(ByVal lSeq As Long, ByVal lIdx As Long, ByVal sData As String) ' 发送数据 m_oUdp.SendData "PKT:" & lSeq & ":" & lIdx & ":" & sData ' 添加到待确认列表 Dim tPending As tPendingPacket tPending.Sequence = lSeq tPending.Index = lIdx tPending.Data = sData tPending.Timestamp = Timer tPending.RetryCount = 0 m_oPendingPackets.Add tPending, CStr(lSeq) & ":" & CStr(lIdx) Debug.Print "发送包 " & lSeq & ":" & lIdx & "，等待确认..." End Sub ' 检查超时 Private Sub tmrTimeout_Timer() Dim i As Long For i = m_oPendingPackets.Count To 1 Step -1 Dim tPending As tPendingPacket tPending = m_oPendingPackets(i) ' 检查是否超时 If Timer - tPending.Timestamp > PACKET_TIMEOUT Then If tPending.RetryCount < MAX_RETRIES Then ' 重传 Debug.Print "包 " & tPending.Sequence & ":" & tPending.Index & " 超时，重传..." ' 重发 m_oUdp.SendData "PKT:" & tPending.Sequence & ":" & tPending.Index & ":" & tPending.Data ' 更新重试计数和时间 tPending.RetryCount = tPending.RetryCount + 1 tPending.Timestamp = Timer m_oPendingPackets.Remove i m_oPendingPackets.Add tPending, CStr(tPending.Sequence) & ":" & CStr(tPending.Index) Else ' 达到最大重试次数，放弃 Debug.Print "包 " & tPending.Sequence & ":" & tPending.Index & " 超过最大重试次数，放弃" m_oPendingPackets.Remove i End If End If Next End Sub ' 确认数据包 Private Sub AckPacket(ByVal lSeq As Long, ByVal lIdx As Long) Dim sKey As String sKey = CStr(lSeq) & ":" & CStr(lIdx) On Error Resume Next m_oPendingPackets.Remove sKey On Error GoTo 0 Debug.Print "确认包 " & lSeq & ":" & lIdx End Sub ``` *** ## 常见问题 ### ❓ 问题 1: UDP 数据包丢失 **现象**: 发送的数据对方没有收到 **原因**: UDP 是不可靠传输，数据包可能丢失 **解决方案**: 实现确认重传机制（如上所示） *** ### ❓ 问题 2: 数据包顺序错乱 **现象**: 接收到的数据包顺序与发送顺序不一致 **原因**: UDP 不保证顺序 **解决方案**: 实现序列号和重组机制 *** ### ❓ 问题 3: 数据包重复 **现象**: 收到重复的数据包 **原因**: 重传导致 **解决方案**: 根据序列号去重 ```vb Private Function IsDuplicate(ByVal lSequence As Long) As Boolean Static lLastSequence As Long If lSequence <= lLastSequence Then IsDuplicate = True Else IsDuplicate = False lLastSequence = lSequence End If End Function ``` *** ### ❓ 问题 4: 广播失败 **现象**: 发送广播后没有收到响应 **原因**: 防火墙阻止广播 **解决方案**: 配置防火墙或使用特定端口 ```vb ' 尝试不同的广播地址 m_oUdp.RemoteHost = "192.168.1.255" ' 子网广播 m_oUdp.SendData "Broadcast" ``` *** ### ❓ 问题 5: 虚拟客户端未清理 **现象**: UDP 服务器客户端列表持续增长 **原因**: UDP 无连接，客户端断开时无法自动检测 **解决方案**: 实现超时清理机制 ```vb Private Sub tmrCleanup_Timer() Dim oClient As cWinsock Dim tSession As tSessionData For Each oClient In m_oUdpServer.Clients tSession = oClient.UserData ' 检查超时 If DateDiff("s", tSession.LastActivity, Now) > 300 Then Debug.Print "清理超时客户端: " & oClient.ClientId oClient.Close_ End If Next End Sub ``` *** **最后更新**: 2026-01-09 --- --- url: /en/vbman/winsock/udp.md --- # cWinsock UDP Programming Guide ## 📖 Table of Contents * [Overview](#overview) * [UDP Basic Programming](#udp-basic-programming) * [UDP Server Virtual Client](#udp-server-virtual-client) * [UDP Broadcast and Multicast](#udp-broadcast-and-multicast) * [Advanced Features](#advanced-features) * [Common Issues](#common-issues) *** ## Overview UDP (User Datagram Protocol) is a connectionless, unreliable transmission protocol, suitable for scenarios requiring real-time performance and tolerating some data loss. ### UDP Characteristics * ✅ **Connectionless**: No need to establish connection * ✅ **Low latency**: No connection overhead * ✅ **Simple and efficient**: Small protocol overhead * ✅ **Broadcast support**: Can send to multiple receivers simultaneously * ❌ **Unreliable**: Doesn't guarantee data arrival, ordering, or integrity * ❌ **No flow control**: May cause network congestion ### Use Cases * Real-time gaming * Video streaming * Audio calls * DNS queries * Network discovery * IoT device communication *** ## UDP Basic Programming ### UDP Client ```vb ' Declare UDP object Private WithEvents m_oUdp As cWinsock ' Initialize Private Sub Form_Load() Set m_oUdp = New cWinsock m_oUdp.Protocol = sckUDPProtocol m_oUdp.Bind 0 ' 0 means system auto-assigns port Debug.Print "UDP client bound to port: " & m_oUdp.LocalPort End Sub ' Send data Private Sub cmdSend_Click() ' Set remote address and port m_oUdp.RemoteHost = "127.0.0.1" m_oUdp.RemotePort = 8888 ' Send data m_oUdp.SendData "Hello, UDP!" Debug.Print "Sent to " & m_oUdp.RemoteHost & ":" & m_oUdp.RemotePort End Sub ' Receive data Private Sub m_oUdp_DataArrival(Client As cWinsock, ByVal bytesTotal As Long) Dim sData As String ' Receive data Client.GetData sData Debug.Print "Received data (" & bytesTotal & " bytes): " & sData Debug.Print "From: " & Client.RemoteHostIP & ":" & Client.RemotePort End Sub ' Close Private Sub Form_Unload(Cancel As Integer) On Error Resume Next m_oUdp.Close_ End Sub ``` ### UDP Server ```vb ' Declare UDP server object Private WithEvents m_oUdpServer As cWinsock ' Start server Private Sub cmdStart_Click() Set m_oUdpServer = New cWinsock m_oUdpServer.Protocol = sckUDPProtocol m_oUdpServer.Bind 8888 Debug.Print "UDP server bound to port: 8888" End Sub ' Data arrival Private Sub m_oUdpServer_DataArrival(Client As cWinsock, ByVal bytesTotal As Long) Dim sData As String ' Receive data Client.GetData sData Debug.Print "Received from " & Client.RemoteHostIP & ":" & Client.RemotePort Debug.Print "Content: " & sData ' Reply Client.SendData "Reply: " & sData Debug.Print "Replied" End Sub ' Close Private Sub cmdStop_Click() m_oUdpServer.Close_ Debug.Print "UDP server stopped" End Sub ``` *** ## UDP Server Virtual Client ### Overview UDP is a connectionless protocol, but `cWinsock` creates virtual client objects for each different remote address:port combination, simulating connection behavior. ### How It Works ``` First time receiving data from 192.168.1.100:5000 ↓ Create virtual client object, Tag = "192.168.1.100:5000" ↓ Trigger ConnectionRequest event ↓ Trigger DataArrival event ↓ Can reply to that virtual client ``` ### Example Code ```vb Private WithEvents m_oUdpServer As cWinsock ' Start server Private Sub cmdStart_Click() Set m_oUdpServer = New cWinsock m_oUdpServer.Protocol = sckUDPProtocol m_oUdpServer.Bind 8888 Debug.Print "UDP server started" End Sub ' New connection request (first time receiving data from some address:port) Private Sub m_oUdpServer_ConnectionRequest(Client As cWinsock, ByRef DisConnect As Boolean) Debug.Print "New UDP client: " & Client.RemoteHostIP & ":" & Client.RemotePort Debug.Print "Tag: " & Client.Tag ' Can intercept here If IsInBlacklist(Client.RemoteHostIP) Then Debug.Print "Reject blacklist IP: " & Client.RemoteHostIP DisConnect = True End If End Sub ' Data arrival Private Sub m_oUdpServer_DataArrival(Client As cWinsock, ByVal bytesTotal As Long) Dim sData As String ' Receive data Client.GetData sData Debug.Print "Data from Client #" & Client.ClientId & ": " & sData ' Reply directly to that virtual client Client.SendData "Echo: " & sData End Sub ' Connection closed (virtual client timeout) Private Sub m_oUdpServer_CloseEvent(Client As cWinsock) Debug.Print "UDP client " & Client.ClientId & " disconnected" ' Update client list UpdateClientList End Sub ' Update client list Private Sub UpdateClientList() lstClients.Clear lblCount.Caption = m_oUdpServer.ClientCount Dim oClient As cWinsock For Each oClient In m_oUdpServer.Clients lstClients.AddItem "Client #" & oClient.ClientId & " - " & oClient.RemoteHostIP & ":" & oClient.RemotePort Next End Sub ``` ### Virtual Client Timeout Handling ```vb Private Sub tmrCleanup_Timer() Dim oClient As cWinsock Dim tSession As tSessionData For Each oClient In m_oUdpServer.Clients tSession = oClient.UserData ' Check timeout (5 minutes no activity) If DateDiff("s", tSession.LastActivity, Now) > 300 Then Debug.Print "Clean up timeout client: " & oClient.ClientId oClient.Close_ End If Next End Sub Private Sub m_oUdpServer_DataArrival(Client As cWinsock, ByVal bytesTotal As Long) Dim sData As String Client.GetData sData ' Update activity time Dim tSession As tSessionData If IsEmpty(Client.UserData) Then tSession.FirstSeen = Now Else tSession = Client.UserData End If tSession.LastActivity = Now Client.UserData = tSession ' Process data... ProcessData Client, sData End Sub ``` *** ## UDP Broadcast and Multicast ### Broadcast ```vb ' Broadcast to LAN Private Sub cmdBroadcast_Click() ' Bind to any port m_oUdp.Bind 0 ' Set broadcast address m_oUdp.RemoteHost = "255.255.255.255" m_oUdp.RemotePort = 9999 ' Send broadcast message m_oUdp.SendData "Broadcast message" Debug.Print "Sent broadcast" End Sub ' Receive broadcast Private Sub m_oUdp_DataArrival(Client As cWinsock, ByVal bytesTotal As Long) Dim sData As String Client.GetData sData Debug.Print "Received broadcast: " & sData Debug.Print "From: " & Client.RemoteHostIP & ":" & Client.RemotePort End Sub ``` ### LAN Device Discovery ```vb ' Send discovery request Private Sub cmdDiscover_Click() m_oUdp.RemoteHost = "255.255.255.255" m_oUdp.RemotePort = 9999 m_oUdp.SendData "DISCOVER_SERVERS" End Sub ' Server responds to discovery Private Sub m_oUdpServer_DataArrival(Client As cWinsock, ByVal bytesTotal As Long) Dim sData As String Client.GetData sData If sData = "DISCOVER_SERVERS" Then ' Respond with own info Client.SendData "SERVER_INFO:" & GetLocalIP() & ":" & m_oUdpServer.LocalPort End If End Sub ' Client collects responses Private Sub m_oUdp_DataArrival(Client As cWinsock, ByVal bytesTotal As Long) Dim sData As String Client.GetData sData If Left$(sData, 12) = "SERVER_INFO:" Then Dim sInfo As String sInfo = Mid$(sData, 13) Debug.Print "Discovered server: " & sInfo ' Add to list lstServers.AddItem sInfo End If End Sub ``` ### Multicast (Groupcast) ```vb ' Join multicast group Private Sub JoinMulticastGroup(ByVal sGroupIP As String, ByVal lPort As Long) ' Note: cWinsock doesn't directly support multicast ' Need to use underlying socket API or cAsyncSocket ' Basic usage demonstrated here m_oUdp.Bind lPort m_oUdp.RemoteHost = sGroupIP m_oUdp.RemotePort = lPort Debug.Print "Joined multicast group: " & sGroupIP End Sub ' Send to multicast group Private Sub cmdSendMulticast_Click() m_oUdp.SendData "Multicast message" Debug.Print "Sent to multicast group" End Sub ``` *** ## Advanced Features ### ✅ Reliable UDP (with Acknowledgment) ```vb ' Reliable UDP sending Private Type tReliablePacket Sequence As Long ' Sequence number Total As Long ' Total packets Index As Long ' Current packet index Data As String ' Data Acked As Boolean ' Acknowledged Timestamp As Double ' Send time End Type Private m_lSequence As Long Private m_lWindowSize As Long ' Send data Private Sub SendReliable(ByVal sData As String) Dim lChunkSize As Long lChunkSize = 1000 ' 1KB per packet Dim lTotalChunks As Long lTotalChunks = (Len(sData) \ lChunkSize) + 1 Dim i As Long For i = 0 To lTotalChunks - 1 Dim lStart As Long lStart = i * lChunkSize + 1 Dim lEnd As Long lEnd = Min(lStart + lChunkSize - 1, Len(sData)) Dim sChunk As String sChunk = Mid$(sData, lStart, lEnd - lStart + 1) ' Send packet m_oUdp.SendData "PKT:" & m_lSequence & ":" & lTotalChunks & ":" & i & ":" & sChunk Debug.Print "Sent packet " & i + 1 & "/" & lTotalChunks m_lSequence = m_lSequence + 1 ' Control send rate If (i + 1) Mod m_lWindowSize = 0 Then Sleep 50 ' Wait when window full End If Next End Sub ' Receive and acknowledge Private Sub m_oUdp_DataArrival(Client As cWinsock, ByVal bytesTotal As Long) Dim sData As String Client.GetData sData If Left$(sData, 4) = "PKT:" Then ' Parse packet Dim sParts() As String sParts = Split(Mid$(sData, 5), ":") Dim lSeq As Long Dim lTotal As Long Dim lIndex As Long Dim sPayload As String lSeq = CLng(sParts(0)) lTotal = CLng(sParts(1)) lIndex = CLng(sParts(2)) sPayload = sParts(3) Debug.Print "Received packet " & lIndex + 1 & "/" & lTotal & " (sequence: " & lSeq & ")" ' Send acknowledgment Client.SendData "ACK:" & lSeq & ":" & lIndex ' Process data... ProcessPacket lSeq, lIndex, lTotal, sPayload ElseIf Left$(sData, 4) = "ACK:" Then ' Received acknowledgment Dim sAckParts() As String sAckParts = Split(Mid$(sData, 5), ":") Dim lAckSeq As Long Dim lAckIndex As Long lAckSeq = CLng(sAckParts(0)) lAckIndex = CLng(sAckParts(1)) ' Mark as acknowledged MarkPacketAcked lAckSeq, lAckIndex Debug.Print "Received acknowledgment: " & lAckSeq & ":" & lAckIndex End If End Sub ``` *** ### 📊 Packet Reassembly ```vb ' Packet reassembly Private Type tReassemblyBuffer Packets() As String ReceivedCount As Long TotalCount As Long End Type Private m_oReassembly As Collection ' Initialize reassembly buffer Private Sub InitReassembly(ByVal lSequence As Long, ByVal lTotal As Long) Dim tBuffer As tReassemblyBuffer ReDim tBuffer.Packets(0 To lTotal - 1) As String tBuffer.ReceivedCount = 0 tBuffer.TotalCount = lTotal m_oReassembly.Add tBuffer, CStr(lSequence) End Sub ' Add packet Private Sub AddPacket(ByVal lSequence As Long, ByVal lIndex As Long, ByVal sData As String) Dim tBuffer As tReassemblyBuffer On Error Resume Next tBuffer = m_oReassembly(CStr(lSequence)) On Error GoTo 0 If tBuffer.TotalCount = 0 Then ' New sequence Debug.Print "New sequence: " & lSequence End If ' Store packet tBuffer.Packets(lIndex) = sData tBuffer.ReceivedCount = tBuffer.ReceivedCount + 1 ' Update buffer If tBuffer.ReceivedCount = tBuffer.TotalCount Then ' All packets received, reassemble data Dim sComplete As String Dim i As Long For i = 0 To tBuffer.TotalCount - 1 sComplete = sComplete & tBuffer.Packets(i) Next Debug.Print "Sequence " & lSequence & " reassembly complete, total size: " & Len(sComplete) ' Process complete data ProcessCompleteData sComplete ' Delete buffer m_oReassembly.Remove CStr(lSequence) Else ' Update buffer m_oReassembly.Remove CStr(lSequence) m_oReassembly.Add tBuffer, CStr(lSequence) End If End Sub ``` *** ### 🕐 Timeout Retransmission ```vb ' Timeout retransmission mechanism Private Type tPendingPacket Sequence As Long Index As Long Data As String Timestamp As Double RetryCount As Long End Type Private m_oPendingPackets As Collection Private Const PACKET_TIMEOUT As Double = 5 ' 5 second timeout Private Const MAX_RETRIES As Long = 3 ' Send packet with timeout Private Sub SendWithTimeout(ByVal lSeq As Long, ByVal lIdx As Long, ByVal sData As String) ' Send data m_oUdp.SendData "PKT:" & lSeq & ":" & lIdx & ":" & sData ' Add to pending list Dim tPending As tPendingPacket tPending.Sequence = lSeq tPending.Index = lIdx tPending.Data = sData tPending.Timestamp = Timer tPending.RetryCount = 0 m_oPendingPackets.Add tPending, CStr(lSeq) & ":" & CStr(lIdx) Debug.Print "Sent packet " & lSeq & ":" & lIdx & ", waiting for acknowledgment..." End Sub ' Check timeout Private Sub tmrTimeout_Timer() Dim i As Long For i = m_oPendingPackets.Count To 1 Step -1 Dim tPending As tPendingPacket tPending = m_oPendingPackets(i) ' Check if timeout If Timer - tPending.Timestamp > PACKET_TIMEOUT Then If tPending.RetryCount < MAX_RETRIES Then ' Retransmit Debug.Print "Packet " & tPending.Sequence & ":" & tPending.Index & " timeout, retrying..." ' Resend m_oUdp.SendData "PKT:" & tPending.Sequence & ":" & tPending.Index & ":" & tPending.Data ' Update retry count and time tPending.RetryCount = tPending.RetryCount + 1 tPending.Timestamp = Timer m_oPendingPackets.Remove i m_oPendingPackets.Add tPending, CStr(tPending.Sequence) & ":" & CStr(tPending.Index) Else ' Max retries reached, give up Debug.Print "Packet " & tPending.Sequence & ":" & tPending.Index & " exceeded max retries, giving up" m_oPendingPackets.Remove i End If End If Next End Sub ' Acknowledge packet Private Sub AckPacket(ByVal lSeq As Long, ByVal lIdx As Long) Dim sKey As String sKey = CStr(lSeq) & ":" & CStr(lIdx) On Error Resume Next m_oPendingPackets.Remove sKey On Error GoTo 0 Debug.Print "Acknowledged packet " & lSeq & ":" & lIdx End Sub ``` *** ## Common Issues ### ❓ Issue 1: UDP Packet Loss **Symptom**: Sent data not received by peer **Cause**: UDP is unreliable transmission, packets may be lost **Solution**: Implement acknowledgment and retransmission mechanism (as shown above) *** ### ❓ Issue 2: Packet Out of Order **Symptom**: Received packets not in same order as sent **Cause**: UDP doesn't guarantee ordering **Solution**: Implement sequence number and reassembly mechanism *** ### ❓ Issue 3: Duplicate Packets **Symptom**: Receiving duplicate packets **Cause**: Caused by retransmission **Solution**: Deduplicate by sequence number ```vb Private Function IsDuplicate(ByVal lSequence As Long) As Boolean Static lLastSequence As Long If lSequence <= lLastSequence Then IsDuplicate = True Else IsDuplicate = False lLastSequence = lSequence End If End Function ``` *** ### ❓ Issue 4: Broadcast Failure **Symptom**: No response after sending broadcast **Cause**: Firewall blocking broadcast **Solution**: Configure firewall or use specific port ```vb ' Try different broadcast addresses m_oUdp.RemoteHost = "192.168.1.255" ' Subnet broadcast m_oUdp.SendData "Broadcast" ``` *** ### ❓ Issue 5: Virtual Client Not Cleaned **Symptom**: UDP server client list keeps growing **Cause**: UDP connectionless, cannot automatically detect client disconnect **Solution**: Implement timeout cleanup mechanism ```vb Private Sub tmrCleanup_Timer() Dim oClient As cWinsock Dim tSession As tSessionData For Each oClient In m_oUdpServer.Clients tSession = oClient.UserData ' Check timeout If DateDiff("s", tSession.LastActivity, Now) > 300 Then Debug.Print "Clean up timeout client: " & oClient.ClientId oClient.Close_ End If Next End Sub ``` *** **Last Updated**: 2026-01-09 --- --- url: /en/vbman/winsock/binding.md --- # cWinsock User Binding and Group Management ## Feature Overview User binding and group management features provide a complete user identity management and message distribution mechanism: * **User Binding**: Associate user identity with socket connection, support sending messages by username * **Group Management**: Group users for batch message sending and management operations * **Bidirectional Sync**: Group operations automatically sync server-side and client-side `CurrentGroups` * **Auto Cleanup**: Automatically unbind when user disconnects, no manual handling needed ### Key Properties | Property | Type | Description | |----------|------|-------------| | `CurrentUser` | Variant | Username bound to client instance | | `CurrentUserToken` | String | User token bound to client instance (e.g., auth token) | | `CurrentUserInfo` | cJson | User extended info bound to client instance (JSON object) | | `CurrentGroups` | Dictionary | Group list client belongs to (group name → True) | *** ## User Binding ### BindUser Method #### Description Binds a user to a client connection, achieving association between user identity and socket connection. #### Syntax ```vb Public Sub BindUser(ByVal User As Variant, Client As cWinsock, Optional ByVal Token As String, Optional Info As cJson) ``` #### Parameters | Parameter | Type | Description | |-----------|------|-------------| | `User` | Variant | User identifier (string or other unique value) | | `Client` | cWinsock | Client socket instance | | `Token` | String (optional) | User auth token, can be retrieved via `Client.CurrentUserToken` after binding | | `Info` | cJson (optional) | User extended info (JSON object), can be retrieved via `Client.CurrentUserInfo` after binding | #### Usage Example ```vb ' Server: Bind user when client connects Private Sub m_oServer_DataArrival(Client As cWinsock, ByVal bytesTotal As Long) Dim sData As String Client.GetData sData ' Parse login message, format: "LOGIN:username" If Left$(sData, 6) = "LOGIN:" Then Dim sUsername As String sUsername = Mid$(sData, 7) ' Bind user to client (with Token and extended info) Dim oInfo As New cJson oInfo.Add "loginTime", Now oInfo.Add "ip", Client.RemoteHostIP m_oServer.BindUser sUsername, Client, "secret_token_123", oInfo Client.SendData "LOGIN:OK" Debug.Print "User " & sUsername & " logged in, Token: " & Client.CurrentUserToken End If End Sub ``` *** ### ExistsUser Method #### Description Check if specified user is bound. #### Syntax ```vb Public Function ExistsUser(ByVal User As Variant) As Boolean ``` #### Usage Example ```vb If m_oServer.ExistsUser("alice") Then Debug.Print "User is online" Else Debug.Print "User is offline" End If ``` *** ### UnbindUser Method #### Description Unbind specified user. #### Syntax ```vb Public Sub UnbindUser(ByVal User As Variant) ``` #### Usage Example ```vb ' Manually kick user If m_oServer.ExistsUser("alice") Then m_oServer.UnbindUser "alice" Debug.Print "User unbound" End If ``` #### Auto Unbind When user disconnects, system automatically removes from user list, no manual call needed. *** ### SendToUser Method #### Description Send data to bound user. #### Syntax ```vb Public Sub SendToUser(ByVal User As Variant, Data As Variant, Optional ByVal CodePage As EnumScpCodePage = wcpAcp) ``` #### Parameters | Parameter | Type | Description | |-----------|------|-------------| | `User` | Variant | User identifier | | `Data` | Variant | Data to send (string or byte array) | | `CodePage` | EnumScpCodePage (optional) | Text encoding, default `wcpAcp` | #### Usage Example ```vb ' Send message to specific user m_oServer.SendToUser "alice", "Hello, Alice!" ' Send with UTF-8 encoding m_oServer.SendToUser "alice", "Hello, Alice!", wcpUtf8 ' Broadcast message to all online users Dim vUser As Variant For Each vUser In m_oServer.m_Users.Keys m_oServer.SendToUser vUser, "System announcement: Server maintenance in 5 minutes" Next ``` #### Error Handling If user doesn't exist, error is thrown: ```vb On Error GoTo EH m_oServer.SendToUser "bob", "Hello!" Exit Sub EH: If Err.Number = vbObjectError Then MsgBox "User is offline" End If ``` *** ## Group Management Group management allows grouping users for easy batch message sending and management. ### Prerequisites Before binding to a group, user must first bind to client: ```vb ' ✅ Correct flow: Bind user first, then bind to group m_oServer.BindUser "alice", Client m_oServer.BindGroup "admins", Client ' ❌ Wrong: User not bound, cannot bind to group m_oServer.BindGroup "admins", Client ' Will error ``` *** ### BindGroup Method #### Description Add client with bound user to specified group. #### Syntax ```vb Public Sub BindGroup(ByVal GroupName As String, Client As cWinsock) ``` #### Parameters | Parameter | Type | Description | |-----------|------|-------------| | `GroupName` | String | Group name | | `Client` | cWinsock | Client instance with bound user | #### Usage Example ```vb Private Sub m_oServer_DataArrival(Client As cWinsock, ByVal bytesTotal As Long) Dim sData As String Client.GetData sData ' Parse join group request, format: "JOIN_GROUP:groupname" If Left$(sData, 11) = "JOIN_GROUP:" Then Dim sGroup As String sGroup = Mid$(sData, 12) ' Check if user is bound If LenB(CStr(Client.CurrentUser)) = 0 Then Client.SendData "ERROR: Please login first" Exit Sub End If ' Join group m_oServer.BindGroup sGroup, Client Client.SendData "JOIN_GROUP:OK:" & sGroup Debug.Print Client.CurrentUser & " joined group: " & sGroup End If End Sub ``` #### Multiple Joins to Same Group Same user can call `BindGroup` multiple times for same group, but won't be added duplicate times. *** ### ExistsGroup Method #### Description Check if specified group exists. #### Syntax ```vb Public Function ExistsGroup(ByVal GroupName As String) As Boolean ``` #### Usage Example ```vb If m_oServer.ExistsGroup("admins") Then Debug.Print "Admin group exists, member count: " & m_oServer.GetGroupMembers("admins").Count Else Debug.Print "Admin group doesn't exist" End If ``` *** ### UnbindGroup Method #### Description Remove user from specified group. #### Syntax ```vb Public Sub UnbindGroup(ByVal GroupName As String, ByVal User As Variant) ``` #### Usage Example ```vb ' Remove user from group m_oServer.UnbindGroup "admins", "alice" ' Group leader kicks user Private Sub m_oServer_DataArrival(Client As cWinsock, ByVal bytesTotal As Long) Dim sData As String Client.GetData sData If Left$(sData, 13) = "KICK_FROM_GROUP" Then Dim sGroup As String, sTarget As String sGroup = Mid$(sData, 14, InStr(sData, ":") - 14) sTarget = Mid$(sData, InStr(sData, ":") + 1) m_oServer.UnbindGroup sGroup, sTarget Debug.Print sTarget & " removed from group: " & sGroup End If End Sub ``` #### Auto Cleanup When all members leave a group, the group is automatically deleted. *** ### GetGroupMembers Method #### Description Get list of all member usernames in specified group. #### Syntax ```vb Public Function GetGroupMembers(ByVal GroupName As String) As String() ``` #### Return Value Returns string array containing all member usernames. Returns empty array if group doesn't exist or is empty. #### Usage Example ```vb Dim aMembers() As String Dim sMember As String aMembers = m_oServer.GetGroupMembers("admins") If UBound(aMembers) >= 0 Then Debug.Print "Admin group has " & (UBound(aMembers) + 1) & " members:" For Each sMember In aMembers Debug.Print " - " & sMember Next Else Debug.Print "Admin group is empty" End If ``` *** ### SendToGroup Method #### Description Send data to all members in specified group. #### Syntax ```vb Public Sub SendToGroup(ByVal GroupName As String, Data As Variant, Optional ByVal CodePage As EnumScpCodePage = wcpAcp) ``` #### Parameters | Parameter | Type | Description | |-----------|------|-------------| | `GroupName` | String | Group name | | `Data` | Variant | Data to send | | `CodePage` | EnumScpCodePage (optional) | Text encoding | #### Usage Example ```vb ' Send group message m_oServer.SendToGroup "developers", "Colleagues, tech sharing at 3pm today" ' Broadcast system announcement to all groups Dim sGroup As Variant For Each sGroup In m_oServer.m_Groups.Keys m_oServer.SendToGroup CStr(sGroup), "[System] Server will restart in 10 minutes" Next ``` #### Smart Handling * If group doesn't exist, no data is sent * If some users in group are offline, they're automatically skipped, only online users receive *** ### GetUserGroups Method #### Description Get list of all groups that specified user belongs to. #### Syntax ```vb Public Function GetUserGroups(ByVal User As Variant) As String() ``` #### Return Value Returns string array containing all group names. #### Usage Example ```vb ' View groups user belongs to Dim aGroups() As String Dim sGroup As String aGroups = m_oServer.GetUserGroups("alice") If UBound(aGroups) >= 0 Then Debug.Print "alice belongs to the following groups:" For Each sGroup In aGroups Debug.Print " - " & sGroup Next Else Debug.Print "alice is not in any groups" End If ``` *** ### DeleteGroup Method #### Description Disband specified group, synchronously deletes the group from all members' `CurrentGroups`. #### Syntax ```vb Public Sub DeleteGroup(ByVal GroupName As String) ``` #### Usage Example ```vb ' Disband group m_oServer.DeleteGroup "temp_group" Debug.Print "Group disbanded" ' Admin disbands group Private Sub m_oServer_DataArrival(Client As cWinsock, ByVal bytesTotal As Long) Dim sData As String Client.GetData sData If Left$(sData, 12) = "DELETE_GROUP" Then Dim sGroup As String sGroup = Mid$(sData, 14) If m_oServer.ExistsGroup(sGroup) Then m_oServer.DeleteGroup sGroup Debug.Print "Group " & sGroup & " has been disbanded" End If End If End Sub ``` #### Sync Mechanism When disbanding a group, system automatically iterates all group members, removing the group name from each member's `CurrentGroups`. *** ### CloseUser Method #### Description Force specified user offline, close their client connection. #### Syntax ```vb Public Sub CloseUser(ByVal User As Variant) ``` #### Usage Example ```vb ' Kick specified user offline m_oServer.CloseUser "alice" Debug.Print "User offline" ' Admin kicks user Private Sub m_oServer_DataArrival(Client As cWinsock, ByVal bytesTotal As Long) Dim sData As String Client.GetData sData If Left$(sData, 5) = "KICK:" Then Dim sTarget As String sTarget = Mid$(sData, 6) If m_oServer.ExistsUser(sTarget) Then m_oServer.CloseUser sTarget Debug.Print sTarget & " has been kicked by admin" End If End If End Sub ``` #### Cleanup Flow Calling `CloseUser` triggers client's `Class_Terminate`, automatically completing the following cleanup: * Unbind from all groups * Remove from user list * Clear `CurrentGroups` *** ## Internal Methods The following methods are for internal use, usually don't need to be called directly: ### UnbindUserFromAllGroups Unbind user from all groups (called by `Class_Terminate`, automatically triggered when user disconnects). Syncs client `CurrentGroups`. *** ## Data Structure and Sync Mechanism ### Server-side Storage Structure ``` m_Users (Dictionary) └── Username → cWinsock client instance m_Groups (Dictionary) └── Group name → Dictionary(Username → True) ``` ### Client Instance Properties ``` CurrentUser (Variant) └── Bound username CurrentUserToken (String) └── User auth token (Token passed when BindUser) CurrentUserInfo (cJson) └── User extended info (Info passed when BindUser) CurrentGroups (Dictionary) └── Group name → True ``` ### Bidirectional Sync All group operations automatically sync server-side and client-side data: | Operation | Server-side | Client-side | |-----------|-------------|-------------| | `BindGroup` | Add to `m_Groups[groupName]` | Add to `CurrentGroups` | | `UnbindGroup` | Remove from `m_Groups[groupName]` | Remove from `CurrentGroups` | | `DeleteGroup` | Delete `m_Groups[groupName]` | Remove from all members' `CurrentGroups` | | `UnbindUserFromAllGroups` | Remove user from all groups | Clear `CurrentGroups` | *** ## Auto Cleanup Mechanism ### Cleanup Flow When User Disconnects When client disconnects, system automatically executes the following cleanup: ``` 1. Client Close_() or Class_Terminate() is called 2. Check if CurrentUser is empty 3. If not empty: a. Call UnbindUserFromAllGroups() to remove from all groups b. Call UnbindUser() to remove from user list c. Clear CurrentGroups d. Clear CurrentUser e. Clear CurrentUserToken (set to empty string) f. Clear CurrentUserInfo (call Clear) ``` ### Memory Management Notes User binding uses Dictionary to store user and group references. To avoid memory leaks: 1. **Always bind/unbind through server object**: Don't directly operate internal `m_Users` and `m_Groups` 2. **Use RemoveClient**: Should call server's `RemoveClient` method when client disconnects 3. **Avoid circular references**: Server holds client reference, client holds parent server reference (via `ParentServer`) *** ## Complete Chat Server Example ```vb ' Complete server-side example Dim WithEvents m_oServer As cWinsock Private Sub Form_Load() Set m_oServer = New cWinsock m_oServer.Protocol = sckTCPProtocol m_oServer.Listen 8080 End Sub ' Handle connection request Private Sub m_oServer_ConnectionRequest(Client As cWinsock, ByRef DisConnect As Boolean) Debug.Print "New connection: " & Client.RemoteHostIP End Sub ' Handle data arrival Private Sub m_oServer_DataArrival(Client As cWinsock, ByVal bytesTotal As Long) Dim sData As String Client.GetData sData ' Parse command Select Case Left$(sData, InStr(sData, ":") - 1) Case "LOGIN" HandleLogin Client, Mid$(sData, 7) Case "JOIN_GROUP" HandleJoinGroup Client, Mid$(sData, 12) Case "MSG" HandleMessage Client, Mid$(sData, 5) Case "BROADCAST" HandleBroadcast Client, Mid$(sData, 11) End Select End Sub Private Sub HandleLogin(Client As cWinsock, ByVal sUsername As String) If m_oServer.ExistsUser(sUsername) Then Client.SendData "LOGIN:ERROR:User already logged in" Exit Sub End If ' Bind user, with Token and extended info Dim oInfo As New cJson oInfo.Add "loginTime", Now oInfo.Add "ip", Client.RemoteHostIP m_oServer.BindUser sUsername, Client, "secret_token_123", oInfo Client.SendData "LOGIN:OK" Debug.Print sUsername & " logged in, Token: " & Client.CurrentUserToken End Sub Private Sub HandleJoinGroup(Client As cWinsock, ByVal sGroup As String) If LenB(CStr(Client.CurrentUser)) = 0 Then Client.SendData "ERROR:Please login first" Exit Sub End If m_oServer.BindGroup sGroup, Client Client.SendData "JOIN_GROUP:OK:" & sGroup Debug.Print Client.CurrentUser & " joined group: " & sGroup End Sub Private Sub HandleMessage(Client As cWinsock, ByVal sMsg As String) If LenB(CStr(Client.CurrentUser)) = 0 Then Client.SendData "ERROR:Please login first" Exit Sub End If ' Send message to all group members m_oServer.SendToGroup "general", Client.CurrentUser & ": " & sMsg End Sub Private Sub HandleBroadcast(Client As cWinsock, ByVal sMsg As String) If LenB(CStr(Client.CurrentUser)) = 0 Then Client.SendData "ERROR:Please login first" Exit Sub End If ' Broadcast to all groups Dim sGroup As Variant For Each sGroup In m_oServer.m_Groups.Keys m_oServer.SendToGroup CStr(sGroup), "[Broadcast] " & Client.CurrentUser & ": " & sMsg Next End Sub ' Handle client disconnect Private Sub m_oServer_CloseEvent(Client As cWinsock) If LenB(CStr(Client.CurrentUser)) <> 0 Then Debug.Print Client.CurrentUser & " is offline" ' No need to manually unbind, system handles automatically End If End Sub ``` *** **Last Updated**: 2026-04-26 --- --- url: /en/vbman2/webview2/bindui.md --- # Data Binding Guide - BindUI / BindData / SetData ## 📖 Table of Contents * [Overview](#overview) * [Architecture Principles](#architecture-principles) * [BindUI - Event Binding](#bindui---event-binding) * [BindData - Data Binding](#binddata---data-binding) * [SetData - Data Pushing](#setdata---data-pushing) * [Auto-Rebuild After Navigation](#auto-rebuild-after-navigation) * [Complete Example](#complete-example) * [FAQ](#faq) *** ## Overview The data binding system in cWebView2Host is a **declarative** VB6-Web two-way communication mechanism that eliminates the need for manually writing JSON message parsing, DOM manipulation, or event listener glue code. ### ✨ Core Features * 🔗 **Two-Way Binding** - BindUI (UI→Host) + BindData (Host→UI) covers bidirectional communication * 📝 **Declarative** - One binding declaration replaces extensive glue code * 🔄 **Auto-Rebuild** - Binding logic is automatically re-injected after page navigation * 🎯 **CSS Selectors** - Standard CSS selectors for locating DOM elements * 📦 **Batch Operations** - SetDataBatch pushes multiple data values at once *** ## Architecture Principles ### System Composition ``` cWebView2Host.BindUI() / BindData() / SetData() │ ▼ WebView2BindUIProxy (COM object, exposed as JS global object bindUIProxy) │ ├── BindUI: JS addEventListener → bindUIProxy.onEvent(bindId, eventName, detail) │ └── CallByName(HostInst, MethodName, vbMethod, EventName, Detail) │ ├── BindData: SetData → JS loop through binding list → element[attr] = value │ └── Navigation rebuild: DOMContentLoaded → inject rebind JS → restore all BindUI + BindData + DataValue ``` ### Workflow ``` 1. VB6 calls BindUI/BindData → Register bindings in WebView2BindUIProxy internal collection 2. GetJsCode() → Load ProxyBindUI.js / ProxyMouseEvents.js from embedded resources 3. GetBindAddJs() → Generate addEventListener JS code 4. ExecuteScript() → Inject and execute binding code in WebView2 5. DOM event fires → JS calls bindUIProxy.onEvent() → CallByName → VB6 method callback 6. SetData call → Generate JS code → Iterate binding list → Update DOM attributes ``` *** ## BindUI - Event Binding ### Basic Usage ```vb ' Bind #submit-btn click event to Me.OnButtonClick wv.BindUI Me, "OnButtonClick", "#submit-btn" ``` After declaration, when the user clicks the `#submit-btn` element in WebView2, VB6 automatically calls the `OnButtonClick` method. ### Host Method Signature All BindUI callback methods must follow this signature: ```vb Public Sub OnButtonClick(ByVal EventName As String, ByVal Detail As String) ' EventName: The DOM event name that fired (e.g., "click", "input", "change") ' Detail: JSON-formatted event details End Sub ``` ### Detail Parameter Parsing Detail is a JSON string whose content depends on the DOM event type. Common event Detail structures: | Event | Detail Example | |-------|----------------| | click | `{"type":"click","target":"#btn"}` | | input | `{"type":"input","value":"User input text"}` | | change | `{"type":"change","value":"new value","checked":true}` | Since VB6 has no built-in JSON parser, simple string processing is typically used: ```vb Public Sub OnNameInput(ByVal EventName As String, ByVal Detail As String) ' Simple value field extraction Dim val As String val = JsonValue(Detail, "value") wv.SetData "name", val End Sub ' Simple JSON value extraction helper function Private Function JsonValue(ByVal Json As String, ByVal Key As String) As String Dim pos As Long pos = InStr(Json, """" & Key & """:""") If pos > 0 Then pos = pos + Len(Key) + 3 Dim endPos As Long endPos = InStr(pos, Json, """") If endPos > 0 Then JsonValue = Mid(Json, pos, endPos - pos) End If End If End Function ``` ### Custom Event Names Click event is bound by default; specify other events via the EventName parameter: ```vb ' Bind input event (real-time text input response) wv.BindUI Me, "OnNameInput", "#name-input", EventName:="input" ' Bind change event (select/checkbox value change) wv.BindUI Me, "OnToggle", "#toggle-enabled", EventName:="change" ' Bind submit event wv.BindUI Me, "OnFormSubmit", "#my-form", EventName:="submit" ``` ### Multi-Element Binding ```vb ' Multiple buttons bound to different methods wv.BindUI Me, "OnSave", "#btn-save" wv.BindUI Me, "OnCancel", "#btn-cancel" wv.BindUI Me, "OnReset", "#btn-reset" ' Same element, different events bound to different methods wv.BindUI Me, "OnFocus", "#input", EventName:="focus" wv.BindUI Me, "OnBlur", "#input", EventName:="blur" ``` ### Removing Bindings ```vb ' Remove all event bindings for specified element wv.UnbindUI "#submit-btn" ' Remove only a specific event binding for the element wv.UnbindUI "#name-input", "input" ``` *** ## BindData - Data Binding ### Principles BindData binds a **data key name** to a **DOM element's specific attribute**. When `SetData` updates the key name, all DOM element attributes bound to that key are automatically updated. ### Supported DOM Attributes | Attribute | Description | Example | |-----------|-------------|---------| | `textContent` | Element text content (default) | Labels, paragraphs | | `value` | Form element value | input, textarea, select | | `innerHTML` | Element inner HTML | Dynamic HTML rendering | | `src` | Resource source | img, video, iframe | | `class` | CSS class name | State style switching | | `checked` | Checked state | checkbox, radio | | `visible` | Show/hide (custom) | Any element | | Other attributes | Directly set DOM attribute | href, disabled, style, etc. | ### Basic Usage ```vb ' Bind data key to element attribute wv.BindData "name", "#name-input", "value" wv.BindData "message", "#msg-display", "textContent" ' Same key bound to multiple elements/attributes wv.BindData "name", "#name-input", "value" wv.BindData "name", "#name-preview", "textContent" ' Same data, different attribute ' Bind to special attributes wv.BindData "enabled", "#toggle", "checked" ' checkbox wv.BindData "enabled", "#panel", "visible" ' show/hide wv.BindData "avatar", "#avatar-img", "src" ' image URL wv.BindData "status", "#status-dot", "class" ' CSS class name wv.BindData "items", "#list", "innerHTML" ' HTML fragment ``` ### visible Attribute `visible` is a virtual attribute custom to cWebView2Host that controls DOM element visibility: ```vb wv.BindData "showPanel", "#settings-panel", "visible" ' When showPanel = True, JS sets element.style.display = '' ' When showPanel = False, JS sets element.style.display = 'none' ``` ### class Attribute The `class` attribute replaces the element's entire CSS class name: ```vb wv.BindData "statusOnline", "#status-dot", "class" wv.SetData "statusOnline", "dot online" ' Green online status wv.SetData "statusOnline", "dot offline" ' Gray offline status ``` *** ## SetData - Data Pushing ### SetData Push a single data value. Supports String, Boolean, and Number types: ```vb wv.SetData "name", "Zhang Wei" ' String wv.SetData "enabled", True ' Boolean wv.SetData "count", 42 ' Number wv.SetData "avatar", "https://example.com/a.png" ' URL string ``` **Type Conversion Rules**: * VB6 `String` → JS string (auto-quoted) * VB6 `Boolean` → JS boolean (true/false) * VB6 numeric types → JS number (passed directly) ### SetDataBatch Batch push multiple data values; parameter is a JSON object string: ```vb wv.SetDataBatch "{""name"":""Zhang Wei"",""enabled"":true,""count"":42}" ``` Suitable for pushing all data at once during page initialization. *** ## Auto-Rebuild After Navigation When WebView2 navigates to a new page, previously injected JavaScript binding code is destroyed. cWebView2Host handles this automatically: ### Rebuild Mechanism 1. After each navigation triggers DOMContentLoaded, rebuild is automatically triggered 2. `GetReattachJs()` generates JS code to rebuild all bindings 3. Rebuild includes: BindUI event listeners + BindData declarations + DataValue current values ### DataValue Persistence Values pushed by `SetData` are automatically stored in the `m_DataValues` collection. After page navigation, these values are automatically re-applied to the DOM: ```vb ' First navigation wv.SetData "name", "Zhang Wei" ' User clicks a link to navigate to a new page ' → DOMContentLoaded triggers auto-rebuild ' → "name" key's value "Zhang Wei" is automatically re-applied ``` *** ## Complete Example The following example demonstrates the complete cooperation of BindUI/BindData/SetData: ### VB6 Code ```vb Dim WithEvents wv As cWebView2Host Private Sub Form_Load() Set wv = New cWebView2Host wv.Initialize Me.hWnd, App.Path & "\www" End Sub Private Sub wv_Ready() ' === Host -> UI Data Binding === wv.BindData "name", "#name-input", "value" wv.BindData "name", "#name-preview", "textContent" wv.BindData "enabled", "#toggle-enabled", "checked" wv.BindData "enabled", "#settings-panel", "visible" wv.BindData "avatar", "#avatar", "src" wv.BindData "count", "#msg-count", "textContent" wv.BindData "statusOnline", "#status-dot", "class" ' === UI -> Host Event Binding === wv.BindUI Me, "OnNameInput", "#name-input", EventName:="input" wv.BindUI Me, "OnToggle", "#toggle-enabled", EventName:="change" wv.BindUI Me, "OnIncMsg", "#btn-inc" wv.BindUI Me, "OnResetMsg", "#btn-reset" ' === Push Initial Data === wv.SetData "name", "Zhang Wei" wv.SetData "enabled", True wv.SetData "count", 0 Me.Caption = wv.DocumentTitle End Sub ' === UI Callback Methods === Public Sub OnNameInput(ByVal EventName As String, ByVal Detail As String) Dim val As String val = JsonValue(Detail, "value") wv.SetData "name", val ' Push back to UI End Sub Public Sub OnToggle(ByVal EventName As String, ByVal Detail As String) ' Detail example: {"type":"change","checked":true} Dim checked As Boolean checked = (InStr(Detail, """checked"":true") > 0) wv.SetData "enabled", checked End Sub Public Sub OnIncMsg(ByVal EventName As String, ByVal Detail As String) Dim count As Long count = Val(wv.JsProp("document.querySelector('#msg-count').textContent")) wv.SetData "count", count + 1 End Sub Public Sub OnResetMsg(ByVal EventName As String, ByVal Detail As String) wv.SetData "count", 0 End Sub ``` ### HTML Page ```html

    Hello, -!

    Settings content here

    0 messages
    ``` *** ## FAQ ### ❓ Q1: BindUI callback not being triggered? **Symptom**: Event is bound but VB6 method is not called. **Reason**: 1. Host method must be declared as `Public` (not Private) 2. Host method signature must exactly match `(ByVal EventName As String, ByVal Detail As String)` 3. Binding must be executed in `wv_Ready` event or later, not in `Form_Load` **Solution**: ```vb ' Correct Public Sub OnClick(ByVal EventName As String, ByVal Detail As String) ' Incorrect Private Sub OnClick(ByVal EventName As String, ByVal Detail As String) ' Cannot be Private Public Sub OnClick() ' Parameter signature mismatch ``` *** ### ❓ Q2: Original styles lost when using BindData with class attribute? **Symptom**: After using `BindData "key", "#element", "class"`, the element's original CSS classes are overwritten. **Reason**: The `class` attribute directly replaces the element's entire className, it does not append. **Solution**: Compose the full class name before calling SetData: ```vb wv.SetData "statusClass", "card " & IIf(isActive, "active", "inactive") ``` *** ### ❓ Q3: Bindings stop working after page navigation? **Symptom**: After clicking a link and navigating to a new page, bindings no longer work. **Reason**: cWebView2Host automatically rebuilds bindings on DOMContentLoaded, but if the new page has a different DOM structure (selectors don't match elements), bindings silently fail. **Solution**: 1. Ensure all pages have consistent DOM IDs/selectors 2. Or re-execute bindings after navigation *** ### ❓ Q4: How to pass complex objects with SetData? **Symptom**: Need to pass arrays or objects to JS. **Reason**: SetData's Value is Variant, internally converted to JS literal. Complex types need to be serialized to JSON string and use innerHTML or custom JS processing. **Solution**: ```vb ' Method 1: Use innerHTML to render a list wv.BindData "items", "#item-list", "innerHTML" wv.SetData "items", "
  • Item 1
  • Item 2
    • " ' Method 2: Directly call JS function to process JSON wv.JsRun "renderItems(" & jsonString & ")" ``` *** **Last Updated**: 2026-06-24 --- --- url: /en/vbman/httpserver/database.md --- # Database Integration ## Overview HttpServer has built-in `cDataBase` integration, allowing direct database access in controllers. ## Configure Database ```vb Private Sub Form_Load() Set Server = New cHttpServer ' Method 1: Configure before starting If Server.Database.Connect(enumDbType.Mysql, "localhost,3306", "root", "password", "mydb") Then Debug.Print "Database connection successful" End If ' Method 2: Using connection string (advanced) ' Server.Database.ConnectionString = "..." Call Server.Start(8080, "C:\WebRoot") End Sub ``` ## Using Database in Controllers ### Basic Query ```vb ' cUserController.cls ' GET /api/users Public Sub List(ctx As cHttpServerContext) Dim sql As String sql = "SELECT id, username, email FROM users LIMIT 100" If ctx.Db.Sql(sql).Fetch Then ctx.Response.Json ctx.Db.Rows, 0, "Success", ctx.Db.Rows.Count Else ctx.Response.State500 "Query failed: " & ctx.Db.LastErr End If End Sub ' GET /api/user?id=123 Public Sub Detail(ctx As cHttpServerContext) Dim id As String id = ctx.Request.QueryString("id") ' Parameterized query to prevent SQL injection If ctx.Db.Sql("SELECT * FROM users WHERE id=?") _ .Param("id", id, adVarChar) _ .Fetch Then If ctx.Db.Rows.Count > 0 Then ctx.Response.Json ctx.Db.Rows(1) Else ctx.Response.State404 "User not found" End If Else ctx.Response.State500 "Query failed" End If End Sub ``` ### Paginated Query ```vb ' GET /api/users?page=1&limit=20 Public Sub ListPaged(ctx As cHttpServerContext) Dim page As Long, limit As Long page = CLng(ctx.Request.QueryString("page")) limit = CLng(ctx.Request.QueryString("limit")) If page < 1 Then page = 1 If limit < 1 Or limit > 100 Then limit = 20 Dim offset As Long offset = (page - 1) * limit ' Get total count Dim total As Long total = ctx.Db.Count("users") ' Paginated query Dim sql As String sql = "SELECT id, username, email FROM users LIMIT " & limit & " OFFSET " & offset If ctx.Db.Sql(sql).Fetch Then Dim result As New Dictionary result("items") = ctx.Db.Rows result("total") = total result("page") = page result("limit") = limit ctx.Response.Json result, 0, "Success", total Else ctx.Response.State500 "Query failed" End If End Sub ``` ### Insert Data ```vb ' POST /api/users Public Sub Create(ctx As cHttpServerContext) Dim username As String, email As String username = ctx.Request.Form("username") email = ctx.Request.Form("email") ' Parameterized insert Dim sql As String sql = "INSERT INTO users (username, email, created_at) VALUES (?, ?, NOW())" If ctx.Db.Sql(sql) _ .Param("username", username, adVarChar) _ .Param("email", email, adVarChar) _ .ExecParam Then Dim newId As Long newId = ctx.Db.LastInsertId Dim result As New Dictionary result("id") = newId result("username") = username ctx.Response.Json result, 0, "Created successfully" Else ctx.Response.State500 "Creation failed: " & ctx.Db.LastErr End If End Sub ``` ### Transaction Processing ```vb ' POST /api/transfer Public Sub Transfer(ctx As cHttpServerContext) Dim fromUser As String, toUser As String Dim amount As Currency fromUser = ctx.Request.Form("from") toUser = ctx.Request.Form("to") amount = CCur(ctx.Request.Form("amount")) ' Start transaction If Not ctx.Db.TransBegin Then ctx.Response.State500 "Failed to start transaction" Exit Sub End If On Error GoTo Rollback ' Deduct from sender If Not ctx.Db.Sql("UPDATE accounts SET balance = balance - ? WHERE user_id = ?") _ .Param("amount", amount, adCurrency) _ .Param("user_id", fromUser, adVarChar) _ .ExecParam Then GoTo Rollback End If ' Add to receiver If Not ctx.Db.Sql("UPDATE accounts SET balance = balance + ? WHERE user_id = ?") _ .Param("amount", amount, adCurrency) _ .Param("user_id", toUser, adVarChar) _ .ExecParam Then GoTo Rollback End If ' Log transaction If Not ctx.Db.Sql("INSERT INTO transactions (from_user, to_user, amount) VALUES (?, ?, ?)") _ .Param("from", fromUser, adVarChar) _ .Param("to", toUser, adVarChar) _ .Param("amount", amount, adCurrency) _ .ExecParam Then GoTo Rollback End If ' Commit transaction If ctx.Db.TransCommit Then ctx.Response.Json Nothing, 0, "Transfer successful" Else GoTo Rollback End If Exit Sub Rollback: ctx.Db.TransRollback ctx.Response.State500 "Transfer failed: " & ctx.Db.LastErr End Sub ``` ### Join Query ```vb ' GET /api/orders?user_id=123 Public Sub GetOrders(ctx As cHttpServerContext) Dim userId As String userId = ctx.Request.QueryString("user_id") Dim sql As String sql = "SELECT o.id, o.total, u.username, u.email " & _ "FROM orders o " & _ "JOIN users u ON o.user_id = u.id " & _ "WHERE o.user_id = ? " & _ "ORDER BY o.created_at DESC" If ctx.Db.Sql(sql) _ .Param("user_id", userId, adVarChar) _ .Fetch Then ctx.Response.Json ctx.Db.Rows, 0, "Success" Else ctx.Response.State500 "Query failed" End If End Sub ``` ## Data Model Encapsulation ```vb ' cUserModel.cls Option Explicit Private Db As cDataBase Public Sub Init(database As cDataBase) Set Db = database End Sub ' Query by ID Public Function FindById(id As String) As Dictionary If Db.Sql("SELECT * FROM users WHERE id=?") _ .Param("id", id, adVarChar) _ .Fetch Then If Db.Rows.Count > 0 Then Set FindById = Db.Rows(1) End If End If End Function ' Query by username Public Function FindByUsername(username As String) As Dictionary If Db.Sql("SELECT * FROM users WHERE username=?") _ .Param("username", username, adVarChar) _ .Fetch Then If Db.Rows.Count > 0 Then Set FindByUsername = Db.Rows(1) End If End If End Function ' Create user Public Function Create(data As Dictionary) As Long If Db.Sql("INSERT INTO users (username, email, password) VALUES (?, ?, ?)") _ .Param("username", data("username"), adVarChar) _ .Param("email", data("email"), adVarChar) _ .Param("password", data("password"), adVarChar) _ .ExecParam Then Create = Db.LastInsertId End If End Function ' Update user Public Function Update(id As String, data As Dictionary) As Boolean Dim fields As String Dim first As Boolean: first = True Dim key As Variant For Each key In data.Keys If Not first Then fields = fields & ", " fields = fields & key & "=?" first = False Next Dim sql As String sql = "UPDATE users SET " & fields & " WHERE id=?" Dim q As Object Set q = Db.Sql(sql) For Each key In data.Keys q.Param CStr(key), data(key), adVarChar Next q.Param "id", id, adVarChar Update = q.ExecParam End Function ' Delete user Public Function Delete(id As String) As Boolean Delete = Db.Sql("DELETE FROM users WHERE id=?") _ .Param("id", id, adVarChar) _ .ExecParam End Function ``` ## Using Models in Controllers ```vb ' cUserController.cls Dim UserModel As cUserModel Private Sub Class_Initialize() Set UserModel = New cUserModel End Sub Public Sub Detail(ctx As cHttpServerContext) Call UserModel.Init(ctx.Db) Dim id As String id = ctx.Request.QueryString("id") Dim user As Dictionary Set user = UserModel.FindById(id) If Not user Is Nothing Then ctx.Response.Json user Else ctx.Response.State404 "User not found" End If End Sub Public Sub Create(ctx As cHttpServerContext) Call UserModel.Init(ctx.Db) Dim data As New Dictionary data("username") = ctx.Request.Form("username") data("email") = ctx.Request.Form("email") data("password") = HashPassword(ctx.Request.Form("password")) Dim newId As Long newId = UserModel.Create(data) If newId > 0 Then ctx.Response.Json newId, 0, "Created successfully" Else ctx.Response.State500 "Creation failed" End If End Sub ``` *** **Last Updated**: 2026-05-17 --- --- url: /zh/vbman/delay/methods.md --- # Delay 方法参考 ## 📋 方法列表 | 方法 | 说明 | |------|------| | `Callback` | 设置回调模式（链式调用） | | `Sync` | 设置同步等待模式（链式调用） | | `CountDown` | 开始倒计时 | | `Cancel` | 取消延时 | *** ## 🔗 Callback 方法 ### 说明 设置回调模式，延时结束后自动调用指定对象的指定方法。支持最多9个参数。 ### 语法 ```vb Public Function Callback(ByVal CallbackObject As Object, ByVal ProcName As String, ParamArray P()) As cDelay ``` ### 参数 | 参数 | 类型 | 说明 | |------|------|------| | `CallbackObject` | Object | 回调方法所在的对象 | | `ProcName` | String | 回调方法名称 | | `P()` | ParamArray | 可变参数，最多9个 | ### 返回值 返回自身对象，支持链式调用。 ### 使用示例 #### 无参数回调 ```vb Private Delay As cDelay Private Sub Test1() Set Delay = New cDelay Delay.Callback(Me, "DoSomething").CountDown 1000 End Sub Public Sub DoSomething() Debug.Print "执行了！" End Sub ``` #### 带参数回调 ```vb Private Sub Test2() Set Delay = New cDelay Delay.Callback(Me, "ProcessData", "用户名", 25, True).CountDown 2000 End Sub Public Sub ProcessData(ByVal name As String, ByVal age As Long, ByVal active As Boolean) Debug.Print name & ", " & age & ", " & active End Sub ``` *** ## ⏱️ Sync 方法 ### 说明 设置同步等待模式，调用 `CountDown` 后会阻塞等待，但会处理消息队列，不卡UI。 ### 语法 ```vb Public Function Sync() As cDelay ``` ### 返回值 返回自身对象，支持链式调用。 ### 使用示例 ```vb Private Sub TestSync() Dim Delay As New cDelay Debug.Print "开始: " & Now Delay.Sync().CountDown 3000 ' 等待3秒 Debug.Print "结束: " & Now ' 3秒后执行 End Sub ``` ### ⚠️ 注意事项 * 同步模式下可以通过 `Cancel` 方法取消等待 * 可以通过 `IsCancelled` 属性判断是被取消还是正常完成 * 等待期间会处理消息队列，UI不会卡顿 *** ## ▶️ CountDown 方法 ### 说明 开始倒计时。根据当前模式决定行为： * 事件/回调模式：启动Windows定时器 * 同步模式：进入消息循环等待 ### 语法 ```vb Public Sub CountDown(ByVal Milliseconds As Long) ``` ### 参数 | 参数 | 类型 | 说明 | |------|------|------| | `Milliseconds` | Long | 延时毫秒数 | ### 使用示例 ```vb ' 事件模式 Delay.CountDown 5000 ' 5秒后触发 OnTime 事件 ' 回调模式（需要先调用Callback） Delay.Callback(Me, "OnDelay").CountDown 3000 ' 同步模式（需要先调用Sync） Delay.Sync().CountDown 2000 ``` *** ## ❌ Cancel 方法 ### 说明 取消当前的延时操作。停止定时器并触发 `OnCancel` 事件。 ### 语法 ```vb Public Sub Cancel() ``` ### 使用示例 ```vb Private WithEvents Delay As cDelay Private Sub cmdStart_Click() Set Delay = New cDelay Delay.CountDown 10000 ' 10秒延时 End Sub Private Sub cmdCancel_Click() Delay.Cancel ' 取消延时 End Sub Private Sub Delay_OnCancel() Debug.Print "延时被取消" End Sub ``` *** ## 📌 使用场景总结 ### 延时执行操作 ```vb ' 3秒后执行清理 Delay.Callback(Me, "DoCleanup").CountDown 3000 ``` ### 延时等待（保持UI响应） ```vb Private Sub LongOperation() ' 第一步 DoStep1 ' 等待2秒（UI不卡顿） Delay.Sync().CountDown 2000 ' 第二步 DoStep2 End Sub ``` ### 可取消的延时 ```vb Private Sub StartDelayedTask() Set Delay = New cDelay Delay.CountDown 5000 End Sub Private Sub CancelTask() If Not Delay Is Nothing Then Delay.Cancel End If End Sub Private Sub Delay_OnTime() Debug.Print "延时任务执行" End Sub Private Sub Delay_OnCancel() Debug.Print "延时任务被取消" End Sub ``` *** **最后更新**: 2026-05-17 --- --- url: /zh/vbman/delay/properties.md --- # Delay 属性参考 ## 📋 属性列表 | 属性 | 类型 | 读写 | 说明 | |------|------|------|------| | `Mode` | DelayMode | 只读 | 当前工作模式 | | `IsActive` | Boolean | 只读 | 是否正在延时 | | `IsCancelled` | Boolean | 只读 | 是否被取消（同步模式） | | `DelayMs` | Long | 只读 | 延时毫秒数 | *** ## 🔄 Mode 属性 ### 说明 获取当前的工作模式。 ### 语法 ```vb Public Property Get Mode() As DelayMode ``` ### 返回值 | 值 | 常量 | 说明 | |----|------|------| | 0 | `dmEvent` | 事件触发模式 | | 1 | `dmCallback` | 回调函数模式 | | 2 | `dmSync` | 同步等待模式 | ### 使用示例 ```vb Private Sub CheckMode() Select Case Delay.Mode Case dmEvent Debug.Print "事件模式" Case dmCallback Debug.Print "回调模式" Case dmSync Debug.Print "同步模式" End Select End Sub ``` *** ## ✅ IsActive 属性 ### 说明 获取当前是否正在进行延时。 ### 语法 ```vb Public Property Get IsActive() As Boolean ``` ### 返回值 * `True` - 延时正在进行中 * `False` - 延时未开始或已结束 ### 使用示例 ```vb Private Sub StartDelay() If Delay.IsActive Then Debug.Print "延时已在进行中" Exit Sub End If Delay.CountDown 3000 End Sub ``` *** ## 🚫 IsCancelled 属性 ### 说明 获取同步模式下是否被取消。仅在同步模式下有效。 ### 语法 ```vb Public Property Get IsCancelled() As Boolean ``` ### 返回值 * `True` - 延时被取消 * `False` - 延时正常完成 ### 使用示例 ```vb Private Sub TestSyncWithCancel() Dim Delay As New cDelay ' 启动延时，可以通过 Cancel 方法取消 Delay.Sync().CountDown 10000 ' 检查是否被取消 If Delay.IsCancelled Then Debug.Print "用户取消了操作" Else Debug.Print "延时正常完成" End If End Sub ``` *** ## ⏱️ DelayMs 属性 ### 说明 获取设置的延时毫秒数。 ### 语法 ```vb Public Property Get DelayMs() As Long ``` ### 使用示例 ```vb Private Sub ShowDelayInfo() Debug.Print "延时设置: " & Delay.DelayMs & " 毫秒" End Sub ``` *** ## 📌 属性使用场景总结 ### 状态检查 ```vb If Delay.IsActive Then MsgBox "请等待当前延时结束" Else Delay.CountDown 3000 End If ``` ### 同步模式结果判断 ```vb Delay.Sync().CountDown 5000 If Delay.IsCancelled Then ' 用户取消了操作 Exit Sub End If ' 继续执行后续操作 ``` *** **最后更新**: 2026-05-17 --- --- url: /zh/vbman/delay/overview.md --- # Delay 延时组件概述 ## 📖 简介 `cDelay` 是一个延时对象类，支持三种工作模式：事件触发模式、回调函数模式和同步等待模式。适用于需要延时执行的各种场景。 ## ✨ 主要特性 | 特性 | 说明 | |------|------| | **三种工作模式** | 事件触发、回调函数、同步等待 | | **支持参数传递** | 回调模式支持最多9个参数 | | **UI不卡顿** | 同步模式使用消息泵，不阻塞UI | | **可取消** | 支持取消延时操作 | | **全局管理** | 自动管理全局资源和实例计数 | ## 🚀 快速开始 ### 事件模式（默认） ```vb Private WithEvents Delay As cDelay Private Sub Form_Load() Set Delay = New cDelay Delay.CountDown 3000 ' 3秒后触发 OnTime 事件 End Sub Private Sub Delay_OnTime() Debug.Print "延时结束！" End Sub ``` ### 回调模式 ```vb Private Delay As cDelay Private Sub TestCallback() Set Delay = New cDelay Delay.Callback(Me, "MyFunction", "参数1", 123).CountDown 2000 End Sub Public Sub MyFunction(ByVal p1 As String, ByVal p2 As Long) Debug.Print "回调执行: " & p1 & ", " & p2 End Sub ``` ### 同步等待模式 ```vb Private Delay As cDelay Private Sub TestSync() Set Delay = New cDelay Debug.Print "开始等待..." Delay.Sync().CountDown 3000 ' 等待3秒，不卡UI If Delay.IsCancelled Then Debug.Print "等待被取消" Else Debug.Print "等待完成" End If End Sub ``` ## 📋 工作模式对比 | 模式 | 枚举值 | 说明 | 适用场景 | |------|--------|------|----------| | 事件模式 | `dmEvent` | 通过 `OnTime` 事件触发 | 需要事件响应的UI操作 | | 回调模式 | `dmCallback` | 调用指定对象的指定方法 | 需要传递参数的场景 | | 同步模式 | `dmSync` | 阻塞等待但处理消息 | 顺序执行但保持UI响应 | ## 🔗 相关文档 * [methods.md](./methods.md) - 方法详细参考 * [properties.md](./properties.md) - 属性详细参考 *** **最后更新**: 2026-05-17 --- --- url: /en/vbman/delay/overview.md --- # Delay Component Overview ## 📖 Introduction `cDelay` is a delay object class that supports three working modes: event-triggered mode, callback function mode, and synchronous wait mode. Suitable for various scenarios requiring delayed execution. ## ✨ Key Features | Feature | Description | |---------|-------------| | **Three Working Modes** | Event-triggered, callback function, synchronous wait | | **Parameter Support** | Callback mode supports up to 9 parameters | | **UI Responsive** | Sync mode uses message pump, does not block UI | | **Cancellable** | Supports cancellation of delay operations | | **Global Management** | Automatically manages global resources and instance counting | ## 🚀 Quick Start ### Event Mode (Default) ```vb Private WithEvents Delay As cDelay Private Sub Form_Load() Set Delay = New cDelay Delay.CountDown 3000 ' Triggers OnTime event after 3 seconds End Sub Private Sub Delay_OnTime() Debug.Print "Delay ended!" End Sub ``` ### Callback Mode ```vb Private Delay As cDelay Private Sub TestCallback() Set Delay = New cDelay Delay.Callback(Me, "MyFunction", "param1", 123).CountDown 2000 End Sub Public Sub MyFunction(ByVal p1 As String, ByVal p2 As Long) Debug.Print "Callback executed: " & p1 & ", " & p2 End Sub ``` ### Synchronous Wait Mode ```vb Private Delay As cDelay Private Sub TestSync() Set Delay = New cDelay Debug.Print "Starting wait..." Delay.Sync().CountDown 3000 ' Wait 3 seconds, UI stays responsive If Delay.IsCancelled Then Debug.Print "Wait cancelled" Else Debug.Print "Wait completed" End If End Sub ``` ## 📋 Working Mode Comparison | Mode | Enum Value | Description | Use Case | |------|------------|-------------|----------| | Event Mode | `dmEvent` | Triggers via `OnTime` event | UI operations requiring event response | | Callback Mode | `dmCallback` | Calls specified method of specified object | Scenarios requiring parameter passing | | Sync Mode | `dmSync` | Blocks but processes messages | Sequential execution while keeping UI responsive | ## 🔗 Related Documentation * [methods.md](./methods.md) - Methods detailed reference * [properties.md](./properties.md) - Properties detailed reference *** **Last Updated**: 2026-05-17 --- --- url: /en/vbman/delay/methods.md --- # Delay Methods Reference ## 📋 Method List | Method | Description | |--------|-------------| | `Callback` | Set callback mode (chainable) | | `Sync` | Set synchronous wait mode (chainable) | | `CountDown` | Start countdown | | `Cancel` | Cancel delay | *** ## 🔗 Callback Method ### Description Sets callback mode. After delay ends, automatically calls the specified method of the specified object. Supports up to 9 parameters. ### Syntax ```vb Public Function Callback(ByVal CallbackObject As Object, ByVal ProcName As String, ParamArray P()) As cDelay ``` ### Parameters | Parameter | Type | Description | |-----------|------|-------------| | `CallbackObject` | Object | Object containing the callback method | | `ProcName` | String | Callback method name | | `P()` | ParamArray | Variable parameters, up to 9 | ### Return Value Returns the object itself for chainable calls. ### Example #### Callback Without Parameters ```vb Private Delay As cDelay Private Sub Test1() Set Delay = New cDelay Delay.Callback(Me, "DoSomething").CountDown 1000 End Sub Public Sub DoSomething() Debug.Print "Executed!" End Sub ``` #### Callback With Parameters ```vb Private Sub Test2() Set Delay = New cDelay Delay.Callback(Me, "ProcessData", "username", 25, True).CountDown 2000 End Sub Public Sub ProcessData(ByVal name As String, ByVal age As Long, ByVal active As Boolean) Debug.Print name & ", " & age & ", " & active End Sub ``` *** ## ⏱️ Sync Method ### Description Sets synchronous wait mode. After calling `CountDown`, it blocks and waits, but processes the message queue, so UI doesn't freeze. ### Syntax ```vb Public Function Sync() As cDelay ``` ### Return Value Returns the object itself for chainable calls. ### Example ```vb Private Sub TestSync() Dim Delay As New cDelay Debug.Print "Start: " & Now Delay.Sync().CountDown 3000 ' Wait 3 seconds Debug.Print "End: " & Now ' Executes after 3 seconds End Sub ``` ### ⚠️ Notes * In sync mode, wait can be cancelled via `Cancel` method * Use `IsCancelled` property to determine if cancelled or completed normally * Message queue is processed during wait, UI stays responsive *** ## ▶️ CountDown Method ### Description Starts countdown. Behavior depends on current mode: * Event/Callback mode: Starts Windows timer * Sync mode: Enters message loop wait ### Syntax ```vb Public Sub CountDown(ByVal Milliseconds As Long) ``` ### Parameters | Parameter | Type | Description | |-----------|------|-------------| | `Milliseconds` | Long | Delay milliseconds | ### Example ```vb ' Event mode Delay.CountDown 5000 ' Triggers OnTime event after 5 seconds ' Callback mode (need to call Callback first) Delay.Callback(Me, "OnDelay").CountDown 3000 ' Sync mode (need to call Sync first) Delay.Sync().CountDown 2000 ``` *** ## ❌ Cancel Method ### Description Cancels the current delay operation. Stops timer and triggers `OnCancel` event. ### Syntax ```vb Public Sub Cancel() ``` ### Example ```vb Private WithEvents Delay As cDelay Private Sub cmdStart_Click() Set Delay = New cDelay Delay.CountDown 10000 ' 10 second delay End Sub Private Sub cmdCancel_Click() Delay.Cancel ' Cancel delay End Sub Private Sub Delay_OnCancel() Debug.Print "Delay cancelled" End Sub ``` *** ## 📌 Usage Scenarios Summary ### Delayed Operation Execution ```vb ' Execute cleanup after 3 seconds Delay.Callback(Me, "DoCleanup").CountDown 3000 ``` ### Delayed Wait (Keep UI Responsive) ```vb Private Sub LongOperation() ' First step DoStep1 ' Wait 2 seconds (UI stays responsive) Delay.Sync().CountDown 2000 ' Second step DoStep2 End Sub ``` ### Cancellable Delay ```vb Private Sub StartDelayedTask() Set Delay = New cDelay Delay.CountDown 5000 End Sub Private Sub CancelTask() If Not Delay Is Nothing Then Delay.Cancel End If End Sub Private Sub Delay_OnTime() Debug.Print "Delayed task executed" End Sub Private Sub Delay_OnCancel() Debug.Print "Delayed task cancelled" End Sub ``` *** **Last Updated**: 2026-05-17 --- --- url: /en/vbman/delay/properties.md --- # Delay Properties Reference ## 📋 Property List | Property | Type | Read/Write | Description | |----------|------|------------|-------------| | `Mode` | DelayMode | Read-only | Current working mode | | `IsActive` | Boolean | Read-only | Whether delay is in progress | | `IsCancelled` | Boolean | Read-only | Whether cancelled (sync mode) | | `DelayMs` | Long | Read-only | Delay milliseconds | *** ## 🔄 Mode Property ### Description Gets the current working mode. ### Syntax ```vb Public Property Get Mode() As DelayMode ``` ### Return Value | Value | Constant | Description | |-------|----------|-------------| | 0 | `dmEvent` | Event-triggered mode | | 1 | `dmCallback` | Callback function mode | | 2 | `dmSync` | Synchronous wait mode | ### Example ```vb Private Sub CheckMode() Select Case Delay.Mode Case dmEvent Debug.Print "Event mode" Case dmCallback Debug.Print "Callback mode" Case dmSync Debug.Print "Sync mode" End Select End Sub ``` *** ## ✅ IsActive Property ### Description Gets whether a delay is currently in progress. ### Syntax ```vb Public Property Get IsActive() As Boolean ``` ### Return Value * `True` - Delay is in progress * `False` - Delay not started or already finished ### Example ```vb Private Sub StartDelay() If Delay.IsActive Then Debug.Print "Delay already in progress" Exit Sub End If Delay.CountDown 3000 End Sub ``` *** ## 🚫 IsCancelled Property ### Description Gets whether cancelled in synchronous mode. Only valid in sync mode. ### Syntax ```vb Public Property Get IsCancelled() As Boolean ``` ### Return Value * `True` - Delay was cancelled * `False` - Delay completed normally ### Example ```vb Private Sub TestSyncWithCancel() Dim Delay As New cDelay ' Start delay, can be cancelled via Cancel method Delay.Sync().CountDown 10000 ' Check if cancelled If Delay.IsCancelled Then Debug.Print "User cancelled operation" Else Debug.Print "Delay completed normally" End If End Sub ``` *** ## ⏱️ DelayMs Property ### Description Gets the configured delay milliseconds. ### Syntax ```vb Public Property Get DelayMs() As Long ``` ### Example ```vb Private Sub ShowDelayInfo() Debug.Print "Delay setting: " & Delay.DelayMs & " milliseconds" End Sub ``` *** ## 📌 Property Usage Scenarios Summary ### Status Check ```vb If Delay.IsActive Then MsgBox "Please wait for current delay to finish" Else Delay.CountDown 3000 End If ``` ### Sync Mode Result Check ```vb Delay.Sync().CountDown 5000 If Delay.IsCancelled Then ' User cancelled operation Exit Sub End If ' Continue with subsequent operations ``` *** **Last Updated**: 2026-05-17 --- --- url: /en/vbman/start/devlog.md --- # Development Log ::: danger Usage Notice **For legal purposes only. Any illegal use is strictly prohibited.** Download = Agreement: The user assumes all legal responsibilities. This website bears no liability. This website will cooperate with national reviews in accordance with the law. ::: ## 2026-03-18 v1.0.335 [Download](https://wwaue.lanzouv.com/i9ZW43kylxkh) * **Added cToast Notification Component** * Supports 9 display positions (center, four corners, four midpoints) * Supports 4 state themes (Info, Success, Warning, Danger) * Supports 2 color themes (Light, Dark) * Smart stacking feature, automatic sequential or reverse stacking * Mouse hover pauses countdown * Global singleton object, can be called from anywhere without New * Complete event mechanism and API documentation ## 2026-01-27 v1.0.302 [Download](https://wwaue.lanzouv.com/iScuR3h317da) * **Added cRedis class object** * Added synchronous operation suite for cWinsock * Added global Tools object with daily utilities * More features waiting for you to discover ## 2026-01-10 v1.0.265 [Download](https://wwaue.lanzouv.com/igLdr3fz5ula) * **Size Exceeds 1MB for the First Time** This official release has surpassed 1MB in size for the first time, after exactly 100 version compilations. Numerous functional objects have been added during this period. For details, you can first explore the library members via the F2 Object Browser. Alternatively, directly download the linked file above—the compressed package contains many demo examples. * **New Module Preview** 1. Enhanced cCsv module. 2. Added cWinsock class object. 3. Added cWebsocket class object. * ...More ## 2020-05-05 v1.0.165 [Download](https://wwaue.lanzouv.com/i6u1t3e63u3a) * ##### Fix cJson.Encode error The friend of the group like wind found a `cJson` class error in the `Encode` method, which has been fixed. * ##### Added weather forecast query instance An instance with video playback was added to the weather forecast query. --- --- url: /zh/vbman/dialog/overview.md --- # Dialog 对话框组件概述 ## 📖 简介 `cDialog` 是一个 Windows 标准对话框封装类，提供打开文件、保存文件、选择文件夹等常用对话框功能，支持文件过滤、多选等特性。 ## ✨ 主要特性 | 特性 | 说明 | | -------------------- | ---------------------------------- | | **打开文件对话框** | 支持单选、多选、文件过滤 | | **保存文件对话框** | 支持覆盖提示、默认扩展名 | | **选择文件夹对话框** | 支持新样式对话框 | | **预设过滤器** | 文本、图片、文档、代码等预设过滤器 | | **文件路径工具** | 提取路径、文件名、扩展名等 | | **打开文件** | 使用 ShellExecute 打开选中文件 | ## 🚀 快速开始 ### 打开文件 ```vb Dim dlg As New cDialog dlg.DialogTitle = "选择文件" dlg.InitialDir = "C:\Documents" dlg.AddFilter "文本文件", "*.txt" dlg.AddFilter "所有文件", "*.*" Dim filePath As String filePath = dlg.ShowOpen If filePath <> "" Then Debug.Print "选择的文件: " & filePath End If ``` ### 保存文件 ```vb Dim dlg As New cDialog dlg.DialogTitle = "保存文件" dlg.DefaultExt = "txt" dlg.FileName = "新建文档.txt" dlg.AddFilter "文本文件", "*.txt" Dim savePath As String savePath = dlg.ShowSave If savePath <> "" Then Debug.Print "保存到: " & savePath End If ``` ### 选择文件夹 ```vb Dim dlg As New cDialog dlg.DialogTitle = "选择文件夹" Dim folderPath As String folderPath = dlg.ShowBrowseForFolder If folderPath <> "" Then Debug.Print "选择的文件夹: " & folderPath End If ``` ### 使用预设过滤器 ```vb Dim dlg As New cDialog ' 使用图片过滤器 dlg.SetImageFilters Dim imgFile As String imgFile = dlg.ShowOpen ' 使用文档过滤器 dlg.SetDocumentFilters Dim docFile As String docFile = dlg.ShowOpen ``` ### 使用实例 ```vb '----------------------------------------------- ' 事件: btnBrowse_Click (浏览按钮) ' 描述: 打开文件选择对话框 '----------------------------------------------- Private Sub btnBrowse_Click() With New cDialog .ClearFilter .AddFilter "所有文件 (*.*)", "*.*" .DialogTitle = "选择要上传的文件" .FileMustExist = True .PathMustExist = True With .SelectFiles() If .Count > 0 Then mSelectedFile = .Item(1) txtFilePath.Text = mSelectedFile lblStatus.Caption = "文件大小: " & VBMAN.Formater(FileLen(mSelectedFile)).ReturnFileSize() btnUpload.Enabled = True End If End With End With End Sub ``` ## 📁 文档导航 * [properties.md](./properties.md) - 属性详细参考 * [methods.md](./methods.md) - 方法详细参考 *** **最后更新**: 2026-05-17 --- --- url: /zh/vbman/dialog/methods.md --- # Dialog 方法参考 ## 📋 方法列表 | 方法 | 说明 | |------|------| | `ShowOpen` | 显示打开文件对话框 | | `ShowSave` | 显示保存文件对话框 | | `ShowBrowseForFolder` | 显示选择文件夹对话框 | | `SelectFiles` | 选择文件并返回集合 | | `SelectAndOpenFile` | 选择文件并打开 | | `OpenFile` | 打开指定文件 | | `AddFilter` | 添加文件过滤器 | | `ClearFilter` | 清除所有过滤器 | | `SetCommonFilters` | 设置常用过滤器 | | `SetImageFilters` | 设置图片过滤器 | | `SetDocumentFilters` | 设置文档过滤器 | | `SetCodeFilters` | 设置代码过滤器 | | `GetFilePath` | 获取文件路径（不含文件名）| | `GetFileName` | 获取文件名（含扩展名）| | `GetFileExtension` | 获取文件扩展名 | | `GetFileNameWithoutExt` | 获取文件名（不含扩展名）| | `Reset` | 重置为默认设置 | *** ## 📂 ShowOpen 方法 ### 说明 显示打开文件对话框。返回选中的文件路径，支持多选。 ### 语法 ```vb Public Function ShowOpen() As Variant ``` ### 返回值 * 单选模式：返回文件路径字符串，取消返回空字符串 * 多选模式（MultiSelect=True）：返回文件路径数组 ### 使用示例 #### 单选文件 ```vb Dim dlg As New cDialog dlg.DialogTitle = "打开文件" dlg.InitialDir = "C:\Documents" dlg.AddFilter "文本文件", "*.txt" dlg.AddFilter "所有文件", "*.*" Dim filePath As String filePath = dlg.ShowOpen If filePath <> "" Then Debug.Print "选择的文件: " & filePath End If ``` #### 多选文件 ```vb dlg.MultiSelect = True Dim result As Variant result = dlg.ShowOpen If IsArray(result) Then Dim i As Long For i = LBound(result) To UBound(result) Debug.Print "文件 " & i & ": " & result(i) Next i ElseIf result <> "" Then Debug.Print "单个文件: " & result End If ``` *** ## 💾 ShowSave 方法 ### 说明 显示保存文件对话框。 ### 语法 ```vb Public Function ShowSave() As String ``` ### 返回值 返回保存路径字符串，取消返回空字符串。 ### 使用示例 ```vb Dim dlg As New cDialog dlg.DialogTitle = "保存文件" dlg.DefaultExt = "txt" dlg.FileName = "新建文档.txt" dlg.InitialDir = "C:\Documents" dlg.AddFilter "文本文件", "*.txt" dlg.AddFilter "所有文件", "*.*" Dim savePath As String savePath = dlg.ShowSave If savePath <> "" Then Debug.Print "保存到: " & savePath ' 执行保存操作 End If ``` *** ## 📁 ShowBrowseForFolder 方法 ### 说明 显示选择文件夹对话框。 ### 语法 ```vb Public Function ShowBrowseForFolder() As String ``` ### 返回值 返回选择的文件夹路径，取消返回空字符串。 ### 使用示例 ```vb Dim dlg As New cDialog dlg.DialogTitle = "请选择输出文件夹" dlg.NewDialogStyle = True ' 使用新样式（带编辑框） Dim folderPath As String folderPath = dlg.ShowBrowseForFolder If folderPath <> "" Then Debug.Print "选择的文件夹: " & folderPath End If ``` *** ## 📋 SelectFiles 方法 ### 说明 显示打开文件对话框，返回选中的文件集合（Collection）。 ### 语法 ```vb Public Function SelectFiles() As Collection ``` ### 返回值 返回包含文件路径的 Collection 对象。 ### 使用示例 ```vb Dim dlg As New cDialog dlg.DialogTitle = "选择文件" dlg.MultiSelect = True dlg.AddFilter "所有文件", "*.*" Dim files As Collection Set files = dlg.SelectFiles Debug.Print "选择了 " & files.count & " 个文件" Dim file As Variant For Each file In files Debug.Print file Next file ``` *** ## 🚀 SelectAndOpenFile 方法 ### 说明 显示打开文件对话框，并自动打开选中的文件。 ### 语法 ```vb Public Function SelectAndOpenFile() As Long ``` ### 返回值 返回 ShellExecute 的结果。 ### 使用示例 ```vb Dim dlg As New cDialog dlg.DialogTitle = "选择要打开的文件" dlg.AddFilter "可执行文件", "*.exe" dlg.SelectAndOpenFile ' 选中后自动打开 ``` *** ## 📂 OpenFile 方法 ### 说明 使用 ShellExecute 打开指定文件。 ### 语法 ```vb Public Function OpenFile(ByVal strFilePath As String, Optional ByVal strOperation As String = "open") As Long ``` ### 参数 | 参数 | 类型 | 说明 | |------|------|------| | `strFilePath` | String | 要打开的文件路径 | | `strOperation` | String | 操作类型，默认 "open" | ### 使用示例 ```vb Dim dlg As New cDialog dlg.OpenFile "C:\Documents\file.txt" ' 用默认程序打开 dlg.OpenFile "C:\Documents\file.txt", "edit" ' 用编辑方式打开 ``` *** ## ➕ AddFilter 方法 ### 说明 添加一个文件过滤器。 ### 语法 ```vb Public Sub AddFilter(ByVal strDescription As String, ByVal strExtension As String) ``` ### 参数 | 参数 | 类型 | 说明 | |------|------|------| | `strDescription` | String | 过滤器描述 | | `strExtension` | String | 文件扩展名模式 | ### 使用示例 ```vb dlg.AddFilter "文本文件", "*.txt" dlg.AddFilter "图片文件", "*.jpg;*.png;*.gif" dlg.AddFilter "所有文件", "*.*" ``` *** ## 🧹 ClearFilter 方法 ### 说明 清除所有文件过滤器。 ### 语法 ```vb Public Sub ClearFilter() ``` ### 使用示例 ```vb dlg.ClearFilter ' 清除之前的过滤器 dlg.AddFilter "新类型", "*.new" ``` *** ## 📋 预设过滤器方法 ### SetCommonFilters 设置常用文件过滤器（文本文件、所有文件）。 ```vb dlg.SetCommonFilters ``` ### SetImageFilters 设置图片文件过滤器。 ```vb dlg.SetImageFilters ' 包含 bmp, jpg, png, gif 等 ``` ### SetDocumentFilters 设置文档文件过滤器。 ```vb dlg.SetDocumentFilters ' 包含 doc, xls, ppt, pdf 等 ``` ### SetCodeFilters 设置代码文件过滤器。 ```vb dlg.SetCodeFilters ' 包含 bas, c, cs, java, py, js 等 ``` *** ## 🔧 文件路径工具方法 ### GetFilePath 获取文件所在目录路径。 ```vb Dim path As String path = dlg.GetFilePath("C:\Folder\file.txt") ' 返回 "C:\Folder" ``` ### GetFileName 获取文件名（含扩展名）。 ```vb Dim name As String name = dlg.GetFileName("C:\Folder\file.txt") ' 返回 "file.txt" ``` ### GetFileExtension 获取文件扩展名（含点号）。 ```vb Dim ext As String ext = dlg.GetFileExtension("C:\Folder\file.txt") ' 返回 ".txt" ``` ### GetFileNameWithoutExt 获取文件名（不含扩展名）。 ```vb Dim name As String name = dlg.GetFileNameWithoutExt("C:\Folder\file.txt") ' 返回 "file" ``` *** ## 🔄 Reset 方法 ### 说明 重置所有设置为默认值。 ### 语法 ```vb Public Sub Reset() ``` ### 使用示例 ```vb dlg.Reset ' 清空所有设置，恢复初始状态 ``` *** **最后更新**: 2026-05-17 --- --- url: /zh/vbman/dialog/properties.md --- # Dialog 属性参考 ## 📋 属性列表 | 属性 | 类型 | 说明 | |------|------|------| | `DialogTitle` | String | 对话框标题 | | `InitialDir` | String | 初始目录 | | `DefaultExt` | String | 默认扩展名 | | `FileName` | String | 默认/选中的文件名 | | `Filter` | String | 文件过滤器 | | `MultiSelect` | Boolean | 是否允许多选 | | `OverwritePrompt` | Boolean | 保存时是否提示覆盖 | | `PathMustExist` | Boolean | 路径必须存在 | | `FileMustExist` | Boolean | 文件必须存在 | | `HideReadOnly` | Boolean | 隐藏只读复选框 | | `NewDialogStyle` | Boolean | 使用新对话框样式 | *** ## 🏷️ DialogTitle 属性 ### 说明 设置或获取对话框标题栏显示的文本。 ### 语法 ```vb Public Property Let DialogTitle(ByVal vValue As String) Public Property Get DialogTitle() As String ``` ### 使用示例 ```vb Dim dlg As New cDialog dlg.DialogTitle = "请选择要打开的文件" Dim file As String file = dlg.ShowOpen ``` *** ## 📁 InitialDir 属性 ### 说明 设置或获取对话框打开时的初始目录。 ### 语法 ```vb Public Property Let InitialDir(ByVal vValue As String) Public Property Get InitialDir() As String ``` ### 使用示例 ```vb dlg.InitialDir = "C:\Users\Documents" ``` *** ## 📎 DefaultExt 属性 ### 说明 设置或获取默认的文件扩展名（不带点号）。 ### 语法 ```vb Public Property Let DefaultExt(ByVal vValue As String) Public Property Get DefaultExt() As String ``` ### 使用示例 ```vb dlg.DefaultExt = "txt" ' 默认保存为 .txt 文件 ``` *** ## 📄 FileName 属性 ### 说明 设置默认文件名或获取用户选择的文件名。 ### 语法 ```vb Public Property Let FileName(ByVal vValue As String) Public Property Get FileName() As String ``` ### 使用示例 ```vb ' 设置默认文件名 dlg.FileName = "新建文档.txt" ' 获取选择的文件名（ShowOpen/Save后） Dim selected As String selected = dlg.FileName ``` *** ## 🔍 Filter 属性 ### 说明 设置或获取文件过滤器字符串。格式：`描述1|模式1|描述2|模式2` ### 语法 ```vb Public Property Let Filter(ByVal vValue As String) Public Property Get Filter() As String ``` ### 使用示例 ```vb ' 直接设置过滤器 dlg.Filter = "文本文件|*.txt|所有文件|*.*" ' 使用 AddFilter 方法添加 dlg.AddFilter "文本文件", "*.txt" dlg.AddFilter "所有文件", "*.*" ``` *** ## ☑️ MultiSelect 属性 ### 说明 设置或获取是否允许多选文件。 ### 语法 ```vb Public Property Let MultiSelect(ByVal vValue As Boolean) Public Property Get MultiSelect() As Boolean ``` ### 使用示例 ```vb dlg.MultiSelect = True Dim files As Collection Set files = dlg.SelectFiles ' 返回 Collection ``` *** ## ⚠️ OverwritePrompt 属性 ### 说明 设置或获取保存文件时是否提示覆盖已存在的文件。 ### 语法 ```vb Public Property Let OverwritePrompt(ByVal vValue As Boolean) Public Property Get OverwritePrompt() As Boolean ``` ### 使用示例 ```vb dlg.OverwritePrompt = True ' 默认开启 ``` *** ## ✅ PathMustExist 属性 ### 说明 设置或获取是否要求路径必须存在。 ### 语法 ```vb Public Property Let PathMustExist(ByVal vValue As Boolean) Public Property Get PathMustExist() As Boolean ``` ### 使用示例 ```vb dlg.PathMustExist = True ' 默认开启 ``` *** ## 📋 FileMustExist 属性 ### 说明 设置或获取是否要求文件必须存在（仅打开对话框）。 ### 语法 ```vb Public Property Let FileMustExist(ByVal vValue As Boolean) Public Property Get FileMustExist() As Boolean ``` ### 使用示例 ```vb dlg.FileMustExist = True ' 默认开启 ``` *** ## 🎨 NewDialogStyle 属性 ### 说明 设置或获取是否使用新的对话框样式（文件夹选择对话框）。 ### 语法 ```vb Public Property Let NewDialogStyle(ByVal vValue As Boolean) Public Property Get NewDialogStyle() As Boolean ``` ### 使用示例 ```vb dlg.NewDialogStyle = True ' 使用带编辑框的新样式 ``` *** **最后更新**: 2026-05-17 --- --- url: /en/vbman/dialog/overview.md --- # Dialog Component Overview ## 📖 Introduction `cDialog` is a Windows standard dialog wrapper class providing common dialog functionality such as open file, save file, select folder, supporting file filtering, multi-select, and other features. ## ✨ Key Features | Feature | Description | |---------|-------------| | **Open File Dialog** | Supports single select, multi-select, file filtering | | **Save File Dialog** | Supports overwrite prompt, default extension | | **Select Folder Dialog** | Supports new style dialog | | **Preset Filters** | Text, image, document, code and other preset filters | | **File Path Utilities** | Extract path, filename, extension, etc. | | **Open File** | Open selected file using ShellExecute | ## 🚀 Quick Start ### Open File ```vb Dim dlg As New cDialog dlg.DialogTitle = "Select File" dlg.InitialDir = "C:\Documents" dlg.AddFilter "Text Files", "*.txt" dlg.AddFilter "All Files", "*.*" Dim filePath As String filePath = dlg.ShowOpen If filePath <> "" Then Debug.Print "Selected file: " & filePath End If ``` ### Save File ```vb Dim dlg As New cDialog dlg.DialogTitle = "Save File" dlg.DefaultExt = "txt" dlg.FileName = "New Document.txt" dlg.AddFilter "Text Files", "*.txt" Dim savePath As String savePath = dlg.ShowSave If savePath <> "" Then Debug.Print "Save to: " & savePath End If ``` ### Select Folder ```vb Dim dlg As New cDialog dlg.DialogTitle = "Select Folder" Dim folderPath As String folderPath = dlg.ShowBrowseForFolder If folderPath <> "" Then Debug.Print "Selected folder: " & folderPath End If ``` ### Using Preset Filters ```vb Dim dlg As New cDialog ' Use image filter dlg.SetImageFilters Dim imgFile As String imgFile = dlg.ShowOpen ' Use document filter dlg.SetDocumentFilters Dim docFile As String docFile = dlg.ShowOpen ``` ### Usage Example ```vb '----------------------------------------------- ' Event: btnBrowse_Click (Browse button) ' Description: Open file selection dialog '----------------------------------------------- Private Sub btnBrowse_Click() With New cDialog .ClearFilter .AddFilter "All Files (*.*)", "*.*" .DialogTitle = "Select file to upload" .FileMustExist = True .PathMustExist = True With .SelectFiles() If .Count > 0 Then mSelectedFile = .Item(1) txtFilePath.Text = mSelectedFile lblStatus.Caption = "File size: " & VBMAN.Formater(FileLen(mSelectedFile)).ReturnFileSize() btnUpload.Enabled = True End If End With End With End Sub ``` ## 📁 Documentation Navigation * [properties.md](./properties.md) - Properties detailed reference * [methods.md](./methods.md) - Methods detailed reference *** **Last Updated**: 2026-05-17 --- --- url: /en/vbman/dialog/methods.md --- # Dialog Methods Reference ## 📋 Method List | Method | Description | |--------|-------------| | `ShowOpen` | Show open file dialog | | `ShowSave` | Show save file dialog | | `ShowBrowseForFolder` | Show select folder dialog | | `SelectFiles` | Select files and return collection | | `SelectAndOpenFile` | Select file and open | | `OpenFile` | Open specified file | | `AddFilter` | Add file filter | | `ClearFilter` | Clear all filters | | `SetCommonFilters` | Set common filters | | `SetImageFilters` | Set image filters | | `SetDocumentFilters` | Set document filters | | `SetCodeFilters` | Set code filters | | `GetFilePath` | Get file path (without filename) | | `GetFileName` | Get filename (with extension) | | `GetFileExtension` | Get file extension | | `GetFileNameWithoutExt` | Get filename (without extension) | | `Reset` | Reset to default settings | *** ## 📂 ShowOpen Method ### Description Shows open file dialog. Returns selected file path, supports multi-select. ### Syntax ```vb Public Function ShowOpen() As Variant ``` ### Return Value * Single select mode: Returns file path string, returns empty string on cancel * Multi-select mode (MultiSelect=True): Returns file path array ### Example #### Single File Selection ```vb Dim dlg As New cDialog dlg.DialogTitle = "Open File" dlg.InitialDir = "C:\Documents" dlg.AddFilter "Text Files", "*.txt" dlg.AddFilter "All Files", "*.*" Dim filePath As String filePath = dlg.ShowOpen If filePath <> "" Then Debug.Print "Selected file: " & filePath End If ``` #### Multi-File Selection ```vb dlg.MultiSelect = True Dim result As Variant result = dlg.ShowOpen If IsArray(result) Then Dim i As Long For i = LBound(result) To UBound(result) Debug.Print "File " & i & ": " & result(i) Next i ElseIf result <> "" Then Debug.Print "Single file: " & result End If ``` *** ## 💾 ShowSave Method ### Description Shows save file dialog. ### Syntax ```vb Public Function ShowSave() As String ``` ### Return Value Returns save path string, returns empty string on cancel. ### Example ```vb Dim dlg As New cDialog dlg.DialogTitle = "Save File" dlg.DefaultExt = "txt" dlg.FileName = "New Document.txt" dlg.InitialDir = "C:\Documents" dlg.AddFilter "Text Files", "*.txt" dlg.AddFilter "All Files", "*.*" Dim savePath As String savePath = dlg.ShowSave If savePath <> "" Then Debug.Print "Save to: " & savePath ' Execute save operation End If ``` *** ## 📁 ShowBrowseForFolder Method ### Description Shows select folder dialog. ### Syntax ```vb Public Function ShowBrowseForFolder() As String ``` ### Return Value Returns selected folder path, returns empty string on cancel. ### Example ```vb Dim dlg As New cDialog dlg.DialogTitle = "Please select output folder" dlg.NewDialogStyle = True ' Use new style (with edit box) Dim folderPath As String folderPath = dlg.ShowBrowseForFolder If folderPath <> "" Then Debug.Print "Selected folder: " & folderPath End If ``` *** ## 📋 SelectFiles Method ### Description Shows open file dialog, returns selected file collection (Collection). ### Syntax ```vb Public Function SelectFiles() As Collection ``` ### Return Value Returns Collection object containing file paths. ### Example ```vb Dim dlg As New cDialog dlg.DialogTitle = "Select Files" dlg.MultiSelect = True dlg.AddFilter "All Files", "*.*" Dim files As Collection Set files = dlg.SelectFiles Debug.Print "Selected " & files.Count & " files" Dim file As Variant For Each file In files Debug.Print file Next file ``` *** ## 🚀 SelectAndOpenFile Method ### Description Shows open file dialog and automatically opens the selected file. ### Syntax ```vb Public Function SelectAndOpenFile() As Long ``` ### Return Value Returns ShellExecute result. ### Example ```vb Dim dlg As New cDialog dlg.DialogTitle = "Select file to open" dlg.AddFilter "Executable Files", "*.exe" dlg.SelectAndOpenFile ' Auto open after selection ``` *** ## 📂 OpenFile Method ### Description Opens specified file using ShellExecute. ### Syntax ```vb Public Function OpenFile(ByVal strFilePath As String, Optional ByVal strOperation As String = "open") As Long ``` ### Parameters | Parameter | Type | Description | |-----------|------|-------------| | `strFilePath` | String | File path to open | | `strOperation` | String | Operation type, default "open" | ### Example ```vb Dim dlg As New cDialog dlg.OpenFile "C:\Documents\file.txt" ' Open with default program dlg.OpenFile "C:\Documents\file.txt", "edit" ' Open for editing ``` *** ## ➕ AddFilter Method ### Description Adds a file filter. ### Syntax ```vb Public Sub AddFilter(ByVal strDescription As String, ByVal strExtension As String) ``` ### Parameters | Parameter | Type | Description | |-----------|------|-------------| | `strDescription` | String | Filter description | | `strExtension` | String | File extension pattern | ### Example ```vb dlg.AddFilter "Text Files", "*.txt" dlg.AddFilter "Image Files", "*.jpg;*.png;*.gif" dlg.AddFilter "All Files", "*.*" ``` *** ## 🧹 ClearFilter Method ### Description Clears all file filters. ### Syntax ```vb Public Sub ClearFilter() ``` ### Example ```vb dlg.ClearFilter ' Clear previous filters dlg.AddFilter "New Type", "*.new" ``` *** ## 📋 Preset Filter Methods ### SetCommonFilters Sets common file filters (text files, all files). ```vb dlg.SetCommonFilters ``` ### SetImageFilters Sets image file filters. ```vb dlg.SetImageFilters ' Contains bmp, jpg, png, gif, etc. ``` ### SetDocumentFilters Sets document file filters. ```vb dlg.SetDocumentFilters ' Contains doc, xls, ppt, pdf, etc. ``` ### SetCodeFilters Sets code file filters. ```vb dlg.SetCodeFilters ' Contains bas, c, cs, java, py, js, etc. ``` *** ## 🔧 File Path Utility Methods ### GetFilePath Gets the directory path of a file. ```vb Dim path As String path = dlg.GetFilePath("C:\Folder\file.txt") ' Returns "C:\Folder" ``` ### GetFileName Gets filename (with extension). ```vb Dim name As String name = dlg.GetFileName("C:\Folder\file.txt") ' Returns "file.txt" ``` ### GetFileExtension Gets file extension (with dot). ```vb Dim ext As String ext = dlg.GetFileExtension("C:\Folder\file.txt") ' Returns ".txt" ``` ### GetFileNameWithoutExt Gets filename (without extension). ```vb Dim name As String name = dlg.GetFileNameWithoutExt("C:\Folder\file.txt") ' Returns "file" ``` *** ## 🔄 Reset Method ### Description Resets all settings to default values. ### Syntax ```vb Public Sub Reset() ``` ### Example ```vb dlg.Reset ' Clear all settings, restore initial state ``` *** **Last Updated**: 2026-05-17 --- --- url: /en/vbman/dialog/properties.md --- # Dialog Properties Reference ## 📋 Property List | Property | Type | Description | |----------|------|-------------| | `DialogTitle` | String | Dialog title | | `InitialDir` | String | Initial directory | | `DefaultExt` | String | Default extension | | `FileName` | String | Default/selected filename | | `Filter` | String | File filter | | `MultiSelect` | Boolean | Allow multi-select | | `OverwritePrompt` | Boolean | Prompt for overwrite on save | | `PathMustExist` | Boolean | Path must exist | | `FileMustExist` | Boolean | File must exist | | `HideReadOnly` | Boolean | Hide read-only checkbox | | `NewDialogStyle` | Boolean | Use new dialog style | *** ## 🏷️ DialogTitle Property ### Description Sets or gets the text displayed in the dialog title bar. ### Syntax ```vb Public Property Let DialogTitle(ByVal vValue As String) Public Property Get DialogTitle() As String ``` ### Example ```vb Dim dlg As New cDialog dlg.DialogTitle = "Please select file to open" Dim file As String file = dlg.ShowOpen ``` *** ## 📁 InitialDir Property ### Description Sets or gets the initial directory when dialog opens. ### Syntax ```vb Public Property Let InitialDir(ByVal vValue As String) Public Property Get InitialDir() As String ``` ### Example ```vb dlg.InitialDir = "C:\Users\Documents" ``` *** ## 📎 DefaultExt Property ### Description Sets or gets the default file extension (without dot). ### Syntax ```vb Public Property Let DefaultExt(ByVal vValue As String) Public Property Get DefaultExt() As String ``` ### Example ```vb dlg.DefaultExt = "txt" ' Default save as .txt file ``` *** ## 📄 FileName Property ### Description Sets default filename or gets user-selected filename. ### Syntax ```vb Public Property Let FileName(ByVal vValue As String) Public Property Get FileName() As String ``` ### Example ```vb ' Set default filename dlg.FileName = "New Document.txt" ' Get selected filename (after ShowOpen/Save) Dim selected As String selected = dlg.FileName ``` *** ## 🔍 Filter Property ### Description Sets or gets file filter string. Format: `Description1|Pattern1|Description2|Pattern2` ### Syntax ```vb Public Property Let Filter(ByVal vValue As String) Public Property Get Filter() As String ``` ### Example ```vb ' Set filter directly dlg.Filter = "Text Files|*.txt|All Files|*.*" ' Use AddFilter method dlg.AddFilter "Text Files", "*.txt" dlg.AddFilter "All Files", "*.*" ``` *** ## ☑️ MultiSelect Property ### Description Sets or gets whether to allow multi-file selection. ### Syntax ```vb Public Property Let MultiSelect(ByVal vValue As Boolean) Public Property Get MultiSelect() As Boolean ``` ### Example ```vb dlg.MultiSelect = True Dim files As Collection Set files = dlg.SelectFiles ' Returns Collection ``` *** ## ⚠️ OverwritePrompt Property ### Description Sets or gets whether to prompt for overwrite when saving file that already exists. ### Syntax ```vb Public Property Let OverwritePrompt(ByVal vValue As Boolean) Public Property Get OverwritePrompt() As Boolean ``` ### Example ```vb dlg.OverwritePrompt = True ' Enabled by default ``` *** ## ✅ PathMustExist Property ### Description Sets or gets whether path must exist. ### Syntax ```vb Public Property Let PathMustExist(ByVal vValue As Boolean) Public Property Get PathMustExist() As Boolean ``` ### Example ```vb dlg.PathMustExist = True ' Enabled by default ``` *** ## 📋 FileMustExist Property ### Description Sets or gets whether file must exist (open dialog only). ### Syntax ```vb Public Property Let FileMustExist(ByVal vValue As Boolean) Public Property Get FileMustExist() As Boolean ``` ### Example ```vb dlg.FileMustExist = True ' Enabled by default ``` *** ## 🎨 NewDialogStyle Property ### Description Sets or gets whether to use new dialog style (folder selection dialog). ### Syntax ```vb Public Property Let NewDialogStyle(ByVal vValue As Boolean) Public Property Get NewDialogStyle() As Boolean ``` ### Example ```vb dlg.NewDialogStyle = True ' Use new style with edit box ``` *** **Last Updated**: 2026-05-17 --- --- url: /en/donate.md --- # Donation Thank you to all friends who support this project! Your donations will help us continuously improve and maintain the VB6.Pro project. ## How to Donate If you find VB6.Pro helpful, you're welcome to support our development work through the following methods: ## Donor Below is a list of donors who have supported this project (sorted by date): | 日期 Date | 捐赠者 Donor | 金额 Amount | 留言 Message | | ---------- | ---------------------------- | ----------- | -------------------------------------------------------------------------------------------------- | | 2024-06-20 | VbsGirl（土妹） | ￥ 200 | vbsgirl 娟 200 元 | | 2024-06-21 | 匿名 VB 群友 | ￥ 10 | 暂无 | | 2024-06-27 | 赞助商 码农库 | ￥ 200 | 码农库 MaNongKu.com 捐 200 元 | | 2024-06-28 | VbsGirl（土妹） | ￥ 100 | 过 500 了，怀念 VB 的人务必支持一下，人生有情，情怀无价！ | | 2024-08-06 | twinbasic 群友：TONMIN | ￥ 100 | 支持一下 | | 2024-09-26 | ASP 群友：天子 | ￥ 10 | (马鞍山市的徐磊)支持一下 | | 2024-09-29 | 好友：郑春来 | ￥ 200 | 捐助￥ 200 开发 VBMAN 服务器 demo | | 2024-09-29 | VB 群友：Kimi | ￥ 500 | 捐助开发 JSON 服务器 demo | | 2024-10-11 | VB 群友：流云 | ￥ 100 | 你们这种精神需要鼓励。 | | 2024-10-16 | VB 群友: Edward | ￥ 10 | 暂无 | | 2024-10-19 | VB 群友: 静咫流云 | ￥ 200 | 我看好 VBMAN, 加油干 | | 2024-09-29 | 好友：郑春来 | ￥ 200 | 捐助￥ 200 开发 VBMAN 客户端 HTTP 分块上传文件的 demo | | 2024-12-12 | QQ 群友: 守望者 | ￥ 6.66 | 捐赠 6.66 | | 2024-12-12 | QQ 群友: 码农库 MaNongKu.com | ￥ 1.66 | 捐赠 1.66 | | 2024-12-18 | QQ 群友: mature | ￥ 50.00 | 期待后续的开发，特别是对网页的视频的控制，如播放，暂停，快进，拖放等，看视频中途有题出现时的处理。 | | 2024-12-20 | QQ 群友: 郑春来 | ￥ 88.00 | 捐赠 vbman2。 | | 2024-12-28 | QQ 群友: moonboy | ￥ 66.00 | 小小支持一下，祝越做越好。 | | 2025-03-07 | 微信：\*翼 | ￥ 10.00 | 太棒了，期待更强。 | | 2025-01-11 | QQ 群友：绵阳汪汪 | ￥ 66.66 | 暂无。 | | 2025-01-07 | 微信：\*尔 | ￥ 10.80 | 暂无。 | | 2025-01-07 | 微信：\*尔（支付 2 次） | ￥ 10.80 | 暂无。 | | 2025-06-14 | 微信：贺文龙 | ￥ 500.00 | 把 vb 瘸了的那条腿给接上了。 | | 2025-06-16 | QQ 群友：cuieaor | ￥ 18.00 | 请大神喝杯奶茶。 | | 2025-06-18 | QQ 群友：上海二毛 | ￥ 188.00 | 守住国内 VB6 最后的领地。 | | 2025-12-15 | QQ 群友：蓝海岸 | ￥ 10.00 | 暂无。 | | 2025-12-22 | QQ 群友：Man.兔子 ღ o О | ￥ 50.00 | 暂无。 | | 2026-01-12 | QQ 群友：你到底说不说 | ￥ 50.00 | 再接再厉，继续加油! | | 2026-01-16 | QQ 群友: 码农库 MaNongKu.com | ￥ 20.00 | for vbman | | 2026-01-17 | QQ 群友: 往事随风 | ￥ 100.00 | VBMAN 加油 | | 2026-01-30 | QQ 群友: 小鱼 | ￥ 100.00 | 以图鼓励 嘎嘎 | | 2026-01-30 | QQ 群友: xxdoc | ￥ 20.00 | vbmen牛 | | 2026-02-08 | QQ 群友: 老白 | ￥ 200.00 | 过年了赞助你点 | | 2026-02-09 | QQ 群友: 南赡部洲 | ￥ 100.00 | 大佬，赞助了100 | | 2026-02-16 | QQ 群友: 松林 | ￥ 100.00 | 捐献给本网站 | | 2026-02-18 | QQ 群友: 游戏玩家 | ￥ 6.66 | vbman2，一点点感谢 | | 2026-03-02 | 微信: y\*w | ￥ 20.00 | （无留言） | | 2026-03-02 | QQ 群友: ck^er | ￥ 6.66 | 有空把winsock例程分开吧^O^ | | 2026-03-19 | 微信: 德\*d | ￥ 30.00 | （无留言） | | 2026-03-26 | QQ 群友: norman | ￥ 50.00 | 希望给vb6多续两年命 | | 2026-05-08 | QQ 群友: 小熊软糖 | ￥ 500.00 | 小小心意 | | 2026-05-21 | QQ 群友: 小熊软糖 | ￥ 300.00 | 咖啡费已捐赠 | | 2026-06-01 | QQ 群友: 橙子 | ￥ 100.00 | (无留言) | | 2026-06-25 | QQ 群友: 自学成柴 | ￥ 10.00 | 喝杯红牛 | | 2026-07-19 | QQ 匿名网友（1） | ￥ 200.00 | 辛苦 | | 2026-07-23 | 好友：郑春来 | ￥ 200.00 | VBMAN | | 2026-08-16 | QQ 群友：后悔（2） | ￥ 50.00 | 支持大佬，请大佬喝咖 | ## Fund Usage All donations will be used for: * Continuous framework development and maintenance * Server and domain name expenses * Documentation improvement and translation * Community building and technical support ## Donor (C3 Project) Below is a list of donors who have supported the C3 project (sorted by date): | 日期 Date | 捐赠者 Donor | 金额 Amount | 留言 Message | | ---------- | ------------ | ----------- | ---------------------------- | | 2026-07-07 | QQ群友：落叶 | ￥16 | 请大佬喝杯咖啡，提提速！！！ | | 2026-07-20 | QQ群友：★UF● | ￥20 | 虽然现在VB不怎么用了，先支持下！ | ## Special Notes * Donations are entirely voluntary, with no minimum amount * The donor list will be updated regularly * If you wish to donate anonymously, please indicate in your message Thank you again to all supporters! --- --- url: /en/packages/vbccr/datetime/dtpicker.md description: >- DTPicker Control - VBCCR Development Manual, complete API reference based on source code --- # DTPicker Control Based on the Windows date-time picker common control, provides date and time selection with custom formatting capabilities. ## Enumerations ### DtpFormatConstants | Constant | Value | Description | |----------|-------|-------------| | DtpFormatLongDate | 0 | Long date format | | DtpFormatShortDate | 1 | Short date format | | DtpFormatTime | 2 | Time format | | DtpFormatCustom | 3 | Custom format | ## Properties ### Name ```vb Property Get Name() As String ``` Returns the name used to identify the object in code. ### Tag ```vb Property Get/Let Tag() As String ``` Stores extra data needed by the program. ### Parent ```vb Property Get Parent() As Object ``` Returns the object that contains this object. ### Container `Property Get Container() As Object` / `Property Set Container(ByVal Value As Object)` Returns/sets the container of the object. ### Left ```vb Property Get/Let Left() As Single ``` Returns/sets the distance between the left edge of the object and the left edge of its container. ### Top ```vb Property Get/Let Top() As Single ``` Returns/sets the distance between the top edge of the object and the top edge of its container. ### Width ```vb Property Get/Let Width() As Single ``` Returns/sets the width of the object. ### Height ```vb Property Get/Let Height() As Single ``` Returns/sets the height of the object. ### Visible ```vb Property Get/Let Visible() As Boolean ``` Returns/sets whether the object is visible. ### ToolTipText ```vb Property Get/Let ToolTipText() As String ``` Returns/sets the tooltip text displayed when the mouse hovers. ### HelpContextID ```vb Property Get/Let HelpContextID() As Long ``` Specifies the default help file context ID for the object. ### WhatsThisHelpID ```vb Property Get/Let WhatsThisHelpID() As Long ``` Returns/sets the context number associated with the object. ### DragIcon ```vb Property Get/Let/Set DragIcon() As IPictureDisp ``` Returns/sets the icon displayed during a drag-and-drop operation. ### DragMode ```vb Property Get/Let DragMode() As Integer ``` Returns/sets the drag mode (manual or automatic). ### hWnd ```vb Property Get hWnd() As LongPtr ``` Returns the window handle of the date-time picker control. ### hWndUserControl ```vb Property Get hWndUserControl() As LongPtr ``` Returns the window handle of the UserControl. ### hWndCalendar ```vb Property Get hWndCalendar() As LongPtr ``` Returns the window handle of the drop-down calendar control. ### Font ```vb Property Get/Let/Set Font() As StdFont ``` Returns/sets the control font. ### CalendarFont ```vb Property Get/Let/Set CalendarFont() As StdFont ``` Returns/sets the drop-down calendar font. ### VisualStyles ```vb Property Get/Let VisualStyles() As Boolean ``` Returns/sets whether visual styles are enabled. ### Enabled ```vb Property Get/Let Enabled() As Boolean ``` Returns/sets whether the control responds to user events. ### OLEDropMode ```vb Property Get/Let OLEDropMode() As OLEDropModeConstants ``` Returns/sets whether the object can act as an OLE drop target. See common enumerations. ### MousePointer ```vb Property Get/Let MousePointer() As CCMousePointerConstants ``` Returns/sets the mouse pointer type. See common enumerations. ### MouseIcon ```vb Property Get/Let/Set MouseIcon() As IPictureDisp ``` Returns/sets the custom mouse icon. ### MouseTrack ```vb Property Get/Let MouseTrack() As Boolean ``` Returns/sets whether MouseEnter/MouseLeave events are fired. ### RightToLeft ```vb Property Get/Let RightToLeft() As Boolean ``` Determines the text display direction and visual appearance of the control on bidirectional systems. ### RightToLeftLayout ```vb Property Get/Let RightToLeftLayout() As Boolean ``` Returns/sets whether right-to-left mirrored layout is enabled. ### RightToLeftMode ```vb Property Get/Let RightToLeftMode() As CCRightToLeftModeConstants ``` Returns/sets the right-to-left mode. See common enumerations. ### CalendarBackColor ```vb Property Get/Let CalendarBackColor() As OLE_COLOR ``` Returns/sets the background color of the calendar month area. ### CalendarForeColor ```vb Property Get/Let CalendarForeColor() As OLE_COLOR ``` Returns/sets the foreground color of the calendar month area. ### CalendarTitleBackColor ```vb Property Get/Let CalendarTitleBackColor() As OLE_COLOR ``` Returns/sets the background color of the calendar title. ### CalendarTitleForeColor ```vb Property Get/Let CalendarTitleForeColor() As OLE_COLOR ``` Returns/sets the foreground color of the calendar title. ### CalendarTrailingForeColor ```vb Property Get/Let CalendarTrailingForeColor() As OLE_COLOR ``` Returns/sets the foreground color of the calendar trailing dates. ### CalendarShowToday ```vb Property Get/Let CalendarShowToday() As Boolean ``` Returns/sets whether the calendar displays the "today" date at the bottom. ### CalendarShowTodayCircle ```vb Property Get/Let CalendarShowTodayCircle() As Boolean ``` Returns/sets whether a circle is drawn around today's date. ### CalendarShowWeekNumbers ```vb Property Get/Let CalendarShowWeekNumbers() As Boolean ``` Returns/sets whether the calendar displays week numbers. ### CalendarShowTrailingDates ```vb Property Get/Let CalendarShowTrailingDates() As Boolean ``` Returns/sets whether the calendar displays dates from the previous/next month. ### CalendarAlignment ```vb Property Get/Let CalendarAlignment() As CCLeftRightAlignmentConstants ``` Returns/sets the alignment of the calendar. See common enumerations. ### CalendarDayState ```vb Property Get/Let CalendarDayState() As Boolean ``` Returns/sets whether the calendar supports bold dates in the CalendarGetDayBold event. ### CalendarUseShortestDayNames ```vb Property Get/Let CalendarUseShortestDayNames() As Boolean ``` Returns/sets whether the calendar uses the shortest day names. ### MinDate ```vb Property Get/Let MinDate() As Date ``` Returns/sets the minimum selectable date. ### MaxDate ```vb Property Get/Let MaxDate() As Date ``` Returns/sets the maximum selectable date. ### Value ```vb Property Get/Let Value() As Variant ``` Returns/sets the current date-time value. ### Year ```vb Property Get Year() As Integer ``` Returns the year of the current date (read-only). ### Month ```vb Property Get Month() As Integer ``` Returns the month of the current date (read-only). ### Week ```vb Property Get Week() As Integer ``` Returns the week number of the current date (read-only). ### Day ```vb Property Get Day() As Integer ``` Returns the day of the current date (read-only). ### Hour ```vb Property Get Hour() As Integer ``` Returns the hour of the current time (read-only). ### Minute ```vb Property Get Minute() As Integer ``` Returns the minute of the current time (read-only). ### Second ```vb Property Get Second() As Integer ``` Returns the second of the current time (read-only). ### Format ```vb Property Get/Let Format() As DtpFormatConstants ``` Returns/sets the display format of the date-time. ### CustomFormat ```vb Property Get/Let CustomFormat() As String ``` Returns/sets the custom format string. ### UpDown ```vb Property Get/Let UpDown() As Boolean ``` Returns/sets whether to use up/down buttons instead of a drop-down calendar. ### CheckBox ```vb Property Get/Let CheckBox() As Boolean ``` Returns/sets whether a check box is displayed in the control. ### AllowUserInput ```vb Property Get/Let AllowUserInput() As Boolean ``` Returns/sets whether the user can directly input dates. ### StartOfWeek ```vb Property Get/Let StartOfWeek() As Integer ``` Returns/sets the first day of the week (0=system default, 1=Monday, ..., 7=Sunday). ### DroppedDown ```vb Property Get DroppedDown() As Boolean ``` Returns whether the calendar is in the dropped-down state (read-only). ### Selected ```vb Property Get Selected() As Boolean ``` Returns whether the check box is checked (read-only). ### DayCount ```vb Property Get DayCount() As Long ``` Returns the number of currently visible dates (read-only). ### DayOfWeek ```vb Property Get DayOfWeek() As Integer ``` Returns the day of the week for the current date (read-only). ### SystemStartOfWeek ```vb Property Get SystemStartOfWeek() As Integer ``` Returns the system setting for the first day of the week (read-only). ## Methods ### OLEDrag ```vb Public Sub OLEDrag() ``` Initiates an OLE drag-and-drop operation. ### Drag ```vb Public Sub Drag(Optional ByRef Action As Variant) ``` Starts, ends, or cancels a drag operation. ### SetFocus ```vb Public Sub SetFocus() ``` Moves focus to the control. ### ZOrder ```vb Public Sub ZOrder(Optional ByRef Position As Variant) ``` Places the control at the front or back of the Z-order. ### Refresh ```vb Public Sub Refresh() ``` Forces the control to repaint. ### GetIdealSize ```vb Public Sub GetIdealSize(ByRef Width As Long, ByRef Height As Long) ``` Retrieves the ideal size of the control. ## Events ### Click ```vb Public Event Click() ``` Occurs when the user presses and releases a mouse button. ### DropDown ```vb Public Event DropDown() ``` Occurs when the drop-down calendar is about to be displayed. ### CloseUp ```vb Public Event CloseUp() ``` Occurs when the user closes the calendar. ### Change ```vb Public Event Change() ``` Occurs when the contents of the control change. ### ContextMenu ```vb Public Event ContextMenu(ByRef Handled As Boolean, ByVal X As Single, ByVal Y As Single) ``` Occurs when the user right-clicks or presses Shift+F10. ### CalendarGetDayBold ```vb Public Event CalendarGetDayBold(ByVal StartDate As Date, ByVal Count As Long, ByRef State() As Boolean) ``` Occurs when the calendar requests bold date information. Requires comctl32.dll version 6.1 or later. ### CalendarContextMenu ```vb Public Event CalendarContextMenu(ByRef Handled As Boolean, ByVal X As Single, ByVal Y As Single) ``` Occurs when the calendar area is right-clicked. ### CallbackKeyDown ```vb Public Event CallbackKeyDown(ByVal KeyCode As Integer, ByVal Shift As Integer, ByVal CallbackField As String, ByRef CallbackDate As Date) ``` Occurs when the user presses a key on a callback field. ### FormatString ```vb Public Event FormatString(ByVal CallbackField As String, ByRef FormattedString As String) ``` Occurs when the control requests the display text for a callback field. ### FormatSize ```vb Public Event FormatSize(ByVal CallbackField As String, ByRef Size As Integer) ``` Occurs when the control needs to know the maximum allowed size of a callback field. ### BeforeUserInput ```vb Public Event BeforeUserInput(ByVal hWndEdit As LongPtr) ``` Occurs when the user attempts to input a string. ### ParseUserInput ```vb Public Event ParseUserInput(ByVal Text As String, ByRef ParseDate As Variant) ``` Occurs when the user has finished input, requiring parsing of the input string. ### AfterUserInput ```vb Public Event AfterUserInput() ``` Occurs when user input has been completed or cancelled. ### PreviewKeyDown ```vb Public Event PreviewKeyDown(ByVal KeyCode As Integer, ByRef IsInputKey As Boolean) ``` Occurs before the KeyDown event. ### PreviewKeyUp ```vb Public Event PreviewKeyUp(ByVal KeyCode As Integer, ByRef IsInputKey As Boolean) ``` Occurs before the KeyUp event. ### KeyDown ```vb Public Event KeyDown(KeyCode As Integer, Shift As Integer) ``` Occurs when the user presses a key. ### KeyUp ```vb Public Event KeyUp(KeyCode As Integer, Shift As Integer) ``` Occurs when the user releases a key. ### KeyPress ```vb Public Event KeyPress(KeyChar As Integer) ``` Occurs when the user presses and releases a character key. ### MouseDown ```vb Public Event MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` Occurs when the user presses a mouse button. ### MouseMove ```vb Public Event MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` Occurs when the user moves the mouse. ### MouseUp ```vb Public Event MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` Occurs when the user releases a mouse button. ### MouseEnter ```vb Public Event MouseEnter() ``` Occurs when the mouse enters the control. ### MouseLeave ```vb Public Event MouseLeave() ``` Occurs when the mouse leaves the control. ### OLECompleteDrag ```vb Public Event OLECompleteDrag(Effect As Long) ``` Occurs when an OLE drag-and-drop operation has completed. ### OLEDragDrop ```vb Public Event OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single) ``` Occurs when data is dropped on the control via an OLE drag-and-drop operation. ### OLEDragOver ```vb Public Event OLEDragOver(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single, State As Integer) ``` Occurs when the mouse passes over the control during an OLE drag-and-drop operation. ### OLEGiveFeedback ```vb Public Event OLEGiveFeedback(Effect As Long, DefaultCursors As Boolean) ``` Occurs when the mouse cursor needs to be changed. ### OLESetData ```vb Public Event OLESetData(Data As DataObject, DataFormat As Integer) ``` Occurs when the drop target requests data. ### OLEStartDrag ```vb Public Event OLEStartDrag(Data As DataObject, AllowedEffects As Long) ``` Occurs when an OLE drag-and-drop operation is initiated. ## Code Examples ### Basic Usage ```vb Private Sub Form_Load() With DTPicker1 .Format = DtpFormatShortDate .Value = Date .MinDate = #1/1/1900# .MaxDate = #12/31/9999# End With End Sub Private Sub DTPicker1_Change() MsgBox "Selected date: " & DTPicker1.Value End Sub ``` ### Custom Format and Callback ```vb Private Sub Form_Load() DTPicker1.Format = DtpFormatCustom DTPicker1.CustomFormat = "yyyy年MM月dd日 '第' w '周'" End Sub Private Sub DTPicker1_FormatString(ByVal CallbackField As String, ByRef FormattedString As String) Select Case CallbackField Case "w" FormattedString = CStr(DatePart("ww", DTPicker1.Value, vbMonday)) End Select End Sub ``` --- --- url: /en/EULA.md --- # End User License Agreement ## **VBMAN Product Series Usage Agreement and Disclaimer** \*\*IMPORTANT NOTICE: Before you download, install, use, or in any way access any VBMAN product series (including but not limited to software, code, scripts, documents, and related materials, hereinafter referred to as "this Product") provided by this website (hereinafter referred to as "this Website"), please carefully read and fully understand all terms of this agreement. Any download, installation, or use by you shall be deemed as you have **fully understood, acknowledged, and unconditionally accepted** all terms of this agreement without reservation. If you do not agree with any content of this agreement, please \*\*immediately stop\*\* accessing this website and using this Product in any manner. ### **Article 1: Product Purpose Declaration** 1.1 This Product is limited to **legal, legitimate, and healthy** purposes. Users promise to comply with all current laws, regulations, and public order and good morals of their country, region, and place of use. 1.2 It is **strictly prohibited** for any user to use this Product for any illegal, infringing, fraudulent, network security destructive, privacy infringing, malicious information disseminating, or any activities that violate the laws and regulations of the People's Republic of China and international legal standards. ### **Article 2: User Responsibilities and Conduct Standards** 2.1 Users understand and agree that the manner of their use, their behavior, and all consequences arising therefrom **are solely their own responsibility**. Users should independently determine the legality of their use behavior and bear all legal responsibilities resulting therefrom. 2.2 Users have an obligation to ensure that their use behavior does not infringe upon the legitimate rights and interests of any third party (including but not limited to intellectual property rights, privacy rights, reputation rights, etc.), and does not damage public interests. ### **Article 3: Website Disclaimer** 3.1 This Website and the Product author (hereinafter referred to as "the Author") **only provide this Product itself**, and do not assume any direct, indirect, incidental, special, punitive, or derivative liability for **how users use it, under what circumstances it is used, and all consequences resulting from use**. 3.2 If any third party or administrative authority makes any claims, demands, or causes any losses to this Website or the Author due to users violating this agreement or relevant laws and regulations, users shall be responsible for handling such matters and bear all compensation expenses, and ensure that this Website and the Author are free from any harm. 3.3 Users expressly know and agree that any subsequent illegal acts by users are **completely unrelated to this Website and the Author**. Legal responsibility shall be **independently borne by the user themselves**. ### **Article 4: Review and Cooperation Obligations** 4.1 Despite the foregoing disclaimer, the Author solemnly promises to strictly comply with national laws and regulations and fulfill the obligations of citizens and enterprises. 4.2 If the use of this Product by users is suspected of being illegal, and when national competent authorities (such as public security organs, judicial organs, cyberspace administration departments, etc.) make review requests in accordance with legal procedures, **the Author will provide necessary cooperation in accordance with the law**, including but not limited to providing relevant download records, user information, and other materials required by law. However, such cooperation does not constitute the Author's approval of user behavior or assumption of responsibility. ### **Article 5: Agreement Modification and Interpretation Rights** 5.1 The Author reserves the right to unilaterally modify the terms of this agreement when necessary and publish them on this website without separate notice to users. The modified agreement shall take effect from the date of publication. 5.2 If users continue to use this Product, it shall be deemed as acceptance of the modified agreement; if they do not agree with the modified content, they should immediately stop using it. 5.3 The interpretation rights and legal validity of this agreement shall be based on the laws of the People's Republic of China. If any term of this agreement is deemed invalid or unenforceable, it shall not affect the continued validity of the remaining terms. *** **Final Reminder: Technology itself is neither good nor evil, it depends on human intentions. Please be sure to use this Product for righteous purposes and work together to maintain a clean and healthy cyberspace. Your download and use represent your solemn promise to comply with all the above terms.** *** --- --- url: /en/vbman/Toast/examples.md --- # Examples Practical examples for various usage scenarios of cToast. ## Table of Contents * [Basic Examples](#basic-examples) * [Position Control Examples](#position-control-examples) * [State and Theme Examples](#state-and-theme-examples) * [Stacking Management Examples](#stacking-management-examples) * [Popup Management Examples](#popup-management-examples) * [Event Listener Examples](#event-listener-examples) * [Real-world Scenarios](#real-world-scenarios) * [Best Practices](#best-practices) ## Basic Examples ### 1. Simple Information Notification ```vb With New cToast .Show "This is a simple information notification" End With ``` ### 2. Success Notification with Title ```vb With New cToast .State(Success).Show "File saved successfully", 2000, "Success" End With ``` ### 3. Warning Notification with Custom Duration ```vb With New cToast .State(Warning).Show "Disk space is running low", 5000, "Warning" End With ``` ### 4. Error Notification ```vb With New cToast .State(Danger).Show "Operation failed, please try again", 3000, "Error" End With ``` ### 5. Dark Theme Notification ```vb With New cToast .Theme(Dark).State(Info).Show "Dark theme notification", 2000 End With ``` ### 6. Persistent Display (No Auto Close) ```vb With New cToast .State(Info).Show "This message will not auto-close", 0, "Important" End With ``` ### 7. Long Text Content ```vb Dim msg As String msg = "This is a long message that may span multiple lines. " & _ "cToast automatically handles text wrapping and display." With New cToast .State(Info).Show msg, 5000, "Long Message" End With ``` ### 8. Empty Title (No Title Display) ```vb With New cToast .Show "Notification without title", 2000, "" End With ``` ### 9. Empty Content (Only Title) ```vb With New cToast .Show "", 2000, "Title Only" End With ``` ### 10. Very Short Duration (1 Second) ```vb With New cToast .State(Success).Show "Quick flash", 1000, "Quick" End With ``` ## Position Control Examples ### 11. Top-Left Corner Display ```vb With New cToast .Pos(LeftTop).State(Info).Show "Top-left notification", 2000 End With ``` ### 12. Top-Right Corner Display ```vb With New cToast .Pos(RightTop).State(Success).Show "Top-right notification", 2000 End With ``` ### 13. Bottom-Left Corner Display ```vb With New cToast .Pos(LeftBottom).State(Warning).Show "Bottom-left notification", 2000 End With ``` ### 14. Bottom-Right Corner Display ```vb With New cToast .Pos(RightBottom).State(Danger).Show "Bottom-right notification", 2000 End With ``` ### 15. Center Display ```vb With New cToast .Pos(Center).State(Info).Show "Center notification", 3000, "Center" End With ``` ### 16. Top-Center Display ```vb With New cToast .Pos(CenterTop).State(Success).Show "Top-center notification", 2000 End With ``` ### 17. Bottom-Center Display ```vb With New cToast .Pos(CenterBottom).State(Warning).Show "Bottom-center notification", 2000 End With ``` ### 18. Left-Center Display ```vb With New cToast .Pos(LeftCenter).State(Info).Show "Left-center notification", 2000 End With ``` ### 19. Right-Center Display ```vb With New cToast .Pos(RightCenter).State(Danger).Show "Right-center notification", 2000 End With ``` ## State and Theme Examples ### 20. All Four States ```vb ' Information With New cToast .Pos(RightTop).State(Info).Show "Information message", 2000, "Info" End With ' Success With New cToast .Pos(RightTop).State(Success).Show "Success message", 2000, "Success" End With ' Warning With New cToast .Pos(RightTop).State(Warning).Show "Warning message", 2000, "Warning" End With ' Danger With New cToast .Pos(RightTop).State(Danger).Show "Error message", 2000, "Error" End With ``` ### 21. Light Theme (Default) ```vb With New cToast .Theme(Light).State(Info).Show "Light theme message", 2000 End With ``` ### 22. Dark Theme ```vb With New cToast .Theme(Dark).State(Info).Show "Dark theme message", 2000 End With ``` ### 23. State + Theme Combination ```vb ' Dark theme + Success With New cToast .Theme(Dark).State(Success).Show "Dark + Success", 2000 End With ' Dark theme + Danger With New cToast .Theme(Dark).State(Danger).Show "Dark + Danger", 2000 End With ' Light theme + Warning With New cToast .Theme(Light).State(Warning).Show "Light + Warning", 2000 End With ``` ## Stacking Management Examples ### 24. Top-Right Auto Stacking (Sequential) ```vb With New cToast .Pos(RightTop) ' Messages will stack from top to bottom .State(Info).Show "First message", 0 .State(Success).Show "Second message", 0 .State(Warning).Show "Third message", 0 .State(Danger).Show "Fourth message", 0 End With ``` ### 25. Bottom-Center Auto Stacking (Reverse) ```vb With New cToast .Pos(CenterBottom) ' Messages will stack from bottom to top (reverse) .State(Info).Show "First message (bottom)", 0 .State(Success).Show "Second message", 0 .State(Warning).Show "Third message", 0 .State(Danger).Show "Fourth message (top)", 0 End With ``` ### 26. Manual Stacking Index ```vb With New cToast .Pos(RightTop) ' Specify stack index manually .InstIndex(0).State(Info).Show "Message at index 0", 0 .InstIndex(1).State(Success).Show "Message at index 1", 0 .InstIndex(2).State(Warning).Show "Message at index 2", 0 End With ``` ### 27. Batch Stacking in Loop ```vb Dim i As Integer Dim Toast As New cToast Toast.Pos(RightTop) For i = 1 To 5 Toast.State(Info).Show "Message " & i, 3000, "Batch" Next i ``` ## Popup Management Examples ### 28. Named Popup Management ```vb Dim Toast As New cToast ' Display named popups Toast.Tag("msg1").Pos(RightTop).State(Info).Show "Message 1", 0 Toast.Tag("msg2").Pos(RightTop).State(Success).Show "Message 2", 0 Toast.Tag("msg3").Pos(RightTop).State(Warning).Show "Message 3", 0 ' Close specific popup Toast.CloseMe "msg2" ' Check if exists If Toast.Exists("msg1") Then Debug.Print "msg1 still exists" End If ``` ### 29. Batch Close All ```vb Dim Toast As New cToast ' Display multiple popups Toast.Pos(RightTop).State(Info).Show "Message 1", 0 Toast.Pos(RightTop).State(Success).Show "Message 2", 0 Toast.Pos(RightTop).State(Warning).Show "Message 3", 0 ' Close all at once Toast.CloseAll ``` ### 30. Get Active Popup List ```vb Dim Toast As New cToast Dim Keys As Collection Dim Key As Variant ' Display some popups Toast.Pos(RightTop).State(Info).Show "Message 1", 0 Toast.Pos(RightTop).State(Success).Show "Message 2", 0 ' Get all active popups Set Keys = Toast.ActiveKeys Debug.Print "Total popups: " & Toast.Count For Each Key In Keys Debug.Print "Active popup: " & CStr(Key) Next Key ``` ### 31. Conditional Close ```vb Dim Toast As New cToast Toast.Tag("important").State(Danger).Show "Important message", 0 Toast.Tag("normal").State(Info).Show "Normal message", 0 ' Close specific popups Toast.CloseMe "normal" ' Only important message remains ``` ## Event Listener Examples ### 32. Monitor Popup Count Changes ```vb Private WithEvents Toast As cToast Private Sub Form_Load() Set Toast = New cToast End Sub Private Sub Toast_OnToastCountChange(ByVal TagName As String, _ ByVal IsDelete As Boolean, _ ByVal CurrentCount As Long) If IsDelete Then Debug.Print "Popup " & TagName & " was closed, remaining: " & CurrentCount Else Debug.Print "Popup " & TagName & " was created, total: " & CurrentCount End If End Sub ``` ### 33. Monitor Batch Close Event ```vb Private WithEvents Toast As cToast Private Sub Toast_OnCloseAll(ByVal ClosedCount As Long) Debug.Print "Batch closed " & ClosedCount & " popups" ' Can trigger other operations RefreshUI LogStatistics ClosedCount End Sub ``` ### 34. Update UI Based on Events ```vb Private WithEvents Toast As cToast Private Sub Toast_OnToastCountChange(ByVal TagName As String, _ ByVal IsDelete As Boolean, _ ByVal CurrentCount As Long) ' Update UI control lblToastCount.Caption = "Current: " & CurrentCount ' Refresh popup list RefreshPopupList End Sub Private Sub RefreshPopupList() Dim Keys As Collection Dim Key As Variant lstToasts.Clear Set Keys = Toast.ActiveKeys If Keys.Count > 0 Then For Each Key In Keys lstToasts.AddItem CStr(Key) Next Key Else lstToasts.AddItem "(No active popups)" End If End Sub ``` ## Real-world Scenarios ### 35. File Download Progress Notification ```vb Private Sub NotifyDownloadProgress(ByVal FileName As String, ByVal Progress As Long) Dim TagName As String TagName = "download_" & FileName With New cToast .Pos(RightBottom).Tag(TagName) _ .State(Info) _ .Show "Downloading: " & FileName & vbCrLf & "Progress: " & Progress & "%", _ 0, "Download" End With End Sub ' Complete download Private Sub NotifyDownloadComplete(ByVal FileName As String) Dim TagName As String TagName = "download_" & FileName Dim Toast As New cToast Toast.CloseMe TagName ' Show completion notification With New cToast .Pos(RightBottom).State(Success) _ .Show FileName & " download complete!", 3000, "Download Complete" End With End Sub ``` ### 36. Form Validation Error Notification ```vb Private Sub ValidateForm() As Boolean Dim hasError As Boolean hasError = False If txtName.Text = "" Then With New cToast .Pos(RightTop).State(Danger) _ .Show "Please enter name", 3000, "Validation Error" End With hasError = True End If If txtEmail.Text = "" Then With New cToast .Pos(RightTop).State(Danger) _ .Show "Please enter email", 3000, "Validation Error" End With hasError = True End If ValidateForm = Not hasError End Sub ``` ### 37. Database Operation Notification ```vb Private Sub SaveToDatabase() On Error GoTo ErrorHandler ' Simulate database operation ' ... database save code ... ' Success notification With New cToast .Pos(Center).State(Success) _ .Show "Data saved successfully!", 2000, "Success" End With Exit Sub ErrorHandler: ' Error notification With New cToast .Pos(Center).State(Danger) _ .Show "Failed to save data: " & Err.Description, 5000, "Error" End With End Sub ``` ### 38. Network Request Notification ```vb Private Sub MakeAPIRequest() Dim Toast As New cToast ' Show loading notification Toast.Tag("api_loading").Pos(Center).State(Info) _ .Show "Sending request, please wait...", 0, "Request" ' Simulate API request ' ... API call code ... ' Close loading Toast.CloseMe "api_loading" ' Show result With New cToast .Pos(RightTop).State(Success) _ .Show "Request successful!", 2000, "API" End With End Sub ``` ### 39. Background Task Notification ```vb Private Sub BackgroundTaskProgress() Dim i As Integer Dim Toast As New cToast Toast.Pos(RightBottom).Tag("bg_task") For i = 1 To 10 ' Update progress Toast.CloseMe "bg_task" Toast.State(Info).Show "Processing: " & (i * 10) & "%", 0, "Background Task" ' Simulate work DoEvents Sleep 500 Next i ' Complete Toast.CloseMe "bg_task" With New cToast .State(Success).Show "Task complete!", 2000, "Background Task" End With End Sub ``` ### 40. System Maintenance Notification ```vb Private Sub ShowMaintenanceNotice() With New cToast .Pos(Center).State(Warning).Theme(Dark) _ .Show "System will undergo maintenance at 22:00 tonight." & vbCrLf & _ "Please save your work.", 0, "System Notice" End With End Sub ``` ### 41. User Login Notification ```vb Private Sub HandleLoginSuccess(ByVal UserName As String) With New cToast .Pos(RightTop).State(Success) _ .Show "Welcome back, " & UserName & "!", 3000, "Login" End With End Sub Private Sub HandleLoginFailure() With New cToast .Pos(RightTop).State(Danger) _ .Show "Login failed, please check username and password", 3000, "Login Failed" End With End Sub ``` ### 42. Multi-Language Notification ```vb Private Sub ShowNotification(ByVal Lang As String) Dim msg As String Dim title As String If Lang = "zh" Then msg = "操作成功完成" title = "提示" ElseIf Lang = "en" Then msg = "Operation completed successfully" title = "Notice" Else msg = "操作成功完成" title = "提示" End If With New cToast .Pos(RightTop).State(Success).Show msg, 2000, title End With End Sub ``` ## Best Practices ### 1. Choose Appropriate Positions ```vb ' Tips: Use different positions for different scenarios ' Important notifications: Center With New cToast .Pos(Center).State(Danger).Show "Critical error!", 0, "Important" End With ' Success notifications: Right-top With New cToast .Pos(RightTop).State(Success).Show "Saved successfully", 2000 End With ' System notifications: Bottom-center With New cToast .Pos(CenterBottom).State(Info).Show "System update available", 0 End With ``` ### 2. Reasonable Duration Settings ```vb ' Quick notification: 1-2 seconds With New cToast .State(Success).Show "Quick notification", 1000 End With ' Normal notification: 2-3 seconds With New cToast .State(Info).Show "Normal notification", 2000 End With ' Important notification: 5 seconds With New cToast .State(Warning).Show "Important notification", 5000 End With ' Critical notification: No auto-close With New cToast .State(Danger).Show "Critical notification, user must acknowledge", 0 End With ``` ### 3. Proper Resource Management ```vb Private Sub ProperToastUsage() Dim Toast As New cToast ' Use Toast ' Release resources promptly Set Toast = Nothing End Sub ``` ### 4. Use Global Singleton for Quick Notifications ```vb ' Quick notification anywhere VBMAN.Toast.State(Success).Show "Operation complete", 2000 ``` ### 5. Avoid Popup Overload ```vb ' Bad practice: Too many notifications For i = 1 To 50 VBMAN.Toast.Show "Message " & i Next i ' Good practice: Batch notification or limit quantity With New cToast .Show "50 operations completed", 2000 End With ``` ### 6. Use Appropriate State Colors ```vb ' Information: Blue .State(Info).Show "System information", 2000 ' Success: Green .State(Success).Show "Operation successful", 2000 ' Warning: Yellow .State(Warning).Show "Disk space low", 2000 ' Error: Red .State(Danger).Show "Operation failed", 2000 ``` ### 7. Clear and Concise Content ```vb ' Bad: Too long .Show "This is a very long message that users may not have time to read completely", 2000 ' Good: Concise .Show "Operation successful", 2000 ``` ### 8. Provide Meaningful Titles ```vb ' Bad: No title .Show "Operation failed", 2000, "" ' Good: Clear title .Show "Operation failed", 2000, "Error" ``` ### 9. Use Hover Pause Effect ```vb ' Users can hover to extend viewing time .Show "This message will pause on hover", 2000 ``` ### 10. Event-Driven UI Updates ```vb Private WithEvents Toast As cToast Private Sub Toast_OnToastCountChange(ByVal TagName As String, _ ByVal IsDelete As Boolean, _ ByVal CurrentCount As Long) ' Automatically update UI UpdateToastCountDisplay CurrentCount End Sub ``` --- --- url: /en/vbman/database/execute.md --- # Execute Operations This document details the data modification operations of the cDataBase class, including INSERT, UPDATE, DELETE, etc. *** ## Table of Contents * [Exec Method](#exec-method) * [INSERT Operations](#insert-operations) * [UPDATE Operations](#update-operations) * [DELETE Operations](#delete-operations) * [Get Affected Rows](#get-affected-rows) * [Get Last Insert ID](#get-last-insert-id) * [Batch Operations](#batch-operations) *** ## Exec Method ### Basic Syntax The `Exec` method executes non-query SQL statements like INSERT, UPDATE, DELETE. #### Syntax ```vb Function Exec(Optional RecordsAffected, Optional Options As Long = -1) As Boolean ``` #### Parameters | Parameter | Type | Description | | ----------------- | --------- | ------------------------------------------ | | `RecordsAffected` | `Variant` | Returns number of affected rows (optional) | | `Options` | `Long` | Execution options (optional, default -1) | #### Return Value * `True` - Execution successful * `False` - Execution failed (view error via `LastErr`) #### Example ```vb ' Execute INSERT statement If db.Sql("INSERT INTO users (name, age) VALUES ('John', 25)").Exec Then Debug.Print "Insert successful" Else Debug.Print "Insert failed: " & db.LastErr End If ``` *** ## INSERT Operations ### Basic Insert ```vb ' Insert single record If db.Sql("INSERT INTO users (name, age, email) VALUES ('John', 25, 'john@example.com')").Exec Then Debug.Print "Insert successful" End If ``` ### Insert Multiple Records ```vb ' Insert multiple using VALUES clause Dim sSql As String sSql = "INSERT INTO users (name, age) VALUES " & _ "('John', 25), " & _ "('Mary', 30), " & _ "('Bob', 28)" If db.Sql(sSql).Exec Then Debug.Print "Batch insert successful" End If ``` ### Using Parameterized Insert ```vb ' Use parameterized query (recommended, prevents SQL injection) If db.Sql("INSERT INTO users (name, age, email) VALUES (?, ?, ?)") _ .Param("name", "John", VBMAN.adVarWChar) _ .Param("age", 25, VBMAN.adInteger) _ .Param("email", "john@example.com", VBMAN.adVarWChar) _ .ExecParam Then Debug.Print "Insert successful, ID: " & db.LastInsertId End If ``` ### INSERT SELECT ```vb ' Insert data from other table If db.Sql("INSERT INTO users_backup SELECT * FROM users WHERE age > 30").Exec Then Debug.Print "Data copy successful" End If ``` *** ## UPDATE Operations ### Basic Update ```vb ' Update single record If db.Sql("UPDATE users SET age = 26 WHERE id = 1").Exec Then Debug.Print "Update successful" End If ``` ### Update Multiple Records ```vb ' Batch update If db.Sql("UPDATE users SET status = 'active' WHERE age > 18").Exec Then Debug.Print "Batch update successful" End If ``` ### Using Parameterized Update ```vb ' Use parameterized query If db.Sql("UPDATE users SET age = ?, email = ? WHERE id = ?") _ .Param("age", 26, VBMAN.adInteger) _ .Param("email", "newemail@example.com", VBMAN.adVarWChar) _ .Param("id", 1, VBMAN.adInteger) _ .ExecParam Then Debug.Print "Update successful" End If ``` ### Conditional Update ```vb ' Complex conditional update Dim sSql As String sSql = "UPDATE users SET status = 'inactive' " & _ "WHERE last_login < DATEADD(day, -30, GETDATE())" If db.Sql(sSql).Exec Then Debug.Print "Expired users marked" End If ``` *** ## DELETE Operations ### Basic Delete ```vb ' Delete single record If db.Sql("DELETE FROM users WHERE id = 1").Exec Then Debug.Print "Delete successful" End If ``` ### Batch Delete ```vb ' Delete multiple records If db.Sql("DELETE FROM users WHERE age < 18").Exec Then Debug.Print "Batch delete successful" End If ``` ### Using Parameterized Delete ```vb ' Use parameterized query If db.Sql("DELETE FROM users WHERE id = ?") _ .Param("id", 1, VBMAN.adInteger) _ .ExecParam Then Debug.Print "Delete successful" End If ``` ### Truncate Table ```vb ' Clear table (note: deletes all data) If db.Sql("DELETE FROM users").Exec Then Debug.Print "Table cleared" End If ' Or use TRUNCATE (faster, but cannot be rolled back) If db.Sql("TRUNCATE TABLE users").Exec Then Debug.Print "Table cleared" End If ``` *** ## Get Affected Rows ### RecordsAffected Parameter ```vb ' Get number of affected rows Dim lAffected As Long If db.Sql("UPDATE users SET status = 'active' WHERE age > 18").Exec(lAffected) Then Debug.Print "Updated " & lAffected & " records" End If ``` ### Examples ```vb ' INSERT operation Dim lAffected As Long If db.Sql("INSERT INTO users (name) VALUES ('John')").Exec(lAffected) Then Debug.Print "Inserted " & lAffected & " records" End If ' UPDATE operation If db.Sql("UPDATE users SET status = 'active'").Exec(lAffected) Then Debug.Print "Updated " & lAffected & " records" End If ' DELETE operation If db.Sql("DELETE FROM users WHERE age < 18").Exec(lAffected) Then Debug.Print "Deleted " & lAffected & " records" End If ``` *** ## Get Last Insert ID ### LastInsertId Method The `LastInsertId` method gets the auto-increment primary key ID of the last insert. #### Syntax ```vb Function LastInsertId() As Variant ``` #### Supported Databases * SQL Server - Uses `SCOPE_IDENTITY()` * MySQL - Uses `LAST_INSERT_ID()` * Access - Uses `@@IDENTITY` #### Example ```vb ' Insert data If db.Sql("INSERT INTO users (name, age) VALUES ('John', 25)").Exec Then ' Get last inserted ID Dim lId As Variant lId = db.LastInsertId Debug.Print "New user ID: " & lId End If ``` ### Notes 1. **Must call immediately after INSERT** ```vb ' Correct db.Sql("INSERT INTO users (name) VALUES ('John')").Exec Dim lId As Variant lId = db.LastInsertId ' Wrong: Other operations in between db.Sql("INSERT INTO users (name) VALUES ('John')").Exec db.Sql("SELECT * FROM users").Query ' This resets the ID Dim lId As Variant lId = db.LastInsertId ' May not get the correct ID ``` 2. **Only supports auto-increment primary key** ```vb ' Table must have auto-increment primary key CREATE TABLE users ( id INT IDENTITY(1,1) PRIMARY KEY, -- SQL Server name NVARCHAR(50) ) ``` *** ## Batch Operations ### BatchInsert Method The `BatchInsert` method inserts data in batches using transactions to ensure data consistency. #### Syntax ```vb Function BatchInsert(ByVal TableName As String, ByVal Data As Collection) As Boolean ``` #### Parameters | Parameter | Type | Description | | ----------- | ------------ | ------------------------------------------------------ | | `TableName` | `String` | Table name (required) | | `Data` | `Collection` | Data collection, each element is Dictionary (required) | #### Example ```vb ' Prepare data Dim colData As New Collection Dim dictRow As Dictionary ' First row Set dictRow = New Dictionary dictRow.Add "name", "John" dictRow.Add "age", 25 dictRow.Add "email", "john@example.com" colData.Add dictRow ' Second row Set dictRow = New Dictionary dictRow.Add "name", "Mary" dictRow.Add "age", 30 dictRow.Add "email", "mary@example.com" colData.Add dictRow ' Batch insert If db.BatchInsert("users", colData) Then Debug.Print "Batch insert successful" Else Debug.Print "Batch insert failed: " & db.LastErr End If ``` ### Batch Update ```vb ' Use transaction for batch update db.TransBegin Dim i As Long For i = 1 To 100 Dim sSql As String sSql = "UPDATE users SET status = 'active' WHERE id = " & i If Not db.Sql(sSql).Exec Then db.TransRollback Exit For End If Next If db.TransCommit Then Debug.Print "Batch update successful" End If ``` *** ## Asynchronous Execution ### Async Property Use the `Async` property to execute SQL statements asynchronously. ```vb ' Asynchronous execution db.Sql("INSERT INTO users (name) VALUES ('John')").Async.Exec ' Listen for completion event Private Sub db_AsyncExecuteComplete(ByVal RecordsAffected As Long, _ ByVal pError As ADODB.Error, _ adStatus As ADODB.EventStatusEnum, _ ByVal pCommand As ADODB.Command, _ ByVal pRecordset As ADODB.Recordset, _ ByVal pConnection As ADODB.Connection) If pError Is Nothing Then Debug.Print "Async execution successful, rows affected: " & RecordsAffected Else Debug.Print "Async execution failed: " & pError.Description End If End Sub ``` *** ## Error Handling ```vb ' Execution error handling If Not db.Sql("INSERT INTO users (name) VALUES ('John')").Exec Then Debug.Print "Execution failed" Debug.Print "Error code: " & db.LastErrNumber Debug.Print "Error description: " & db.LastErrDescription Debug.Print "Full info: " & db.LastErr Exit Sub End If ``` *** ## Best Practices ### 1. Use Parameterized Queries ```vb ' Recommended: Use parameterized queries db.Sql("INSERT INTO users (name, age) VALUES (?, ?)") _ .Param("name", txtName.Text, VBMAN.adVarWChar) _ .Param("age", CLng(txtAge.Text), VBMAN.adInteger) _ .ExecParam ' Not recommended: Direct SQL concatenation (vulnerable to SQL injection) db.Sql("INSERT INTO users (name, age) VALUES ('" & txtName.Text & "', " & txtAge.Text & ")").Exec ``` ### 2. Use Transactions for Consistency ```vb ' Recommended: Use transactions db.TransBegin db.Sql("INSERT INTO users (name) VALUES ('John')").Exec db.Sql("INSERT INTO posts (user_id, title) VALUES (1, 'Title')").Exec If Not db.TransCommit Then Debug.Print "Transaction failed, rolled back" End If ``` ### 3. Check Return Values ```vb ' Recommended: Always check return values If db.Sql("INSERT INTO users (name) VALUES ('John')").Exec Then ' Success handling Else ' Error handling End If ``` ### 4. Get Affected Rows ```vb ' Recommended: Check affected rows Dim lAffected As Long If db.Sql("UPDATE users SET status = 'active'").Exec(lAffected) Then If lAffected > 0 Then Debug.Print "Updated " & lAffected & " records" Else Debug.Print "No records were updated" End If End If ``` *** **Last Updated**: 2026-01-21 --- --- url: /en/vbman/Toast/faq.md --- # FAQ Frequently Asked Questions about cToast. ## Table of Contents * [Basic Questions](#basic-questions) * [Usage Questions](#usage-questions) * [Technical Questions](#technical-questions) * [Performance Questions](#performance-questions) * [Extension Questions](#extension-questions) * [Other Questions](#other-questions) ## Basic Questions ### Q1: What is cToast? **A**: cToast is a message notification component in the VBMan framework, used to display brief message popups. It supports multiple display positions, state themes, and intelligent stacking, providing a simple and elegant notification solution. ### Q2: Do I need to create an instance every time? **A**: Not necessarily. If you use the global singleton `VBMAN.Toast`, you can call it directly from anywhere without creating an instance. For more complex management needs, you can create a cToast instance and use it multiple times. ### Q3: What display positions are supported? **A**: cToast supports 9 display positions: * Left: LeftTop, LeftCenter, LeftBottom * Center: CenterTop, Center, CenterBottom * Right: RightTop, RightCenter, RightBottom ### Q4: What state themes are available? **A**: cToast supports 4 state themes: * Info (blue) - Information messages * Success (green) - Success messages * Warning (yellow) - Warning messages * Danger (red) - Error messages ### Q5: What color themes are available? **A**: cToast supports 2 color themes: * Light (default) - Light theme, suitable for light interfaces * Dark - Dark theme, suitable for dark interfaces ## Usage Questions ### Q6: How to quickly display a simple message? **A**: Use the simplest method: ```vb ' Method 1: Create instance With New cToast .Show "Operation successful!" End With ' Method 2: Global singleton VBMAN.Toast.Show "Operation successful!" ``` ### Q7: How to set display duration? **A**: Set the second parameter of the Show method (in milliseconds): ```vb ' Display for 2 seconds Toast.Show "Message", 2000 ' Display for 5 seconds Toast.Show "Message", 5000 ' No auto-close (persistent) Toast.Show "Message", 0 ``` ### Q8: How to set display position? **A**: Use the Pos method: ```vb ' Top-right corner Toast.Pos(RightTop).Show "Message", 2000 ' Center Toast.Pos(Center).Show "Message", 2000 ' Bottom-left Toast.Pos(LeftBottom).Show "Message", 2000 ``` ### Q9: How to display multiple messages with stacking? **A**: Messages will automatically stack: ```vb With New cToast .Pos(RightTop) ' These messages will stack automatically .State(Info).Show "Message 1", 0 .State(Success).Show "Message 2", 0 .State(Warning).Show "Message 3", 0 End With ``` ### Q10: How to close a specific popup? **A**: Use the Tag method to name it, then close with CloseMe: ```vb ' Display named popup Toast.Tag("msg1").Show "Message 1", 0 ' Close specific popup Toast.CloseMe "msg1" ``` ### Q11: How to close all popups? **A**: Use the CloseAll method: ```vb Toast.CloseAll ``` ### Q12: How to check if a popup exists? **A**: Use the Exists method: ```vb If Toast.Exists("msg1") Then Debug.Print "Popup exists" Else Debug.Print "Popup does not exist" End If ``` ### Q13: How to get the current number of popups? **A**: Use the Count property: ```vb Debug.Print "Current popups: " & Toast.Count ``` ### Q14: How to get a list of all active popups? **A**: Use the ActiveKeys property: ```vb Dim Keys As Collection Dim Key As Variant Set Keys = Toast.ActiveKeys For Each Key In Keys Debug.Print CStr(Key) Next Key ``` ### Q15: How to monitor popup count changes? **A**: Use the OnToastCountChange event: ```vb Private WithEvents Toast As cToast Private Sub Toast_OnToastCountChange(ByVal TagName As String, _ ByVal IsDelete As Boolean, _ ByVal CurrentCount As Long) Debug.Print "Count changed: " & CurrentCount End Sub ``` ### Q16: Why doesn't the popup close automatically? **A**: Check if the delay parameter is set to 0: ```vb ' No auto-close Toast.Show "Message", 0 ' Auto-close after 3 seconds Toast.Show "Message", 3000 ``` ### Q17: Why is the popup not showing? **A**: Check the following: 1. Is the Show method called? 2. Is the Tag name repeated (duplicate popups are not created)? 3. Is the form loaded properly? 4. Is there an error in the code? ## Technical Questions ### Q18: What is the difference between Center and other positions? **A**: Center positions (Center, LeftCenter, RightCenter) are overlay mode - only one popup can be displayed, new ones overlay old ones. Other positions support stacking mode and can display multiple popups simultaneously. ### Q19: How does stacking work? **A**: * **Top positions** (CenterTop, LeftTop, RightTop): Sequential stacking, newest at the bottom * **Bottom positions** (CenterBottom, LeftBottom, RightBottom): Reverse stacking, newest at the top * **Center positions**: No stacking, overlay mode ### Q20: How to manually set stacking index? **A**: Use the InstIndex method: ```vb Toast.Pos(RightTop).InstIndex(0).Show "Message at index 0", 0 Toast.Pos(RightTop).InstIndex(1).Show "Message at index 1", 0 ``` ### Q21: Why doesn't the center position support stacking? **A**: Center position is designed for important single-message notifications, using overlay mode to ensure message prominence. If stacking is needed, use top or bottom positions. ### Q22: How to implement chain calls? **A**: All configuration methods return Me, supporting chained calls: ```vb With New cToast .Pos(RightTop).State(Success).Theme(Dark).Tag("msg1").Show "Message", 2000 End With ``` ### Q23: How to use events? **A**: Declare variable WithEvents: ```vb Private WithEvents Toast As cToast Private Sub Form_Load() Set Toast = New cToast End Sub Private Sub Toast_OnToastCountChange(ByVal TagName As String, _ ByVal IsDelete As Boolean, _ ByVal CurrentCount As Long) ' Handle event End Sub ``` ### Q24: What form types are used internally? **A**: cToast uses two form types: * **FToastCenter**: Used for Center, CenterTop, CenterBottom positions * **FToastDrawer**: Used for other 6 positions ### Q25: How to modify popup appearance? **A**: Appearance is controlled by state and theme: * State controls color and icon (Info, Success, Warning, Danger) * Theme controls background color (Light, Dark) For deeper customization, you need to modify the form code. ## Performance Questions ### Q26: Will multiple popups affect performance? **A**: cToast is optimized for performance. Generally, displaying 10-20 popups will not affect performance. However, displaying too many (over 50) may consume more system resources. ### Q27: Does the popup consume system resources? **A**: Each popup creates a form instance, consuming some memory and window resources. It is recommended to close unneeded popups promptly to free resources. ### Q28: How to optimize performance in high-frequency notification scenarios? **A**: Suggestions: 1. Use batch notifications instead of multiple popups 2. Reasonably set display duration 3. Close unneeded popups promptly 4. Limit the maximum number of simultaneous popups ## Extension Questions ### Q29: Can I add custom icons? **A**: The standard version does not support custom icons. You need to modify the form code to add custom icon support. ### Q30: Can I add animations? **A**: The standard version does not support animations. You can modify the form code to add fade-in, slide-in, and other animation effects. ### Q31: Can I play sound on popup display? **A**: The standard version does not support sound. You can add your own sound playing code in the Show method. ### Q32: Can I click the popup to perform an action? **A**: The standard version does not support click actions. You can add a form Click event to implement custom actions. ### Q33: Can I add a progress bar? **A**: The standard version does not support progress bars. You need to extend the form code to add progress bar support. ### Q34: Can I use HTML or RTF formatted text? **A**: The standard version only supports plain text. To support rich text, you need to use a rich text control and modify the form code. ### Q35: Can I customize the popup size? **A**: The standard version's popup size is fixed. If you need to change the size, modify the form's dimensions. ### Q36: Can I support multiple monitors? **A**: The standard version defaults to the primary monitor. To support multiple monitors, modify the position calculation code. ### Q37: Can I create custom themes? **A**: The standard version only supports Light and Dark themes. To add custom themes, modify the theme enumeration and related code. ## Other Questions ### Q38: Is cToast thread-safe? **A**: cToast is not designed for multithreading. It is recommended to use it in the main thread. ### Q39: How to handle errors? **A**: Use standard VB6 error handling: ```vb On Error GoTo ErrorHandler Toast.Pos(RightTop).Show "Message", 2000 Exit Sub ErrorHandler: Debug.Print "Error: " & Err.Description ``` ### Q40: How to log popup display history? **A**: Use the OnToastCountChange event to record: ```vb Private Sub Toast_OnToastCountChange(ByVal TagName As String, _ ByVal IsDelete As Boolean, _ ByVal CurrentCount As Long) Dim action As String action = IIf(IsDelete, "Closed", "Displayed") LogToFile action & ": " & TagName & " at " & Now() End Sub ``` ### Q41: How to integrate cToast into existing projects? **A**: Steps: 1. Copy cToast.cls and related form files to the project 2. Add reference to cShadow component (if needed) 3. Add code in the project 4. Test functionality ### Q42: Does cToast have dependencies? **A**: cToast depends on the cShadow component (for shadow effects). Ensure that the cShadow component is properly referenced in the project. ### Q43: Is cToast compatible with all VB6 versions? **A**: cToast requires VB6 SP6 or later. It is recommended to use VB6 SP6 with the latest updates. ### Q44: Does cToast support Windows 10/11? **A**: Yes, cToast is compatible with Windows XP and later, including Windows 10 and Windows 11. ### Q45: Where can I get more help? **A**: * Check documentation: [API Reference](./api.md), [Examples](./examples.md), [Technical Details](./technical.md) * Join QQ group: 915520648 * Visit official website: https://vb6.pro/ * View source code for more details ### Q46: How to report a bug? **A**: 1. Record the detailed steps to reproduce 2. Provide code example 3. Describe the expected and actual behavior 4. Report in QQ group or via other channels ### Q47: How to request a new feature? **A**: 1. Describe the feature requirements in detail 2. Provide usage scenarios 3. Give your own suggestions on implementation 4. Feedback in QQ group or other channels ### Q48: Is there a demo program? **A**: Yes, demo programs are available at: `vbman-demo/demos/Toast/`. The demo demonstrates various features and usage scenarios. ### Q49: How to migrate from older versions? **A**: 1. Read the version update notes 2. Check if there are API changes 3. Update code according to the documentation 4. Test after migration ### Q50: What is the future development plan for cToast? **A**: The development team will continue to improve cToast functionality and performance. Planned features include: * More theme options * Animation effects * Sound notification * Click actions * Progress bar support * More customization options Please pay attention to the official channels for the latest updates. --- --- url: /en/vbman2/webview2/faq.md --- # FAQ - Frequently Asked Questions ## 🔄 Initialization and Creation ### ❓ Q1: WebView2 creation failed — what to do? **Symptom**: After calling Initialize, Create or Ready events are not triggered. **Possible Causes**: 1. WebView2 Runtime not installed 2. WebView2 version on target machine is too old 3. UserDataFolder path conflict **Solution**: ```vb ' Check if WebView2 is installed ' Look for path: C:\Program Files (x86)\Microsoft\EdgeWebView\Application ' Specify minimum version number wv.EnvironmentOptions.TargetCompatibleBrowserVersion = "86.0.616.0" ``` cWebView2Host has internal retry logic — up to 10 creation attempts, auto-incrementing the UserDataFolder path each time. *** ### ❓ Q2: Should Initialize take a Form object or hWnd? Both are supported: ```vb wv.Initialize Me.hWnd, "https://vb6.pro" ' Pass window handle wv.Initialize Me, "https://vb6.pro" ' Pass Form object (auto-gets hWnd) ``` When passing a Form object, `Form.hWnd` is called internally to get the window handle. The effect is exactly the same. *** ### ❓ Q3: When to use two-parameter Initialize vs one-parameter? * **Two-parameter** `Initialize(hWnd, url)` - Most common, auto-navigates to specified URL * **One-parameter** `Initialize(hWnd)` - Use when you need to configure environment parameters before navigation ```vb ' Simple scenario: navigate directly wv.Initialize Me.hWnd, "https://vb6.pro" ' Advanced scenario: need to configure environment parameters wv.Initialize Me.hWnd ' Don't navigate immediately Private Sub wv_Create() ' Configure before navigation wv.EnvironmentOptions.UserDataFolder = App.Path & "\UserData" wv.Security.CertificateErrorAction = CEA_AlwaysAllow End Sub Private Sub wv_Ready() wv.Navigate "https://example.com" End Sub ``` *** ## 🔗 Data Binding ### ❓ Q4: Must BindUI callback methods be Public? **Yes**. BindUI uses `CallByName` to invoke host methods — VB6's CallByName can only call Public members. ```vb ' Correct Public Sub OnClick(ByVal EventName As String, ByVal Detail As String) ' Incorrect - will not be called Private Sub OnClick(ByVal EventName As String, ByVal Detail As String) ``` *** ### ❓ Q5: How to get DOM element values with BindUI? The Detail parameter contains JSON-formatted event details that vary by event type. Manual parsing is required: ```vb Public Sub OnNameInput(ByVal EventName As String, ByVal Detail As String) ' Detail example: {"type":"input","value":"User input text"} Dim val As String val = JsonValue(Detail, "value") wv.SetData "name", val End Sub ``` *** ### ❓ Q6: Can SetData pass arrays or objects? SetData's Value parameter is Variant, internally generating a JS literal directly. There are two approaches for complex structures: ```vb ' Method 1: Use innerHTML attribute binding wv.BindData "list", "#item-list", "innerHTML" wv.SetData "list", "
  • Item 1
  • Item 2
    • " ' Method 2: Call JS function to process JSON wv.JsRun "renderList(" & jsonString & ")" ``` *** ## ⚡ JavaScript Execution ### ❓ Q7: What's the difference between JsRun and ExecuteScript? | Feature | JsRun | ExecuteScript | |---------|-------|---------------| | Execution mode | Synchronous (blocking wait) | Asynchronous (event callback) | | Return value | Direct String return | JsAsyncResult event | | WithEvents | Not required | Recommended | | Typical scenario | Get result immediately | Don't need to wait for result | *** ### ❓ Q8: What's the difference between JsRun and Script.Eval? | Feature | JsRun | Script.Eval | |---------|-------|-------------| | Input | JS expression/property path | JS code block (supports return) | | Wrapping | Direct execution | Wrapped as function, then executed | | Usage | `wv.JsRun("document.title")` | `wv.Script.Eval("return document.title")` | | Best for | Simple expressions | Complex code blocks | `Script.Eval` wraps code as `function EvalFuncName(){...}`, injects and calls it, so `return` is needed to return values. *** ## 🛡️ Security ### ❓ Q9: How to ignore HTTPS certificate errors? **Must be set in the Create event**, before navigation starts: ```vb Dim WithEvents wv As cWebView2Host Private Sub Form_Load() Set wv = New cWebView2Host wv.Initialize Me.hWnd, "https://self-signed.example.com/" End Sub Private Sub wv_Create() ' Set before navigation wv.Security.CertificateErrorAction = CEA_AlwaysAllow End Sub ``` If set after the Create event, it will not take effect. *** ### ❓ Q10: How to disable DevTools and context menus? ```vb Private Sub wv_Create() wv.AreDevToolsEnabled = False wv.AreDefaultContextMenusEnabled = False End Sub ``` *** ## 🍪 Cookies ### ❓ Q11: What's the difference between GetCookies and GetCookiesFull? | Method | Retrieval Method | HttpOnly Cookies | Performance | |--------|-----------------|------------------|-------------| | `Cookies.GetCookies` | document.cookie | Not visible | Fast | | `Cookies.GetCookiesFull` | CDP Network.getCookies | Visible | Slightly slower | | `Cookies.GetCookiesFullAsync` | CDP async | Visible | Non-blocking | For scenarios requiring access to HttpOnly cookies, you must use `GetCookiesFull` or `GetCookiesFullAsync`. *** ## 🖥️ Host Environment ### ❓ Q12: What limitations exist in Access? Access uses MessageWindowAdapter — the following features are not available: * Host mouse events (HostMouse\*) * Host keyboard events (HostKeyDown/Up/Press) * HostFocus / HostBlur events Workarounds: * Use BindUI to bind DOM events * Use UserMouse series events (requires EnableUserMouseEvents = True) *** ### ❓ Q13: How to share or isolate sessions across multiple WebView2 instances? Controlled via `UserDataFolder`: ```vb ' Shared session: same UserDataFolder wv1.EnvironmentOptions.UserDataFolder = App.Path & "\UserData" wv2.EnvironmentOptions.UserDataFolder = App.Path & "\UserData" ' Isolated sessions: different UserDataFolders wv1.EnvironmentOptions.UserDataFolder = App.Path & "\UserDir\account-001" wv2.EnvironmentOptions.UserDataFolder = App.Path & "\UserDir\account-002" ``` Instances sharing a session will share cookies, localStorage, etc. Isolated sessions are completely independent. *** ## 📦 Local Resource Loading ### ❓ Q14: How to load local HTML files? Three methods: ```vb ' Method 1: Pass local folder path (simplest) wv.Initialize Me.hWnd, App.Path & "\www" ' Auto-maps to http://vbman2.com/index.html ' Method 2: Virtual host name mapping (recommended, supports https protocol) wv.Initialize Me.hWnd ' In wv_Ready: wv.SetVirtualHostNameToFolderMapping "myapp.local", App.Path & "\www" wv.Navigate "https://myapp.local/index.html" ' Method 3: Load from VB6 resource file (single-file distribution) wv.Initialize Me.hWnd ' In wv_Ready: wv.NavigateToString VBMAN2.Res(LoadResData("INDEX.HTML", "WWW")).ReturnString() ``` *** ### ❓ Q15: Cross-origin issues with AJAX requests in local HTML? When loading via `SetVirtualHostNameToFolderMapping`, the page runs under the `https://` protocol and can normally access external APIs of the same protocol — no `file://` protocol restrictions apply. *** **Last Updated**: 2026-06-24 --- --- url: /en/cases/featured-cases.md description: VBMAN featured user case showcase --- Outstanding cases are being collected — submit your work today! ## Case #001: Lightweight IoT Cloud Platform **Author**: TechGeek LaoBai **Core Module**: cHttpServer **Project Overview**: A lightweight IoT data storage service built on VBMAN HttpServer. Read/write data with just a URL, no SDK needed, up and running in 30 seconds. Supports multi-language calls from ESP32/Arduino/Python/cURL, with free read operations. **Technical Highlights**: * VBMAN `cHttpServer` routing system implements REST-style API * Native CORS support, frontend can make cross-origin calls directly * JSON response format + data persistence storage * Full multi-language client coverage (JS/ESP32/Python/cURL) **Use Cases**: IoT sensor cloud upload, device remote control, smart home data hub, rapid project prototype validation **Details**: [View Full Case](/en/cases/case-iot-cloud) *** ## Case #002: Smart Factory Equipment Monitoring System \[Placeholder, not actual] **Author**: Smart Manufacturing Team **Project Overview**: An equipment status real-time monitoring system developed for an auto parts factory using VBMAN WEB server and WebSocket capabilities. The system can simultaneously monitor 50+ production devices, implementing fault warning, production data statistics, remote control, and more. **Technical Highlights**: * VBMAN WebSocket server for real-time device data push * Supports multiple simultaneous online monitoring clients * Integrated Modbus protocol for PLC data reading * VBMAN2 WebView2 for visual dashboard display **Use Cases**: Industry 4.0 smart manufacturing, remote equipment O\&M, production data visualization *** ## Case #003: School Library Management System \[Placeholder, not actual] **Author**: Lao Zhang Programming **Project Overview**: A web-based library management system developed for a primary school using VBMAN. The system supports book inventory, borrowing/returning management, reader management, borrowing statistics, and more, greatly improving library management efficiency. **Technical Highlights**: * VBMAN WEB server provides RESTful API * VBMAN JSON module handles data interaction * Supports Excel import/export of borrowing records * QR code scanning for quick borrowing/returning **Use Cases**: School libraries, community libraries, corporate book corners *** ## Case #004: Online Examination System \[Placeholder, not actual] **Author**: Education Software Developer **Project Overview**: An online examination system built with VBMAN, supporting question bank management, test paper generation, online exams, auto-grading, and more. Deployed in 3 training institutions, serving 5000+ examinees cumulatively. **Technical Highlights**: * VBMAN handles concurrent exam requests * Supports multiple question types (single choice, multiple choice, fill-in-the-blank, short answer) * VBMAN2 WebView2 for rich text editor * Anti-cheating mechanisms (screen-switch detection, timed answering) **Use Cases**: Online education, vocational training, corporate internal training exams *** *More outstanding cases coming soon — welcome to submit your work!* --- --- url: /en/packages/vbccr/lists/fontcombo.md description: >- FontCombo Control - VBCCR Development Manual, complete API reference based on source code --- # FontCombo Control Provides a font selection combo box control with a most-recently-used list, capable of enumerating system fonts and filtering by type and pitch. ## Enumerations ### FtcStyleConstants | Constant | Value | Description | |----------|-------|-------------| | FtcStyleDropDownCombo | 0 | Drop-down combo box (editable) | | FtcStyleSimpleCombo | 1 | Simple combo box (list always visible) | | FtcStyleDropDownList | 2 | Drop-down list (selection only) | ### FtcFontTypeConstants | Constant | Value | Description | |----------|-------|-------------| | FtcFontTypeTrueType | 0 | TrueType fonts only | | FtcFontTypeBitmap | 1 | Bitmap fonts only | | FtcFontTypeBitmapTrueType | 2 | Bitmap and TrueType fonts | ### FtcFontPitchConstants | Constant | Value | Description | |----------|-------|-------------| | FtcFontPitchAll | 0 | All pitches | | FtcFontPitchFixed | 1 | Fixed pitch | | FtcFontPitchVariable | 2 | Variable pitch | ## Properties ### Name ```vb Property Get Name() As String ``` Returns the name of the control. ### Tag ```vb Property Get/Let Tag() As String ``` Returns/sets the tag value of the control. ### Parent ```vb Property Get Parent() As Object ``` Returns the parent object of the control. ### Container ```vb Property Get/Set Container() As Object ``` Returns/sets the container of the control. ### Left ```vb Property Get/Let Left() As Single ``` Returns/sets the position of the left edge of the control. ### Top ```vb Property Get/Let Top() As Single ``` Returns/sets the position of the top edge of the control. ### Width ```vb Property Get/Let Width() As Single ``` Returns/sets the width of the control. ### Height ```vb Property Get/Let Height() As Single ``` Returns/sets the height of the control. ### Visible ```vb Property Get/Let Visible() As Boolean ``` Returns/sets whether the control is visible. ### ToolTipText ```vb Property Get/Let ToolTipText() As String ``` Returns/sets the tooltip text of the control. ### HelpContextID ```vb Property Get/Let HelpContextID() As Long ``` Returns/sets the help context ID of the control. ### WhatsThisHelpID ```vb Property Get/Let WhatsThisHelpID() As Long ``` Returns/sets the "What's This" help ID of the control. ### DragIcon ```vb Property Get/Let/Set DragIcon() As IPictureDisp ``` Returns/sets the icon displayed during drag operations. ### DragMode ```vb Property Get/Let DragMode() As Integer ``` Returns/sets the drag mode (manual or automatic). ### hWnd ```vb Property Get hWnd() As LongPtr ``` Returns the window handle of the combo box. ### hWndUserControl ```vb Property Get hWndUserControl() As LongPtr ``` Returns the window handle of the UserControl. ### hWndEdit ```vb Property Get hWndEdit() As LongPtr ``` Returns the window handle of the edit box portion. ### hWndList ```vb Property Get hWndList() As LongPtr ``` Returns the window handle of the list portion. ### Font ```vb Property Get/Let/Set Font() As StdFont ``` Returns/sets the font used by the control. ### VisualStyles ```vb Property Get/Let VisualStyles() As Boolean ``` Returns/sets whether visual styles are enabled. ### BackColor ```vb Property Get/Let BackColor() As OLE_COLOR ``` Returns/sets the background color of the control. ### ForeColor ```vb Property Get/Let ForeColor() As OLE_COLOR ``` Returns/sets the foreground color of the control. ### Enabled ```vb Property Get/Let Enabled() As Boolean ``` Returns/sets whether the control is enabled. ### OLEDragMode ```vb Property Get/Let OLEDragMode() As VBRUN.OLEDragConstants ``` Returns/sets the OLE drag mode. ### OLEDropMode ```vb Property Get/Let OLEDropMode() As OLEDropModeConstants ``` Returns/sets the OLE drop mode. See common enumerations. ### MousePointer ```vb Property Get/Let MousePointer() As CCMousePointerConstants ``` Returns/sets the mouse pointer type. See common enumerations. ### MouseIcon ```vb Property Get/Let/Set MouseIcon() As IPictureDisp ``` Returns/sets the custom mouse icon. ### MouseTrack ```vb Property Get/Let MouseTrack() As Boolean ``` Returns/sets whether mouse enter/leave tracking is enabled. ### RightToLeft ```vb Property Get/Let RightToLeft() As Boolean ``` Returns/sets whether right-to-left layout is enabled. ### RightToLeftMode ```vb Property Get/Let RightToLeftMode() As CCRightToLeftModeConstants ``` Returns/sets the right-to-left mode. See common enumerations. ### BuddyControl ```vb Property Get/Set/Let BuddyControl() As Variant ``` Returns/sets the associated buddy control, which is notified to update when a font is selected. ### Style ```vb Property Get/Let Style() As FtcStyleConstants ``` Returns/sets the combo box style. ### FontType ```vb Property Get/Let FontType() As FtcFontTypeConstants ``` Returns/sets the font type filter for display. ### FontPitch ```vb Property Get/Let FontPitch() As FtcFontPitchConstants ``` Returns/sets the font pitch filter for display. ### Locked ```vb Property Get/Let Locked() As Boolean ``` Returns/sets whether the control is locked (prevents editing and selection). ### Text ```vb Property Get/Let Text() As String ``` Returns/sets the text in the edit box. ### Default ```vb Property Get/Let Default() As String ``` Returns/sets the default font name. ### ExtendedUI ```vb Property Get/Let ExtendedUI() As Boolean ``` Returns/sets whether extended user interface is used. ### MaxDropDownItems ```vb Property Get/Let MaxDropDownItems() As Integer ``` Returns/sets the maximum number of visible items in the drop-down list. ### IntegralHeight ```vb Property Get/Let IntegralHeight() As Boolean ``` Returns/sets whether only complete items are shown (no partial items truncated). ### MaxLength ```vb Property Get/Let MaxLength() As Long ``` Returns/sets the maximum number of characters that can be entered in the edit box. ### HorizontalExtent ```vb Property Get/Let HorizontalExtent() As Single ``` Returns/sets the horizontal scroll width of the list. ### IMEMode ```vb Property Get/Let IMEMode() As CCIMEModeConstants ``` Returns/sets the input method editor mode. See common enumerations. ### ScrollTrack ```vb Property Get/Let ScrollTrack() As Boolean ``` Returns/sets whether the scroll bar tracks in real time. ### AutoSelect ```vb Property Get/Let AutoSelect() As Boolean ``` Returns/sets whether the edit box text is automatically selected when the control receives focus. ### AlwaysFindExact ```vb Property Get/Let AlwaysFindExact() As Boolean ``` Returns/sets whether to always perform exact matching. ### RecentMax ```vb Property Get/Let RecentMax() As Integer ``` Returns/sets the maximum number of items in the recently used list (0-9), 0 hides the recent list. ### RecentBackColor ```vb Property Get/Let RecentBackColor() As OLE_COLOR ``` Returns/sets the background color of the recently used list. ### RecentForeColor ```vb Property Get/Let RecentForeColor() As OLE_COLOR ``` Returns/sets the foreground color of the recently used list. ### RecentCount ```vb Property Get RecentCount() As Long ``` Returns the number of items in the recently used list. Read-only. ### ListCount ```vb Property Get ListCount() As Long ``` Returns the total number of items in the list. Read-only. ### List ```vb Property Get List(ByVal Index As Long) As String ``` Returns the text of the list item at the specified index. Read-only. ### ListIndex ```vb Property Get/Let ListIndex() As Long ``` Returns/sets the index of the currently selected item. ### ItemData ```vb Property Get/Let ItemData(ByVal Index As Long) As LongPtr ``` Returns/sets the extra data for the item at the specified index. ### SelStart ```vb Property Get/Let SelStart() As Long ``` Returns/sets the starting position of the selected text. ### SelLength ```vb Property Get/Let SelLength() As Long ``` Returns/sets the length of the selected text. ### SelText ```vb Property Get/Let SelText() As String ``` Returns/sets the currently selected text. ### ItemHeight ```vb Property Get ItemHeight() As Single ``` Returns the height of list items. Read-only. ### FieldHeight ```vb Property Get FieldHeight() As Single ``` Returns the height of the edit box (or static text) portion. Read-only. ### DroppedDown ```vb Property Get/Let DroppedDown() As Boolean ``` Returns/sets whether the drop-down list is expanded. ### DropDownWidth ```vb Property Get/Let DropDownWidth() As Single ``` Returns/sets the width of the drop-down list. Not supported in simple style. ### TopIndex ```vb Property Get/Let TopIndex() As Long ``` Returns/sets the index of the top visible item in the list. ## Methods ### OLEDrag ```vb Public Sub OLEDrag() ``` Initiates an OLE drag operation. ### Drag ```vb Public Sub Drag(Optional ByRef Action As Variant) ``` Starts, ends, or cancels a drag operation. ### SetFocus ```vb Public Sub SetFocus() ``` Moves focus to this control. ### ZOrder ```vb Public Sub ZOrder(Optional ByRef Position As Variant) ``` Sets the control's Z-order position within its layer. ### Refresh ```vb Public Sub Refresh() ``` Forces a complete redraw of the control. ### FindItem ```vb Public Function FindItem(ByVal Text As String, Optional ByVal Index As Long = -1, Optional ByVal Partial As Boolean) As Long ``` Finds an item in the font combo box and returns its index. When Partial is True, performs partial matching. ### GetIdealHorizontalExtent ```vb Public Function GetIdealHorizontalExtent() As Single ``` Gets the ideal value for the horizontal scroll width. ### SelectItem ```vb Public Function SelectItem(ByVal Text As String, Optional ByVal Index As Long = -1) As Long ``` Searches for an item starting with the specified string and selects it. Case-insensitive. ### SaveRecent ```vb Public Function SaveRecent() As Variant ``` Saves the recently used list and returns a string array. ### RestoreRecent ```vb Public Sub RestoreRecent(ByVal ArgList As Variant) ``` Restores the recently used list from a previously saved state. ### ClearRecent ```vb Public Sub ClearRecent() ``` Clears the contents of the recently used list. ## Events ### Click ```vb Public Event Click() ``` Occurs when the control is clicked. ### DblClick ```vb Public Event DblClick() ``` Occurs when the control is double-clicked. ### Scroll ```vb Public Event Scroll() ``` Occurs when the list is scrolled. ### Change ```vb Public Event Change() ``` Occurs when the control content changes. ### ContextMenu ```vb Public Event ContextMenu(ByRef Handled As Boolean, ByVal X As Single, ByVal Y As Single) ``` Occurs on right-click or Shift+F10. Set Handled to True to prevent the default context menu. ### DropDown ```vb Public Event DropDown() ``` Occurs when the drop-down list is about to expand. ### CloseUp ```vb Public Event CloseUp() ``` Occurs when the drop-down list closes. ### PreviewKeyDown ```vb Public Event PreviewKeyDown(ByVal KeyCode As Integer, ByRef IsInputKey As Boolean) ``` Occurs before the KeyDown event. Set IsInputKey to mark whether the key is an input key. ### PreviewKeyUp ```vb Public Event PreviewKeyUp(ByVal KeyCode As Integer, ByRef IsInputKey As Boolean) ``` Occurs before the KeyUp event. ### KeyDown ```vb Public Event KeyDown(KeyCode As Integer, Shift As Integer) ``` Occurs when a keyboard key is pressed. ### KeyUp ```vb Public Event KeyUp(KeyCode As Integer, Shift As Integer) ``` Occurs when a keyboard key is released. ### KeyPress ```vb Public Event KeyPress(KeyChar As Integer) ``` Occurs when a character key is pressed and released. ### MouseDown ```vb Public Event MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` Occurs when a mouse button is pressed. ### MouseMove ```vb Public Event MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` Occurs when the mouse is moved. ### MouseUp ```vb Public Event MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` Occurs when a mouse button is released. ### MouseEnter ```vb Public Event MouseEnter() ``` Occurs when the mouse enters the control. ### MouseLeave ```vb Public Event MouseLeave() ``` Occurs when the mouse leaves the control. ### OLECompleteDrag ```vb Public Event OLECompleteDrag(Effect As Long) ``` Occurs on the source control after an OLE drag-drop operation is completed or canceled. ### OLEDragDrop ```vb Public Event OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single) ``` Occurs when data is dropped onto the control via an OLE drag-drop operation. ### OLEDragOver ```vb Public Event OLEDragOver(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single, State As Integer) ``` Occurs when the mouse passes over the control during an OLE drag-drop operation. ### OLEGiveFeedback ```vb Public Event OLEGiveFeedback(Effect As Long, DefaultCursors As Boolean) ``` Occurs on the source control when the mouse cursor needs to change during an OLE drag-drop operation. ### OLESetData ```vb Public Event OLESetData(Data As DataObject, DataFormat As Integer) ``` Occurs on the source control when the drop target requests data. ### OLEStartDrag ```vb Public Event OLEStartDrag(Data As DataObject, AllowedEffects As Long) ``` Occurs when an OLE drag-drop operation is started. ## Code Examples ### Basic Usage ```vb Private Sub Form_Load() With FontCombo1 .Style = FtcStyleDropDownCombo .FontType = FtcFontTypeTrueType .FontPitch = FtcFontPitchAll .RecentMax = 5 End With End Sub Private Sub FontCombo1_Click() Me.Font.Name = FontCombo1.Text Debug.Print "Selected font: " & FontCombo1.Text End Sub Private Sub Form_Unload(Cancel As Integer) Dim v As Variant v = FontCombo1.SaveRecent SaveSetting App.Title, "FontCombo", "Recent", Join(v, vbTab) End Sub ``` --- --- url: /en/packages/vbccr/system/framew.md description: >- FrameW Control - VBCCR Development Manual, Complete API Reference Based on Source Code --- # FrameW Control Provides a container frame control that supports visual styles, transparent background, and image display. Can serve as a container for other controls. ## Enumerations No proprietary public enumerations. Uses the following common enumerations: CCAppearanceConstants, CCLeftRightAlignmentConstants, CCMousePointerConstants, CCRightToLeftModeConstants, OLEDropModeConstants. ## Properties ### Name ```vb Property Get Name() As String ``` Returns the name of the control. ### Tag ```vb Property Get/Let Tag() As String ``` Returns/sets the tag value of the control. ### Parent ```vb Property Get Parent() As Object ``` Returns the parent object of the control. ### Container ```vb Property Get/Set Container() As Object ``` Returns/sets the container of the control. ### Left ```vb Property Get/Let Left() As Single ``` Returns/sets the position of the left edge of the control. ### Top ```vb Property Get/Let Top() As Single ``` Returns/sets the position of the top edge of the control. ### Width ```vb Property Get/Let Width() As Single ``` Returns/sets the width of the control. ### Height ```vb Property Get/Let Height() As Single ``` Returns/sets the height of the control. ### Visible ```vb Property Get/Let Visible() As Boolean ``` Returns/sets whether the control is visible. ### ToolTipText ```vb Property Get/Let ToolTipText() As String ``` Returns/sets the tooltip text of the control. ### WhatsThisHelpID ```vb Property Get/Let WhatsThisHelpID() As Long ``` Returns/sets the "What's This" Help ID of the control. ### DragIcon ```vb Property Get/Let/Set DragIcon() As IPictureDisp ``` Returns/sets the icon displayed during drag operations. ### DragMode ```vb Property Get/Let DragMode() As Integer ``` Returns/sets the drag mode (manual or automatic). ### hWnd ```vb Property Get hWnd() As LongPtr ``` Returns the window handle of the control. ### Font ```vb Property Get/Let/Set Font() As StdFont ``` Returns/sets the font used by the control. ### VisualStyles ```vb Property Get/Let VisualStyles() As Boolean ``` Returns/sets whether visual styles are enabled. ### Appearance ```vb Property Get/Let Appearance() As CCAppearanceConstants ``` Returns/sets the visual appearance of the control. See Common Enumerations. ### BackColor ```vb Property Get/Let BackColor() As OLE_COLOR ``` Returns/sets the background color of the control. ### ForeColor ```vb Property Get/Let ForeColor() As OLE_COLOR ``` Returns/sets the foreground color of the control (caption text color). ### Enabled ```vb Property Get/Let Enabled() As Boolean ``` Returns/sets whether the control is enabled. ### OLEDropMode ```vb Property Get/Let OLEDropMode() As OLEDropModeConstants ``` Returns/sets the OLE drop mode. See Common Enumerations. ### MousePointer ```vb Property Get/Let MousePointer() As CCMousePointerConstants ``` Returns/sets the mouse pointer type. See Common Enumerations. ### MouseIcon Not available. The frame control does not support custom mouse icons. ### MouseTrack ```vb Property Get/Let MouseTrack() As Boolean ``` Returns/sets whether mouse enter/leave tracking is enabled. ### RightToLeft ```vb Property Get/Let RightToLeft() As Boolean ``` Returns/sets whether right-to-left layout is enabled. ### RightToLeftMode ```vb Property Get/Let RightToLeftMode() As CCRightToLeftModeConstants ``` Returns/sets the right-to-left mode. See Common Enumerations. ### BorderStyle ```vb Property Get/Let BorderStyle() As Integer ``` Returns/sets the border style of the control. Values: 0 (vbBSNone) no border, 1 (vbFixedSingle) fixed single border. ### Caption ```vb Property Get/Let Caption() As String ``` Returns/sets the frame caption text. ### UseMnemonic ```vb Property Get/Let UseMnemonic() As Boolean ``` Returns/sets whether the & character in the caption acts as an access key. ### Alignment ```vb Property Get/Let Alignment() As VBRUN.AlignmentConstants ``` Returns/sets the alignment of the caption. ### Transparent ```vb Property Get/Let Transparent() As Boolean ``` Returns/sets whether the control is transparent. ### Picture ```vb Property Get/Let/Set Picture() As IPictureDisp ``` Returns/sets the image displayed in the frame. ### PictureAlignment ```vb Property Get/Let PictureAlignment() As CCLeftRightAlignmentConstants ``` Returns/sets the alignment of the image. See Common Enumerations. ### ContainedControls ```vb Property Get ContainedControls() As VBRUN.ContainedControls ``` Returns the collection of controls contained by the frame. Read-only. ## Methods ### OLEDrag ```vb Public Sub OLEDrag() ``` Initiates an OLE drag operation. ### Drag ```vb Public Sub Drag(Optional ByRef Action As Variant) ``` Starts, ends, or cancels a drag operation. ### ZOrder ```vb Public Sub ZOrder(Optional ByRef Position As Variant) ``` Sets the Z-order position of the control within its layer. ### Refresh ```vb Public Sub Refresh() ``` Forces a complete repaint of the control. ## Events ### Click ```vb Public Event Click() ``` Occurs when the control is clicked. ### DblClick ```vb Public Event DblClick() ``` Occurs when the control is double-clicked. ### Resize ```vb Public Event Resize() ``` Occurs when the control is resized. ### MouseDown ```vb Public Event MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` Occurs when a mouse button is pressed. ### MouseMove ```vb Public Event MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` Occurs when the mouse is moved. ### MouseUp ```vb Public Event MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` Occurs when a mouse button is released. ### MouseEnter ```vb Public Event MouseEnter() ``` Occurs when the mouse enters the control. ### MouseLeave ```vb Public Event MouseLeave() ``` Occurs when the mouse leaves the control. ### OLECompleteDrag ```vb Public Event OLECompleteDrag(Effect As Long) ``` Occurs on the source control after an OLE drag-and-drop operation is completed or cancelled. ### OLEDragDrop ```vb Public Event OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single) ``` Occurs when data is dropped onto the control via an OLE drag-and-drop operation. ### OLEDragOver ```vb Public Event OLEDragOver(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single, State As Integer) ``` Occurs when the mouse moves over the control during an OLE drag-and-drop operation. ### OLEGiveFeedback ```vb Public Event OLEGiveFeedback(Effect As Long, DefaultCursors As Boolean) ``` Occurs on the source control when the mouse cursor needs to be changed during an OLE drag-and-drop operation. ### OLESetData ```vb Public Event OLESetData(Data As DataObject, DataFormat As Integer) ``` Occurs on the source control when the drop target requests data. ### OLEStartDrag ```vb Public Event OLEStartDrag(Data As DataObject, AllowedEffects As Long) ``` Occurs when an OLE drag-and-drop operation is started. ## Code Examples ### Basic Usage ```vb Private Sub Form_Load() With FrameW1 .Caption = "Option Settings" .BorderStyle = vbFixedSingle .UseMnemonic = True .Alignment = vbLeftJustify .VisualStyles = True End With End Sub Private Sub FrameW1_Resize() Debug.Print "Frame size: " & FrameW1.Width & " x " & FrameW1.Height End Sub ``` --- --- url: /zh/vbman/redis/hash-operations.md --- # Hash 操作 Redis Hash 是一个键值对集合，适合存储对象。每个 Hash 可以包含多个字段-值对。 ## HSet - 设置 Hash 字段 ### 设置单个字段 ```vb oRedis.HSet "user:1", "name", "张三" oRedis.HSet "user:1", "age", "25" oRedis.HSet "user:1", "email", "zhangsan@example.com" ``` ### 批量设置字段 ```vb oRedis.HSet "user:1", "name", "李四" oRedis.HSet "user:1", "age", "30" oRedis.HSet "user:1", "city", "上海" oRedis.HSet "user:1", "email", "lisi@example.com" ``` ## HGet - 获取 Hash 字段 ```vb Dim sValue As String sValue = oRedis.HGet("user:1", "name") Debug.Print sValue ' 输出: 张三 ``` ## HMGet - 批量获取 Hash 字段 ```vb ' 批量获取字段 Dim vValues As Variant vValues = oRedis.HMGet("user:1", "name", "age", "email") If IsArray(vValues) Then Dim i As Long For i = 0 To UBound(vValues) Debug.Print vValues(i) Next End If ``` ## HGetAll - 获取所有 Hash 字段 获取 Hash 中所有字段和值，返回 `Dictionary` 对象： ```vb ' 获取所有字段和值 Dim oDict As Dictionary Set oDict = oRedis.HGetAll("user:1") ' 遍历字典 Dim vKey As Variant For Each vKey In oDict.Keys Debug.Print vKey & ": " & oDict(vKey) Next ``` **返回值类型：** `Dictionary` **注意：** 使用前需要添加对 "Microsoft Scripting Runtime" 的引用。 ## HDel - 删除 Hash 字段 ```vb ' 删除单个字段 oRedis.HDel "user:1", "email" ' 删除多个字段 oRedis.HDel "user:1", "age", "email" ``` ## HExists - 检查 Hash 字段是否存在 ```vb If oRedis.HExists("user:1", "name") Then Debug.Print "字段存在" Else Debug.Print "字段不存在" End If ``` ## 应用场景 ### 1. 用户信息存储 ```vb Sub StoreUserInfo() Dim oRedis As New cRedisClient If Not oRedis.Connect() Then Exit Sub Dim lUserId As Long lUserId = 1001 ' 存储用户信息 oRedis.HSet "user:" & lUserId, "name", "张三" oRedis.HSet "user:" & lUserId, "age", "25" oRedis.HSet "user:" & lUserId, "email", "zhangsan@example.com" oRedis.HSet "user:" & lUserId, "phone", "13800138000" oRedis.HSet "user:" & lUserId, "city", "北京" ' 获取用户姓名 Debug.Print "用户姓名: " & oRedis.HGet("user:" & lUserId, "name") ' 获取用户邮箱 Debug.Print "用户邮箱: " & oRedis.HGet("user:" & lUserId, "email") ' 获取所有用户信息 Dim oDict As Dictionary Set oDict = oRedis.HGetAll("user:" & lUserId) Debug.Print vbCrLf & "用户详细信息:" Dim vKey As Variant For Each vKey In oDict.Keys Debug.Print " " & vKey & ": " & oDict(vKey) Next oRedis.DisConnect End Sub ``` ### 2. 购物车 ```vb Sub ShoppingCart() Dim oRedis As New cRedisClient If Not oRedis.Connect() Then Exit Sub Dim sUserId As String sUserId = "cart:user123" ' 添加商品到购物车 oRedis.HSet sUserId, "product:1001", "2" ' 商品ID: 数量 oRedis.HSet sUserId, "product:1002", "1" oRedis.HSet sUserId, "product:1003", "3" ' 获取购物车中某商品的数量 Debug.Print "商品 1001 的数量: " & oRedis.HGet(sUserId, "product:1001") ' 更新商品数量 oRedis.HSet sUserId, "product:1001", "5" ' 获取购物车中所有商品 Dim oCart As Dictionary Set oCart = oRedis.HGetAll(sUserId) Debug.Print vbCrLf & "购物车内容:" Dim vProductId As Variant Dim lTotal As Long lTotal = 0 For Each vProductId In oCart.Keys Dim lCount As Long lCount = CLng(oCart(vProductId)) Debug.Print " " & vProductId & ": " & lCount & " 件" lTotal = lTotal + lCount Next Debug.Print "总件数: " & lTotal ' 从购物车删除商品 oRedis.HDel sUserId, "product:1002" oRedis.DisConnect End Sub ``` ### 3. 文章元数据 ```vb Sub ArticleMetadata() Dim oRedis As New cRedisClient If Not oRedis.Connect() Then Exit Sub Dim sArticleId As String sArticleId = "article:12345" ' 存储文章元数据 oRedis.HSet sArticleId, "title", "Redis 入门教程" oRedis.HSet sArticleId, "author", "张三" oRedis.HSet sArticleId, "views", "1000" oRedis.HSet sArticleId, "likes", "50" oRedis.HSet sArticleId, "comments", "20" oRedis.HSet sArticleId, "created_at", "2024-01-01" ' 获取文章标题 Debug.Print "文章标题: " & oRedis.HGet(sArticleId, "title") ' 获取作者和浏览数 Dim vInfo As Variant vInfo = oRedis.HMGet(sArticleId, "author", "views") If IsArray(vInfo) Then Debug.Print "作者: " & vInfo(0) Debug.Print "浏览数: " & vInfo(1) End If ' 增加浏览数 Dim lViews As Long lViews = CLng(oRedis.HGet(sArticleId, "views")) oRedis.HSet sArticleId, "views", CStr(lViews + 1) Debug.Print "更新后浏览数: " & oRedis.HGet(sArticleId, "views") ' 检查文章是否有评论 If oRedis.HExists(sArticleId, "comments") Then Debug.Print "评论数: " & oRedis.HGet(sArticleId, "comments") End If oRedis.DisConnect End Sub ``` ### 4. 配置管理 ```vb Sub ConfigManager() Dim oRedis As New cRedisClient If Not oRedis.Connect() Then Exit Sub Dim sConfigKey As String sConfigKey = "config:app" ' 加载配置 oRedis.HSet sConfigKey, "appname", "MyApp" oRedis.HSet sConfigKey, "version", "1.0.0" oRedis.HSet sConfigKey, "debug", "false" oRedis.HSet sConfigKey, "timeout", "30" oRedis.HSet sConfigKey, "max_users", "1000" ' 获取单个配置 Debug.Print "应用名称: " & oRedis.HGet(sConfigKey, "appname") ' 批量获取配置 Dim vConfigs As Variant vConfigs = oRedis.HMGet(sConfigKey, "debug", "timeout") If IsArray(vConfigs) Then Debug.Print "调试模式: " & vConfigs(0) Debug.Print "超时时间: " & vConfigs(1) & " 秒" End If ' 更新配置 oRedis.HSet sConfigKey, "debug", "true" oRedis.HSet sConfigKey, "version", "1.1.0" ' 获取所有配置 Dim oAllConfig As Dictionary Set oAllConfig = oRedis.HGetAll(sConfigKey) Debug.Print vbCrLf & "所有配置:" Dim vKey As Variant For Each vKey In oAllConfig.Keys Debug.Print " " & vKey & " = " & oAllConfig(vKey) Next oRedis.DisConnect End Sub ``` ### 5. 在线用户状态 ```vb Sub OnlineUserStatus() Dim oRedis As New cRedisClient If Not oRedis.Connect() Then Exit Sub Dim sUserId As String sUserId = "user:123" ' 更新用户在线状态 oRedis.HSet sUserId, "status", "online" oRedis.HSet sUserId, "last_seen", CStr(Now()) oRedis.HSet sUserId, "ip", "192.168.1.100" ' 检查用户是否在线 Dim sStatus As String sStatus = oRedis.HGet(sUserId, "status") Debug.Print "用户状态: " & sStatus ' 获取用户最后活跃时间 Debug.Print "最后活跃: " & oRedis.HGet(sUserId, "last_seen") ' 用户下线 oRedis.HSet sUserId, "status", "offline" oRedis.DisConnect End Sub ``` ## 完整示例 ```vb Sub Example_HashOperations() Dim oRedis As New cRedisClient If Not oRedis.Connect() Then Debug.Print "连接失败: " & oRedis.LastError Exit Sub End If ' 设置用户信息 oRedis.HSet "user:1001", "name", "李四" oRedis.HSet "user:1001", "age", "30" oRedis.HSet "user:1001", "city", "上海" oRedis.HSet "user:1001", "email", "lisi@example.com" ' 获取单个字段 Debug.Print "用户姓名: " & oRedis.HGet("user:1001", "name") ' 获取所有字段 Dim oDict As Dictionary Set oDict = oRedis.HGetAll("user:1001") Debug.Print vbCrLf & "用户详细信息:" Dim vKey As Variant For Each vKey In oDict.Keys Debug.Print " " & vKey & ": " & oDict(vKey) Next ' 检查字段是否存在 If oRedis.HExists("user:1001", "name") Then Debug.Print vbCrLf & "姓名字段存在" End If ' 删除字段 oRedis.HDel "user:1001", "email" Debug.Print "已删除邮箱字段" oRedis.DisConnect End Sub ``` ## Hash vs String 的选择 | 场景 | 推荐类型 | 原因 | | -------------------- | -------- | ---------------------------- | | 存储单个值 | String | 简单高效 | | 存储对象多个字段 | Hash | 更节省内存，支持单独字段操作 | | 频繁更新单个字段 | Hash | 只更新需要修改的字段 | | 需要批量获取部分字段 | Hash | 使用 HMGet 更高效 | | 简单缓存 | String | 实现简单 | --- --- url: /zh/vbman/crypt/hash/methods.md --- # Hash 哈希方法参考 ## 📋 方法列表 ### 传统方式 | 方法 | 说明 | |------|------| | `ComputeHash` | 计算字符串哈希（返回 Hex） | | `ComputeHashBytesToHex` | 计算字节数组哈希（返回 Hex） | | `ComputeHashBytes` | 计算字节数组哈希（返回字节数组） | | `ComputeFileHash` | 计算文件哈希 | ### 链式调用方式 | 方法 | 说明 | |------|------| | `Mode` | 设置哈希算法 | | `DataString` | 输入字符串数据 | | `DataBytes` | 输入字节数组数据 | | `ReturnHex` | 返回 Hex 格式结果 | | `ReturnBase64` | 返回 Base64 格式结果 | | `ReturnBytes` | 返回字节数组结果 | *** ## 🔧 ComputeHash 方法 ### 说明 计算字符串的哈希值，返回十六进制字符串。 ### 语法 ```vb Public Function ComputeHash(ByVal Text As String, _ Optional ByVal Algorithm As CryptoHashAlgorithm, _ Optional ByVal Encoding As CryptoStringEncoding = ENCODING_UTF8) As String ``` ### 参数 | 参数 | 类型 | 说明 | |------|------|------| | `Text` | String | 要哈希的文本字符串 | | `Algorithm` | CryptoHashAlgorithm | 可选，哈希算法（默认使用类属性值） | | `Encoding` | CryptoStringEncoding | 可选，字符串编码（默认 UTF8） | ### 使用示例 ```vb Dim Hash As New cCryptoHash ' 默认 SHA256 Dim result As String result = Hash.ComputeHash("Hello World") ' 指定 MD5 result = Hash.ComputeHash("Hello World", HASH_ALG_MD5) ' 指定 ANSI 编码 result = Hash.ComputeHash("Hello World", HASH_ALG_SHA256, ENCODING_ANSI) ``` *** ## 📦 ComputeHashBytes 方法 ### 说明 计算字节数组的哈希值，返回原始字节数组。 ### 语法 ```vb Public Function ComputeHashBytes(ByRef Data() As Byte, _ Optional ByVal Algorithm As CryptoHashAlgorithm) As Byte() ``` ### 使用示例 ```vb Dim Hash As New cCryptoHash Dim data() As Byte Dim result() As Byte ' 准备字节数组 data = StrConv("Hello World", vbFromUnicode) ' 计算哈希 result = Hash.ComputeHashBytes(data) ' 结果长度 Debug.Print "Hash length: " & UBound(result) + 1 ' SHA256 = 32 bytes ``` *** ## 📁 ComputeFileHash 方法 ### 说明 计算文件的哈希值（二进制模式读取），返回十六进制字符串。 ### 语法 ```vb Public Function ComputeFileHash(ByVal FilePath As String, _ Optional ByVal Algorithm As CryptoHashAlgorithm) As String ``` ### 使用示例 ```vb Dim Hash As New cCryptoHash Dim fileHash As String ' 计算文件哈希 fileHash = Hash.ComputeFileHash("C:\data.txt") Debug.Print "File SHA256: " & fileHash ' 指定算法 fileHash = Hash.ComputeFileHash("C:\data.txt", HASH_ALG_MD5) ``` *** ## ⛓️ 链式调用方法 ### Mode 方法 设置哈希算法，开始链式调用。 ```vb Public Function Mode(ByVal Algorithm As CryptoHashAlgorithm) As cCryptoHash ``` ### DataString 方法 输入字符串数据。 ```vb Public Function DataString(ByVal Text As String, _ Optional ByVal Encoding As CryptoStringEncoding = ENCODING_UTF8) As cCryptoHash ``` ### DataBytes 方法 输入字节数组数据。 ```vb Public Function DataBytes(ByRef Data() As Byte) As cCryptoHash ``` ### ReturnHex 方法 返回十六进制格式的哈希值。 ```vb Public Function ReturnHex(Optional ByVal UpperCase As Boolean = False) As String ``` ### ReturnBase64 方法 返回 Base64 格式的哈希值。 ```vb Public Function ReturnBase64() As String ``` ### ReturnBytes 方法 返回字节数组格式的哈希值。 ```vb Public Function ReturnBytes() As Byte() ``` *** ## 📌 链式调用示例 ### 基本链式调用 ```vb Dim Hash As New cCryptoHash Dim result As String ' 完整链式调用 result = Hash.Mode(HASH_ALG_SHA256) _ .DataString("Hello World") _ .ReturnHex() ``` ### 省略 Mode（使用默认 SHA256） ```vb result = Hash.DataString("Hello World").ReturnHex() ``` ### 多种格式输出 ```vb ' 设置数据和算法 Hash.Mode(HASH_ALG_SHA256).DataString("Hello World") ' 获取不同格式（不重复计算） Debug.Print "Hex: " & Hash.ReturnHex() Debug.Print "Hex(Upper): " & Hash.ReturnHex(True) Debug.Print "Base64: " & Hash.ReturnBase64() ``` ### 字节数组输入 ```vb Dim data() As Byte data = StrConv("Hello World", vbFromUnicode) result = Hash.Mode(HASH_ALG_SHA256) _ .DataBytes(data) _ .ReturnHex() ``` *** ## 📌 使用场景总结 ### 密码存储（推荐 SHA256） ```vb Private Function HashPassword(ByVal password As String, ByVal salt As String) As String Dim Hash As New cCryptoHash ' 密码 + 盐值 Dim saltedPassword As String saltedPassword = password & salt ' 使用 SHA256 HashPassword = Hash.ComputeHash(saltedPassword, HASH_ALG_SHA256) End Function ``` ### 文件完整性校验 ```vb Private Function VerifyFileIntegrity(ByVal filePath As String, ByVal expectedHash As String) As Boolean Dim Hash As New cCryptoHash Dim actualHash As String ' 计算文件哈希 actualHash = Hash.ComputeFileHash(filePath, HASH_ALG_SHA256) ' 比较（不区分大小写） VerifyFileIntegrity = (LCase(actualHash) = LCase(expectedHash)) End Function ``` ### 数据签名前哈希 ```vb Private Function PrepareDataForSigning(ByVal data As String) As Byte() Dim Hash As New cCryptoHash ' 计算哈希并返回字节数组 PrepareDataForSigning = Hash.Mode(HASH_ALG_SHA256) _ .DataString(data) _ .ReturnBytes() End Function ``` *** **最后更新**: 2026-05-17 --- --- url: /zh/vbman/crypt/hash/overview.md --- # Hash 哈希组件概述 ## 📖 简介 `cCryptoHash` 是基于 Windows CryptoAPI 的哈希计算类，支持 MD5、SHA1、SHA256、SHA384、SHA512 等多种哈希算法。 ## ✨ 主要特性 | 特性 | 说明 | |------|------| | **多算法支持** | MD5、SHA1、SHA256、SHA384、SHA512 | | **多种输入** | 支持字符串、字节数组、文件 | | **多种输出** | 支持 Hex 字符串、Base64、字节数组 | | **链式调用** | 流畅的 API 设计，支持方法链式调用 | | **自动提供程序选择** | 自动选择合适的加密服务提供程序 | | **编码支持** | 支持 UTF-8 和 ANSI 编码 | ## 🚀 快速开始 ### 创建实例 ```vb Dim Hash As New cCryptoHash ``` ### 简单哈希计算 ```vb ' 计算字符串哈希（默认 SHA256） Dim hashValue As String hashValue = Hash.ComputeHash("Hello World") Debug.Print hashValue ' 64位十六进制字符串 ``` ### 链式调用 ```vb ' 使用链式调用 Dim result As String result = Hash.Mode(HASH_ALG_SHA256) _ .DataString("Hello World") _ .ReturnHex() ``` ### 计算文件哈希 ```vb ' 计算文件 SHA256 Dim fileHash As String fileHash = Hash.ComputeFileHash("C:\data.txt") ``` ## 📋 支持的算法 | 算法 | 枚举值 | 输出长度 | 说明 | |------|--------|----------|------| | MD5 | `HASH_ALG_MD5` | 128 bit (32 hex) | 不推荐用于安全场景 | | SHA1 | `HASH_ALG_SHA1` | 160 bit (40 hex) | 逐步淘汰中 | | SHA256 | `HASH_ALG_SHA256` | 256 bit (64 hex) | 推荐 | | SHA384 | `HASH_ALG_SHA384` | 384 bit (96 hex) | 高安全 | | SHA512 | `HASH_ALG_SHA512` | 512 bit (128 hex) | 最高安全 | ## 🔗 相关文档 * [methods.md](./methods.md) - 方法详细参考 *** **最后更新**: 2026-05-17 --- --- url: /en/vbman/crypt/hash/overview.md --- # Hash Component Overview ## 📖 Introduction `cCryptoHash` is a Windows CryptoAPI-based hash computation class that supports multiple hash algorithms including MD5, SHA1, SHA256, SHA384, and SHA512. ## ✨ Key Features | Feature | Description | |---------|-------------| | **Multiple Algorithms** | MD5, SHA1, SHA256, SHA384, SHA512 | | **Multiple Inputs** | Supports strings, byte arrays, files | | **Multiple Outputs** | Supports Hex strings, Base64, byte arrays | | **Chainable API** | Fluent API design with method chaining | | **Auto CSP Selection** | Automatically selects appropriate cryptographic service provider | | **Encoding Support** | Supports UTF-8 and ANSI encoding | ## 🚀 Quick Start ### Create Instance ```vb Dim Hash As New cCryptoHash ``` ### Simple Hash Computation ```vb ' Compute string hash (default SHA256) Dim hashValue As String hashValue = Hash.ComputeHash("Hello World") Debug.Print hashValue ' 64-character hex string ``` ### Chainable Call ```vb ' Use chainable call Dim result As String result = Hash.Mode(HASH_ALG_SHA256) _ .DataString("Hello World") _ .ReturnHex() ``` ### Compute File Hash ```vb ' Compute file SHA256 Dim fileHash As String fileHash = Hash.ComputeFileHash("C:\data.txt") ``` ## 📋 Supported Algorithms | Algorithm | Enum Value | Output Length | Description | |-----------|------------|---------------|-------------| | MD5 | `HASH_ALG_MD5` | 128 bit (32 hex) | Not recommended for security | | SHA1 | `HASH_ALG_SHA1` | 160 bit (40 hex) | Being deprecated | | SHA256 | `HASH_ALG_SHA256` | 256 bit (64 hex) | Recommended | | SHA384 | `HASH_ALG_SHA384` | 384 bit (96 hex) | High security | | SHA512 | `HASH_ALG_SHA512` | 512 bit (128 hex) | Highest security | ## 🔗 Related Documentation * [methods.md](./methods.md) - Methods detailed reference *** **Last Updated**: 2026-05-17 --- --- url: /en/vbman/crypt/hash/methods.md --- # Hash Methods Reference ## 📋 Method List ### Traditional Methods | Method | Description | |--------|-------------| | `ComputeHash` | Compute string hash (returns Hex) | | `ComputeHashBytesToHex` | Compute byte array hash (returns Hex) | | `ComputeHashBytes` | Compute byte array hash (returns byte array) | | `ComputeFileHash` | Compute file hash | ### Chainable Methods | Method | Description | |--------|-------------| | `Mode` | Set hash algorithm | | `DataString` | Input string data | | `DataBytes` | Input byte array data | | `ReturnHex` | Return Hex format result | | `ReturnBase64` | Return Base64 format result | | `ReturnBytes` | Return byte array result | *** ## 🔧 ComputeHash Method ### Description Computes the hash value of a string, returning a hexadecimal string. ### Syntax ```vb Public Function ComputeHash(ByVal Text As String, _ Optional ByVal Algorithm As CryptoHashAlgorithm, _ Optional ByVal Encoding As CryptoStringEncoding = ENCODING_UTF8) As String ``` ### Parameters | Parameter | Type | Description | |-----------|------|-------------| | `Text` | String | Text string to hash | | `Algorithm` | CryptoHashAlgorithm | Optional, hash algorithm (defaults to class property value) | | `Encoding` | CryptoStringEncoding | Optional, string encoding (default UTF8) | ### Example ```vb Dim Hash As New cCryptoHash ' Default SHA256 Dim result As String result = Hash.ComputeHash("Hello World") ' Specify MD5 result = Hash.ComputeHash("Hello World", HASH_ALG_MD5) ' Specify ANSI encoding result = Hash.ComputeHash("Hello World", HASH_ALG_SHA256, ENCODING_ANSI) ``` *** ## 📦 ComputeHashBytes Method ### Description Computes the hash of a byte array, returning the raw byte array. ### Syntax ```vb Public Function ComputeHashBytes(ByRef Data() As Byte, _ Optional ByVal Algorithm As CryptoHashAlgorithm) As Byte() ``` ### Example ```vb Dim Hash As New cCryptoHash Dim data() As Byte Dim result() As Byte ' Prepare byte array data = StrConv("Hello World", vbFromUnicode) ' Compute hash result = Hash.ComputeHashBytes(data) ' Result length Debug.Print "Hash length: " & UBound(result) + 1 ' SHA256 = 32 bytes ``` *** ## 📁 ComputeFileHash Method ### Description Computes the hash of a file (binary mode read), returning a hexadecimal string. ### Syntax ```vb Public Function ComputeFileHash(ByVal FilePath As String, _ Optional ByVal Algorithm As CryptoHashAlgorithm) As String ``` ### Example ```vb Dim Hash As New cCryptoHash Dim fileHash As String ' Compute file hash fileHash = Hash.ComputeFileHash("C:\data.txt") Debug.Print "File SHA256: " & fileHash ' Specify algorithm fileHash = Hash.ComputeFileHash("C:\data.txt", HASH_ALG_MD5) ``` *** ## ⛓️ Chainable Methods ### Mode Method Sets the hash algorithm, starts chainable call. ```vb Public Function Mode(ByVal Algorithm As CryptoHashAlgorithm) As cCryptoHash ``` ### DataString Method Inputs string data. ```vb Public Function DataString(ByVal Text As String, _ Optional ByVal Encoding As CryptoStringEncoding = ENCODING_UTF8) As cCryptoHash ``` ### DataBytes Method Inputs byte array data. ```vb Public Function DataBytes(ByRef Data() As Byte) As cCryptoHash ``` ### ReturnHex Method Returns hash value in hexadecimal format. ```vb Public Function ReturnHex(Optional ByVal UpperCase As Boolean = False) As String ``` ### ReturnBase64 Method Returns hash value in Base64 format. ```vb Public Function ReturnBase64() As String ``` ### ReturnBytes Method Returns hash value as byte array. ```vb Public Function ReturnBytes() As Byte() ``` *** ## 📌 Chainable Call Examples ### Basic Chainable Call ```vb Dim Hash As New cCryptoHash Dim result As String ' Complete chainable call result = Hash.Mode(HASH_ALG_SHA256) _ .DataString("Hello World") _ .ReturnHex() ``` ### Omit Mode (using default SHA256) ```vb result = Hash.DataString("Hello World").ReturnHex() ``` ### Multiple Output Formats ```vb ' Set data and algorithm Hash.Mode(HASH_ALG_SHA256).DataString("Hello World") ' Get different formats (without recomputing) Debug.Print "Hex: " & Hash.ReturnHex() Debug.Print "Hex(Upper): " & Hash.ReturnHex(True) Debug.Print "Base64: " & Hash.ReturnBase64() ``` ### Byte Array Input ```vb Dim data() As Byte data = StrConv("Hello World", vbFromUnicode) result = Hash.Mode(HASH_ALG_SHA256) _ .DataBytes(data) _ .ReturnHex() ``` *** ## 📌 Usage Scenarios Summary ### Password Storage (SHA256 Recommended) ```vb Private Function HashPassword(ByVal password As String, ByVal salt As String) As String Dim Hash As New cCryptoHash ' Password + salt Dim saltedPassword As String saltedPassword = password & salt ' Use SHA256 HashPassword = Hash.ComputeHash(saltedPassword, HASH_ALG_SHA256) End Function ``` ### File Integrity Verification ```vb Private Function VerifyFileIntegrity(ByVal filePath As String, ByVal expectedHash As String) As Boolean Dim Hash As New cCryptoHash Dim actualHash As String ' Compute file hash actualHash = Hash.ComputeFileHash(filePath, HASH_ALG_SHA256) ' Compare (case-insensitive) VerifyFileIntegrity = (LCase(actualHash) = LCase(expectedHash)) End Function ``` ### Data Signing Pre-hash ```vb Private Function PrepareDataForSigning(ByVal data As String) As Byte() Dim Hash As New cCryptoHash ' Compute hash and return byte array PrepareDataForSigning = Hash.Mode(HASH_ALG_SHA256) _ .DataString(data) _ .ReturnBytes() End Function ``` *** **Last Updated**: 2026-05-17 --- --- url: /en/vbman/redis/hash-operations.md --- # Hash Operations Redis Hash is a collection of key-value pairs, suitable for storing objects. Each Hash can contain multiple field-value pairs. ## HSet - Set Hash Field ### Set Single Field ```vb oRedis.HSet "user:1", "name", "Zhang San" oRedis.HSet "user:1", "age", "25" oRedis.HSet "user:1", "email", "zhangsan@example.com" ``` ### Batch Set Fields ```vb oRedis.HSet "user:1", "name", "Li Si" oRedis.HSet "user:1", "age", "30" oRedis.HSet "user:1", "city", "Shanghai" oRedis.HSet "user:1", "email", "lisi@example.com" ``` ## HGet - Get Hash Field ```vb Dim sValue As String sValue = oRedis.HGet("user:1", "name") Debug.Print sValue ' Output: Zhang San ``` ## HMGet - Batch Get Hash Fields ```vb ' Batch get fields Dim vValues As Variant vValues = oRedis.HMGet("user:1", "name", "age", "email") If IsArray(vValues) Then Dim i As Long For i = 0 To UBound(vValues) Debug.Print vValues(i) Next End If ``` ## HGetAll - Get All Hash Fields Get all fields and values in a Hash, returns `Dictionary` object: ```vb ' Get all fields and values Dim oDict As Dictionary Set oDict = oRedis.HGetAll("user:1") ' Traverse dictionary Dim vKey As Variant For Each vKey In oDict.Keys Debug.Print vKey & ": " & oDict(vKey) Next ``` **Return Value Type:** `Dictionary` **Note:** Need to add reference to "Microsoft Scripting Runtime" before use. ## HDel - Delete Hash Field ```vb ' Delete single field oRedis.HDel "user:1", "email" ' Delete multiple fields oRedis.HDel "user:1", "age", "email" ``` ## HExists - Check if Hash Field Exists ```vb If oRedis.HExists("user:1", "name") Then Debug.Print "Field exists" Else Debug.Print "Field does not exist" End If ``` ## Use Cases ### 1. User Information Storage ```vb Sub StoreUserInfo() Dim oRedis As New cRedisClient If Not oRedis.Connect() Then Exit Sub Dim lUserId As Long lUserId = 1001 ' Store user information oRedis.HSet "user:" & lUserId, "name", "Zhang San" oRedis.HSet "user:" & lUserId, "age", "25" oRedis.HSet "user:" & lUserId, "email", "zhangsan@example.com" oRedis.HSet "user:" & lUserId, "phone", "13800138000" oRedis.HSet "user:" & lUserId, "city", "Beijing" ' Get user name Debug.Print "User name: " & oRedis.HGet("user:" & lUserId, "name") ' Get user email Debug.Print "User email: " & oRedis.HGet("user:" & lUserId, "email") ' Get all user information Dim oDict As Dictionary Set oDict = oRedis.HGetAll("user:" & lUserId) Debug.Print vbCrLf & "User details:" Dim vKey As Variant For Each vKey In oDict.Keys Debug.Print " " & vKey & ": " & oDict(vKey) Next oRedis.DisConnect End Sub ``` ### 2. Shopping Cart ```vb Sub ShoppingCart() Dim oRedis As New cRedisClient If Not oRedis.Connect() Then Exit Sub Dim sUserId As String sUserId = "cart:user123" ' Add products to cart oRedis.HSet sUserId, "product:1001", "2" ' Product ID: Quantity oRedis.HSet sUserId, "product:1002", "1" oRedis.HSet sUserId, "product:1003", "3" ' Get quantity of a product in cart Debug.Print "Quantity of product 1001: " & oRedis.HGet(sUserId, "product:1001") ' Update product quantity oRedis.HSet sUserId, "product:1001", "5" ' Get all products in cart Dim oCart As Dictionary Set oCart = oRedis.HGetAll(sUserId) Debug.Print vbCrLf & "Cart contents:" Dim vProductId As Variant Dim lTotal As Long lTotal = 0 For Each vProductId In oCart.Keys Dim lCount As Long lCount = CLng(oCart(vProductId)) Debug.Print " " & vProductId & ": " & lCount & " items" lTotal = lTotal + lCount Next Debug.Print "Total items: " & lTotal ' Remove product from cart oRedis.HDel sUserId, "product:1002" oRedis.DisConnect End Sub ``` ### 3. Article Metadata ```vb Sub ArticleMetadata() Dim oRedis As New cRedisClient If Not oRedis.Connect() Then Exit Sub Dim sArticleId As String sArticleId = "article:12345" ' Store article metadata oRedis.HSet sArticleId, "title", "Redis Tutorial" oRedis.HSet sArticleId, "author", "Zhang San" oRedis.HSet sArticleId, "views", "1000" oRedis.HSet sArticleId, "likes", "50" oRedis.HSet sArticleId, "comments", "20" oRedis.HSet sArticleId, "created_at", "2024-01-01" ' Get article title Debug.Print "Article title: " & oRedis.HGet(sArticleId, "title") ' Get author and view count Dim vInfo As Variant vInfo = oRedis.HMGet(sArticleId, "author", "views") If IsArray(vInfo) Then Debug.Print "Author: " & vInfo(0) Debug.Print "Views: " & vInfo(1) End If ' Increment view count Dim lViews As Long lViews = CLng(oRedis.HGet(sArticleId, "views")) oRedis.HSet sArticleId, "views", CStr(lViews + 1) Debug.Print "Updated views: " & oRedis.HGet(sArticleId, "views") ' Check if article has comments If oRedis.HExists(sArticleId, "comments") Then Debug.Print "Comments: " & oRedis.HGet(sArticleId, "comments") End If oRedis.DisConnect End Sub ``` ### 4. Configuration Management ```vb Sub ConfigManager() Dim oRedis As New cRedisClient If Not oRedis.Connect() Then Exit Sub Dim sConfigKey As String sConfigKey = "config:app" ' Load configuration oRedis.HSet sConfigKey, "appname", "MyApp" oRedis.HSet sConfigKey, "version", "1.0.0" oRedis.HSet sConfigKey, "debug", "false" oRedis.HSet sConfigKey, "timeout", "30" oRedis.HSet sConfigKey, "max_users", "1000" ' Get single configuration Debug.Print "Application name: " & oRedis.HGet(sConfigKey, "appname") ' Batch get configuration Dim vConfigs As Variant vConfigs = oRedis.HMGet(sConfigKey, "debug", "timeout") If IsArray(vConfigs) Then Debug.Print "Debug mode: " & vConfigs(0) Debug.Print "Timeout: " & vConfigs(1) & " seconds" End If ' Update configuration oRedis.HSet sConfigKey, "debug", "true" oRedis.HSet sConfigKey, "version", "1.1.0" ' Get all configuration Dim oAllConfig As Dictionary Set oAllConfig = oRedis.HGetAll(sConfigKey) Debug.Print vbCrLf & "All configuration:" Dim vKey As Variant For Each vKey In oAllConfig.Keys Debug.Print " " & vKey & " = " & oAllConfig(vKey) Next oRedis.DisConnect End Sub ``` ### 5. Online User Status ```vb Sub OnlineUserStatus() Dim oRedis As New cRedisClient If Not oRedis.Connect() Then Exit Sub Dim sUserId As String sUserId = "user:123" ' Update user online status oRedis.HSet sUserId, "status", "online" oRedis.HSet sUserId, "last_seen", CStr(Now()) oRedis.HSet sUserId, "ip", "192.168.1.100" ' Check if user is online Dim sStatus As String sStatus = oRedis.HGet(sUserId, "status") Debug.Print "User status: " & sStatus ' Get user last active time Debug.Print "Last active: " & oRedis.HGet(sUserId, "last_seen") ' User offline oRedis.HSet sUserId, "status", "offline" oRedis.DisConnect End Sub ``` ## Complete Example ```vb Sub Example_HashOperations() Dim oRedis As New cRedisClient If Not oRedis.Connect() Then Debug.Print "Connection failed: " & oRedis.LastError Exit Sub End If ' Set user information oRedis.HSet "user:1001", "name", "Li Si" oRedis.HSet "user:1001", "age", "30" oRedis.HSet "user:1001", "city", "Shanghai" oRedis.HSet "user:1001", "email", "lisi@example.com" ' Get single field Debug.Print "User name: " & oRedis.HGet("user:1001", "name") ' Get all fields Dim oDict As Dictionary Set oDict = oRedis.HGetAll("user:1001") Debug.Print vbCrLf & "User details:" Dim vKey As Variant For Each vKey In oDict.Keys Debug.Print " " & vKey & ": " & oDict(vKey) Next ' Check if field exists If oRedis.HExists("user:1001", "name") Then Debug.Print vbCrLf & "Name field exists" End If ' Delete field oRedis.HDel "user:1001", "email" Debug.Print "Deleted email field" oRedis.DisConnect End Sub ``` ## Hash vs String Selection | Scenario | Recommended Type | Reason | | -------------------------------- | ---------------- | ------------------------------------------------ | | Store single value | String | Simple and efficient | | Store object fields | Hash | More memory efficient, supports field operations | | Frequently update single field | Hash | Only update modified fields | | Need to batch get partial fields | Hash | Use HMGet for better efficiency | | Simple cache | String | Simple implementation | --- --- url: /zh/vbman/crypt/hmac/methods.md --- # HMAC 方法参考 ## 📋 方法列表 ### 传统方式 | 方法 | 说明 | |------|------| | `SetKey` | 从字符串设置密钥 | | `SetKeyBytes` | 从字节数组设置密钥 | | `Compute` | 计算字符串 HMAC（返回 Hex） | | `ComputeBytes` | 计算字节数组 HMAC（返回字节数组） | | `ComputeBytesToHex` | 计算字节数组 HMAC（返回 Hex） | ### 链式调用方式 | 方法 | 说明 | |------|------| | `Mode` | 设置 HMAC 算法 | | `Secret` | 从字符串/Hex/Base64 设置密钥 | | `SecretBytes` | 从字节数组设置密钥 | | `DataString` | 输入字符串数据 | | `DataBytes` | 输入字节数组数据 | | `ReturnHex` | 返回 Hex 格式结果 | | `ReturnBase64` | 返回 Base64 格式结果 | | `ReturnBytes` | 返回字节数组结果 | *** ## 🔑 SetKey / SetKeyBytes 方法 ### 说明 设置 HMAC 密钥（传统方式）。 ### 语法 ```vb ' 从字符串设置 Public Sub SetKey(ByVal KeyString As String, _ Optional ByVal Encoding As HMACStringEncoding = HMAC_ENCODING_UTF8) ' 从字节数组设置 Public Sub SetKeyBytes(ByRef KeyBytes() As Byte) ``` ### 使用示例 ```vb Dim Hmac As New cCryptoHMAC ' 设置 UTF-8 密钥 Hmac.SetKey("my-secret-key") ' 设置 ANSI 密钥 Hmac.SetKey("my-secret-key", HMAC_ENCODING_ANSI) ' 设置字节数组密钥 Dim keyBytes() As Byte keyBytes = StrConv("my-key", vbFromUnicode) Hmac.SetKeyBytes(keyBytes) ``` *** ## 🔐 Compute 方法 ### 说明 计算字符串数据的 HMAC，返回十六进制字符串。 ### 语法 ```vb Public Function Compute(ByVal Data As String, _ ByVal KeyString As String, _ Optional ByVal Algorithm As HMACAlgorithm, _ Optional ByVal Encoding As HMACStringEncoding = HMAC_ENCODING_UTF8) As String ``` ### 参数 | 参数 | 类型 | 说明 | |------|------|------| | `Data` | String | 要签名的数据 | | `KeyString` | String | 密钥字符串 | | `Algorithm` | HMACAlgorithm | 可选，算法（默认使用类属性） | | `Encoding` | HMACStringEncoding | 可选，编码（默认 UTF8） | ### 使用示例 ```vb Dim Hmac As New cCryptoHMAC Dim result As String ' 简单计算 result = Hmac.Compute("data to sign", "secret-key") ' 指定算法 result = Hmac.Compute("data to sign", "secret-key", HMAC_ALG_SHA256) ``` *** ## ⛓️ 链式调用方法 ### Mode 方法 设置 HMAC 算法。 ```vb Public Function Mode(ByVal Algorithm As HMACAlgorithm) As cCryptoHMAC ``` ### Secret 方法 设置密钥，支持字符串、Hex、Base64 格式。 ```vb Public Function Secret(ByVal KeyString As String, _ Optional ByVal KeyType As SecretKeyType = SECRET_KEY_STRING, _ Optional ByVal Encoding As HMACStringEncoding = HMAC_ENCODING_UTF8) As cCryptoHMAC ``` **密钥类型：** * `SECRET_KEY_STRING` - 普通字符串（默认） * `SECRET_KEY_HEX` - Hex 编码的密钥 * `SECRET_KEY_BASE64` - Base64 编码的密钥 ### SecretBytes 方法 从字节数组设置密钥。 ```vb Public Function SecretBytes(ByRef KeyBytes() As Byte) As cCryptoHMAC ``` ### DataString 方法 输入字符串数据。 ```vb Public Function DataString(ByVal Text As String, _ Optional ByVal Encoding As HMACStringEncoding = HMAC_ENCODING_UTF8) As cCryptoHMAC ``` ### DataBytes 方法 输入字节数组数据。 ```vb Public Function DataBytes(ByRef Data() As Byte) As cCryptoHMAC ``` ### ReturnHex 方法 返回十六进制格式的 HMAC。 ```vb Public Function ReturnHex(Optional ByVal UpperCase As Boolean = False) As String ``` ### ReturnBase64 方法 返回 Base64 格式的 HMAC。 ```vb Public Function ReturnBase64() As String ``` ### ReturnBytes 方法 返回字节数组格式的 HMAC。 ```vb Public Function ReturnBytes() As Byte() ``` *** ## 📌 链式调用示例 ### 基本链式调用 ```vb Dim Hmac As New cCryptoHMAC Dim result As String ' 完整链式调用 result = Hmac.Mode(HMAC_ALG_SHA256) _ .Secret("secret-key") _ .DataString("data to sign") _ .ReturnHex() ``` ### 使用 Hex 密钥 ```vb ' 使用 Hex 格式的密钥 result = Hmac.Mode(HMAC_ALG_SHA256) _ .Secret("deadbeef123456", SECRET_KEY_HEX) _ .DataString("data") _ .ReturnHex() ``` ### 多种格式输出 ```vb ' 设置密钥和数据 Hmac.Mode(HMAC_ALG_SHA256) _ .Secret("secret") _ .DataString("data") ' 获取不同格式 Debug.Print "Hex: " & Hmac.ReturnHex() Debug.Print "Hex(Upper): " & Hmac.ReturnHex(True) Debug.Print "Base64: " & Hmac.ReturnBase64() ``` *** ## 📌 使用场景总结 ### API 请求签名 ```vb Private Function SignApiRequest(ByVal method As String, _ ByVal path As String, _ ByVal timestamp As String, _ ByVal apiSecret As String) As String Dim Hmac As New cCryptoHMAC Dim dataToSign As String ' 构建签名字符串 dataToSign = method & "|" & path & "|" & timestamp ' 计算 HMAC SignApiRequest = Hmac.Mode(HMAC_ALG_SHA256) _ .Secret(apiSecret) _ .DataString(dataToSign) _ .ReturnHex() End Function ``` ### 消息认证 ```vb Private Function CreateMessageAuth(ByVal message As String, _ ByVal sharedSecret As String) As String Dim Hmac As New cCryptoHMAC ' 创建消息认证码 CreateMessageAuth = Hmac.Compute(message, sharedSecret, HMAC_ALG_SHA256) End Function Private Function VerifyMessageAuth(ByVal message As String, _ ByVal mac As String, _ ByVal sharedSecret As String) As Boolean Dim Hmac As New cCryptoHMAC Dim expectedMac As String ' 重新计算 MAC expectedMac = Hmac.Compute(message, sharedSecret, HMAC_ALG_SHA256) ' 比较（不区分大小写） VerifyMessageAuth = (LCase(mac) = LCase(expectedMac)) End Function ``` ### JWT 签名 ```vb Private Function CreateJwtSignature(ByVal headerBase64 As String, _ ByVal payloadBase64 As String, _ ByVal secret As String) As String Dim Hmac As New cCryptoHMAC Dim signingInput As String ' JWT 签名输入 signingInput = headerBase64 & "." & payloadBase64 ' HS256 签名 CreateJwtSignature = Hmac.Mode(HMAC_ALG_SHA256) _ .Secret(secret) _ .DataString(signingInput) _ .ReturnBase64() End Function ``` *** **最后更新**: 2026-05-17 --- --- url: /zh/vbman/crypt/hmac/overview.md --- # HMAC 组件概述 ## 📖 简介 `cCryptoHMAC` 是基于 Windows CryptoAPI 的 HMAC（Hash-based Message Authentication Code）实现，支持 HMAC-SHA1 和 HMAC-SHA256 算法。 ## ✨ 主要特性 | 特性 | 说明 | |------|------| | **标准 HMAC** | 遵循 RFC 2104 标准实现 | | **双算法支持** | HMAC-SHA1、HMAC-SHA256 | | **密钥灵活** | 支持字符串、字节数组、Hex、Base64 格式的密钥 | | **链式调用** | 流畅的 API 设计，支持方法链式调用 | | **多种输出** | 支持 Hex、Base64、字节数组输出 | | **自动密钥处理** | 密钥长度自动处理（超过块大小自动哈希） | ## 🚀 快速开始 ### 创建实例 ```vb Dim Hmac As New cCryptoHMAC ``` ### 简单计算 ```vb ' 计算 HMAC（默认 SHA256） Dim result As String result = Hmac.Compute("data to sign", "secret-key") Debug.Print result ``` ### 链式调用 ```vb ' 使用链式调用 Dim result As String result = Hmac.Mode(HMAC_ALG_SHA256) _ .Secret("secret-key") _ .DataString("data to sign") _ .ReturnHex() ``` ## 📋 支持的算法 | 算法 | 枚举值 | 块大小 | 说明 | |------|--------|--------|------| | HMAC-SHA1 | `HMAC_ALG_SHA1` | 64 bytes | 兼容性好 | | HMAC-SHA256 | `HMAC_ALG_SHA256` | 64 bytes | 安全性高（推荐） | ## 🔐 HMAC 用途 HMAC 主要用于： 1. **API 请求签名** - 验证请求完整性和身份 2. **消息认证** - 确保消息未被篡改 3. **数据完整性校验** - 配合密钥的完整性验证 4. **JWT 签名** - JSON Web Token 的签名部分 ## 🔗 相关文档 * [methods.md](./methods.md) - 方法详细参考 *** **最后更新**: 2026-05-17 --- --- url: /en/vbman/crypt/hmac/overview.md --- # HMAC Component Overview ## 📖 Introduction `cCryptoHMAC` is a Windows CryptoAPI-based HMAC (Hash-based Message Authentication Code) implementation that supports HMAC-SHA1 and HMAC-SHA256 algorithms. ## ✨ Key Features | Feature | Description | |---------|-------------| | **Standard HMAC** | Implemented according to RFC 2104 standard | | **Dual Algorithm Support** | HMAC-SHA1, HMAC-SHA256 | | **Flexible Keys** | Supports keys in string, byte array, Hex, Base64 formats | | **Chainable API** | Fluent API design with method chaining | | **Multiple Outputs** | Supports Hex, Base64, byte array output | | **Auto Key Processing** | Automatic key length handling (auto-hash if exceeds block size) | ## 🚀 Quick Start ### Create Instance ```vb Dim Hmac As New cCryptoHMAC ``` ### Simple Computation ```vb ' Compute HMAC (default SHA256) Dim result As String result = Hmac.Compute("data to sign", "secret-key") Debug.Print result ``` ### Chainable Call ```vb ' Use chainable call Dim result As String result = Hmac.Mode(HMAC_ALG_SHA256) _ .Secret("secret-key") _ .DataString("data to sign") _ .ReturnHex() ``` ## 📋 Supported Algorithms | Algorithm | Enum Value | Block Size | Description | |-----------|------------|------------|-------------| | HMAC-SHA1 | `HMAC_ALG_SHA1` | 64 bytes | Good compatibility | | HMAC-SHA256 | `HMAC_ALG_SHA256` | 64 bytes | High security (recommended) | ## 🔐 HMAC Use Cases HMAC is mainly used for: 1. **API Request Signing** - Verify request integrity and identity 2. **Message Authentication** - Ensure message has not been tampered with 3. **Data Integrity Verification** - Integrity verification with keys 4. **JWT Signing** - Signature part of JSON Web Tokens ## 🔗 Related Documentation * [methods.md](./methods.md) - Methods detailed reference *** **Last Updated**: 2026-05-17 --- --- url: /en/vbman/crypt/hmac/methods.md --- # HMAC Methods Reference ## 📋 Method List ### Traditional Methods | Method | Description | |--------|-------------| | `SetKey` | Set key from string | | `SetKeyBytes` | Set key from byte array | | `Compute` | Compute string HMAC (returns Hex) | | `ComputeBytes` | Compute byte array HMAC (returns byte array) | | `ComputeBytesToHex` | Compute byte array HMAC (returns Hex) | ### Chainable Methods | Method | Description | |--------|-------------| | `Mode` | Set HMAC algorithm | | `Secret` | Set key from string/Hex/Base64 | | `SecretBytes` | Set key from byte array | | `DataString` | Input string data | | `DataBytes` | Input byte array data | | `ReturnHex` | Return Hex format result | | `ReturnBase64` | Return Base64 format result | | `ReturnBytes` | Return byte array result | *** ## 🔑 SetKey / SetKeyBytes Methods ### Description Sets the HMAC key (traditional way). ### Syntax ```vb ' Set from string Public Sub SetKey(ByVal KeyString As String, _ Optional ByVal Encoding As HMACStringEncoding = HMAC_ENCODING_UTF8) ' Set from byte array Public Sub SetKeyBytes(ByRef KeyBytes() As Byte) ``` ### Example ```vb Dim Hmac As New cCryptoHMAC ' Set UTF-8 key Hmac.SetKey "my-secret-key" ' Set ANSI key Hmac.SetKey "my-secret-key", HMAC_ENCODING_ANSI ' Set byte array key Dim keyBytes() As Byte keyBytes = StrConv("my-key", vbFromUnicode) Hmac.SetKeyBytes keyBytes ``` *** ## 🔐 Compute Method ### Description Computes HMAC of string data, returning a hexadecimal string. ### Syntax ```vb Public Function Compute(ByVal Data As String, _ ByVal KeyString As String, _ Optional ByVal Algorithm As HMACAlgorithm, _ Optional ByVal Encoding As HMACStringEncoding = HMAC_ENCODING_UTF8) As String ``` ### Parameters | Parameter | Type | Description | |-----------|------|-------------| | `Data` | String | Data to sign | | `KeyString` | String | Key string | | `Algorithm` | HMACAlgorithm | Optional, algorithm (defaults to class property) | | `Encoding` | HMACStringEncoding | Optional, encoding (default UTF8) | ### Example ```vb Dim Hmac As New cCryptoHMAC Dim result As String ' Simple computation result = Hmac.Compute("data to sign", "secret-key") ' Specify algorithm result = Hmac.Compute("data to sign", "secret-key", HMAC_ALG_SHA256) ``` *** ## ⛓️ Chainable Methods ### Mode Method Sets the HMAC algorithm. ```vb Public Function Mode(ByVal Algorithm As HMACAlgorithm) As cCryptoHMAC ``` ### Secret Method Sets the key, supports string, Hex, Base64 formats. ```vb Public Function Secret(ByVal KeyString As String, _ Optional ByVal KeyType As SecretKeyType = SECRET_KEY_STRING, _ Optional ByVal Encoding As HMACStringEncoding = HMAC_ENCODING_UTF8) As cCryptoHMAC ``` **Key Types:** * `SECRET_KEY_STRING` - Plain string (default) * `SECRET_KEY_HEX` - Hex-encoded key * `SECRET_KEY_BASE64` - Base64-encoded key ### SecretBytes Method Sets the key from byte array. ```vb Public Function SecretBytes(ByRef KeyBytes() As Byte) As cCryptoHMAC ``` ### DataString Method Inputs string data. ```vb Public Function DataString(ByVal Text As String, _ Optional ByVal Encoding As HMACStringEncoding = HMAC_ENCODING_UTF8) As cCryptoHMAC ``` ### DataBytes Method Inputs byte array data. ```vb Public Function DataBytes(ByRef Data() As Byte) As cCryptoHMAC ``` ### ReturnHex Method Returns HMAC in hexadecimal format. ```vb Public Function ReturnHex(Optional ByVal UpperCase As Boolean = False) As String ``` ### ReturnBase64 Method Returns HMAC in Base64 format. ```vb Public Function ReturnBase64() As String ``` ### ReturnBytes Method Returns HMAC as byte array. ```vb Public Function ReturnBytes() As Byte() ``` *** ## 📌 Chainable Call Examples ### Basic Chainable Call ```vb Dim Hmac As New cCryptoHMAC Dim result As String ' Complete chainable call result = Hmac.Mode(HMAC_ALG_SHA256) _ .Secret("secret-key") _ .DataString("data to sign") _ .ReturnHex() ``` ### Using Hex Key ```vb ' Use Hex-formatted key result = Hmac.Mode(HMAC_ALG_SHA256) _ .Secret("deadbeef123456", SECRET_KEY_HEX) _ .DataString("data") _ .ReturnHex() ``` ### Multiple Output Formats ```vb ' Set key and data Hmac.Mode(HMAC_ALG_SHA256) _ .Secret("secret") _ .DataString("data") ' Get different formats Debug.Print "Hex: " & Hmac.ReturnHex() Debug.Print "Hex(Upper): " & Hmac.ReturnHex(True) Debug.Print "Base64: " & Hmac.ReturnBase64() ``` *** ## 📌 Usage Scenarios Summary ### API Request Signing ```vb Private Function SignApiRequest(ByVal method As String, _ ByVal path As String, _ ByVal timestamp As String, _ ByVal apiSecret As String) As String Dim Hmac As New cCryptoHMAC Dim dataToSign As String ' Build signature string dataToSign = method & "|" & path & "|" & timestamp ' Compute HMAC SignApiRequest = Hmac.Mode(HMAC_ALG_SHA256) _ .Secret(apiSecret) _ .DataString(dataToSign) _ .ReturnHex() End Function ``` ### Message Authentication ```vb Private Function CreateMessageAuth(ByVal message As String, _ ByVal sharedSecret As String) As String Dim Hmac As New cCryptoHMAC ' Create message authentication code CreateMessageAuth = Hmac.Compute(message, sharedSecret, HMAC_ALG_SHA256) End Function Private Function VerifyMessageAuth(ByVal message As String, _ ByVal mac As String, _ ByVal sharedSecret As String) As Boolean Dim Hmac As New cCryptoHMAC Dim expectedMac As String ' Recompute MAC expectedMac = Hmac.Compute(message, sharedSecret, HMAC_ALG_SHA256) ' Compare (case-insensitive) VerifyMessageAuth = (LCase(mac) = LCase(expectedMac)) End Function ``` ### JWT Signing ```vb Private Function CreateJwtSignature(ByVal headerBase64 As String, _ ByVal payloadBase64 As String, _ ByVal secret As String) As String Dim Hmac As New cCryptoHMAC Dim signingInput As String ' JWT signing input signingInput = headerBase64 & "." & payloadBase64 ' HS256 signature CreateJwtSignature = Hmac.Mode(HMAC_ALG_SHA256) _ .Secret(secret) _ .DataString(signingInput) _ .ReturnBase64() End Function ``` *** **Last Updated**: 2026-05-17 --- --- url: /en/vbman2/webview2/hosting.md --- # Host Adaptation Guide - VB6/Excel/Access Multi-Host Integration ## 📖 Table of Contents * [Overview](#overview) * [Adapter Architecture](#adapter-architecture) * [Subclassing Adapter (VB6/Excel)](#subclassing-adapter-vb6excel) * [Message Window Adapter (Access)](#message-window-adapter-access) * [Host Usage Guides](#host-usage-guides) * [FAQ](#faq) *** ## Overview cWebView2Host needs to embed the WebView2 child window into the host application's window and bridge events through message interception. Different host environments (VB6, Excel UserForm, Access Form) have significantly different window mechanisms, so an adapter layer is designed to abstract away these differences. ### ✨ Core Features * 🔄 **Auto-Detection** - Automatically selects adapter based on Windows class name * 🖥️ **Seamless Adaptation** - VB6/Excel/Access use exactly the same API * 🛡️ **Access Safety** - Message window adapter avoids Access window subclassing crashes * 📡 **Event Bridging** - Unified HostMouse/HostKey event model *** ## Adapter Architecture ### IHostAdapter Interface ```vb Interface IHostAdapter Sub Attach(hostHWnd As LongPtr, core As WebView2Core) Sub Detach() Sub ScheduleOnMainThread(core As WebView2Core) Sub EnsureChildVisible(childHWnd As LongPtr, width As Long, height As Long) Sub SyncChildSize(childHWnd As LongPtr, width As Long, height As Long) Function FindAndSubclassWv2Child() As LongPtr Sub CleanupChildSubclass() Property Get Wv2ChildHWnd() As LongPtr Property Get AdapterName() As String End Interface ``` ### Auto-Selection Logic ``` Initialize(HostOrHwnd, HttpOrDir) │ ├── Get host window hWnd │ ├── GetClassName(hWnd) == "OForm" ? │ ├── Yes → Create MessageWindowAdapter │ │ (Access window, cannot be safely subclassed) │ │ │ └── No → Create HostSubclassAdapter (VB6/Excel/UserForm, can be safely subclassed) ``` ### Adapter Responsibility Comparison | Responsibility | HostSubclassAdapter | MessageWindowAdapter | |----------------|--------------------|--------------------| | Host window subclassing | Direct subclassing | No subclassing (creates message window) | | Message window | Not needed | Creates HWND\_MESSAGE message window | | Size synchronization | WM\_SIZE interception | 200ms timer polling | | Focus management | WM\_SETFOCUS/KILLFOCUS | Timer check + focus guardian | | Host mouse events | Fully supported | Not supported | | Host keyboard events | Fully supported | Not supported | | WV2 child right-click capture | Subclasses Chrome\_WidgetWin\_0 | Subclasses Chrome\_WidgetWin\_0 | | Child window visibility | Automatic | Force TOP+VISIBLE (Access occlusion issue) | *** ## Subclassing Adapter (VB6/Excel) ### How It Works ``` VB6 Form (hWnd) │ [SetWindowSubclass] → SubclassProc │ ├── WM_SIZE → Adjust WV2 Controller Bounds + SyncChildSize ├── WM_SETFOCUS → Fire HostFocus event ├── WM_KILLFOCUS → Fire HostBlur event ├── WM_KEYDOWN/UP → Fire HostKeyDown/Up event ├── WM_CHAR → Fire HostKeyPress event ├── WM_xBUTTONDOWN/UP/DBLCLK → Fire HostMouseDown/Up/DblClick ├── WM_MOUSEMOVE → Fire HostMouseMove (requires EnableMouseMoveEvents) ├── WM_MOUSEWHEEL → Fire HostMouseWheel ├── WM_CONTEXTMENU → Fire HostContextMenu ├── WM_DESTROY → AdapterTriggerCleanup └── WM_WV2_DEFERRED_CALLBACK → ProcessDeferredCallbacks Chrome_WidgetWin_0 (WV2 child window) │ [SetWindowSubclass] → ChildSubclassProc │ ├── WM_RBUTTONDOWN → Forward to Core ├── WM_RBUTTONUP → Forward to Core ├── WM_CONTEXTMENU → Fire HostContextMenu └── WM_DESTROY → Cleanup subclassing ``` ### Usage Limitations * Cannot use other third-party window subclassing tools during subclassing (potential conflicts) * AddressOf may return different thunks in VB6, but the adapter saves it once during Attach *** ## Message Window Adapter (Access) ### How It Works Access OForm windows are managed by the Access runtime — direct subclassing causes crashes. MessageWindowAdapter creates an independent hidden message window to work around this issue. ``` Access OForm (cannot be subclassed) │ ├── Create Message-Only Window (HWND_MESSAGE parent) │ │ [SetWindowSubclass] → SubclassProc (safe: we own this window) │ │ │ ├── WM_WV2_DEFERRED_CALLBACK → ProcessDeferredCallbacks │ ├── WM_TIMER → │ │ ├── 200ms polling: check host size change → SyncChildSize │ │ └── 5-tick focus guardian: check GetFocus()==0 → restore focus │ └── WM_DESTROY → Cleanup │ └── Chrome_WidgetWin_0 (WV2 child window) │ [SetWindowSubclass] → ChildSubclassProc │ ├── WM_RBUTTONDOWN/UP → Forward to Core └── WM_CONTEXTMENU → Forward to Core ``` ### Access-Specific Handling #### Child Window Visibility Enforcement Access's rendering engine may draw over the WV2 child window, causing content to be obscured. `EnsureChildVisible()` forces the child window to TOP + VISIBLE: ```vb ' Internal implementation SetWindowPos childHWnd, HWND_TOP, 0, 0, width, height, _ SWP_NOMOVE Or SWP_NOZORDER Or SWP_SHOWWINDOW ``` #### Focus Guardian Access may unexpectedly steal focus, preventing WebView2 from receiving keyboard input. The adapter checks focus state once per second: ``` Every 5 timer cycles (approximately 1 second): If GetFocus() == 0 ' No window has focus SetFocus(hostHWnd) ' Restore focus to host window Cooldown 3 seconds to avoid focus fighting ``` #### Size Synchronization Since OForm's WM\_SIZE cannot be intercepted, a 200ms timer polling is used: ```vb ' Timer callback GetClientRect hostHWnd, rc If rc.Width <> lastWidth Or rc.Height <> lastHeight Then Controller.Bounds = rc ' Update WV2 control size SyncChildSize ' Sync child window End If ``` *** ## Host Usage Guides ### VB6 Standard Form ```vb Dim WithEvents wv As cWebView2Host Private Sub Form_Load() Set wv = New cWebView2Host wv.Initialize Me.hWnd, "https://vb6.pro" ' Automatically uses HostSubclassAdapter End Sub Private Sub Form_Resize() ' Subclassing adapter already handles WM_SIZE automatically ' Usually no need to call Resize manually End Sub Private Sub Form_Unload(Cancel As Integer) Set wv = Nothing End Sub ``` ### VB6 MDI Child Form ```vb Dim WithEvents wv As cWebView2Host Dim ThisUrl As String Public Sub Init(Optional ByVal Url As String) Me.Show If Url = "" Then Url = "https://vb6.pro" ThisUrl = Url Set wv = New cWebView2Host wv.Initialize Me ' Auto-gets Me.hWnd End Sub Private Sub wv_Ready() wv.Navigate ThisUrl End Sub ``` ### Excel UserForm ```vb ' In UserForm code module Dim WithEvents wv As cWebView2Host Private Sub UserForm_Initialize() Set wv = New cWebView2Host wv.Initialize Me.hWnd, "https://example.com" End Sub Private Sub UserForm_Terminate() Set wv = Nothing End Sub ``` ### Access Form ```vb ' In Access form code module Dim WithEvents wv As cWebView2Host Private Sub Form_Load() Set wv = New cWebView2Host wv.Initialize Me.hWnd, "https://example.com" ' Auto-detects OForm → Uses MessageWindowAdapter ' Host mouse/keyboard events are not available End Sub Private Sub Form_Close() Set wv = Nothing End Sub ``` ### Embedding in VB6 Frame Control WebView2 can also be embedded in a Frame control instead of the entire Form: ```vb Dim wv As New cWebView2Host Private Sub Form_Load() wv.Initialize Me.Frame1.hWnd, "https://example.com" End Sub ``` *** ## FAQ ### ❓ Q1: How to determine which adapter is currently in use? ```vb Debug.Print wv.HostAdapterName ' Outputs "HostSubclassAdapter" or "MessageWindowAdapter" ``` *** ### ❓ Q2: Host mouse events not firing in Access? **Reason**: MessageWindowAdapter does not subclass the host window, so it cannot intercept mouse/keyboard messages in the host area. **Solution**: Use WebView2 content area events (UserMouse series) instead, or use BindUI to bind DOM events to VB6 methods. *** ### ❓ Q3: WebView2 occasionally gets obscured in Access? **Reason**: The Access rendering engine draws over the WV2 child window, especially after switching windows. **Solution**: MessageWindowAdapter handles this internally (EnsureChildVisible). If occlusion persists, manually call: ```vb wv.Resize ' Trigger child window refresh ``` *** ### ❓ Q4: WebView2 size not syncing after Resize in VB6? **Reason**: HostSubclassAdapter automatically handles size synchronization in WM\_SIZE, but certain scenarios (e.g., manually resizing the window) may require additional triggering. **Solution**: ```vb Private Sub Form_Resize() If Not wv Is Nothing Then wv.Resize End If End Sub ``` *** ### ❓ Q5: Are multiple WebView2 instances supported? **Yes**. Each `cWebView2Host` instance independently manages its own WebView2 control. In MDI applications, each child form can have its own WebView2 instance: ```vb ' MDI child form Dim WithEvents wv As cWebView2Host Private Sub Init(ByVal Url As String) Set wv = New cWebView2Host wv.Initialize Me.hWnd, Url End Sub ``` Note: Multiple instances should use different `UserDataFolder` to avoid data conflicts. *** **Last Updated**: 2026-06-24 --- --- url: /en/packages/vbccr/text/hotkey.md description: >- HotKey Control - VBCCR Development Manual, complete API reference based on source code --- # HotKey Control Provides the Windows standard hot key input control, allowing users to select shortcut key combinations. ## Enumerations ### HkeInvalidKeyCombinationConstants | Constant | Value | Description | |----------|-------|-------------| | HkeInvalidKeyCombinationNone | 1 | Invalid combination: no modifier | | HkeInvalidKeyCombinationShift | 2 | Invalid combination: Shift only | | HkeInvalidKeyCombinationCtrl | 4 | Invalid combination: Ctrl only | | HkeInvalidKeyCombinationAlt | 8 | Invalid combination: Alt only | | HkeInvalidKeyCombinationShiftCtrl | 16 | Invalid combination: Shift+Ctrl | | HkeInvalidKeyCombinationShiftAlt | 32 | Invalid combination: Shift+Alt | | HkeInvalidKeyCombinationCtrlAlt | 64 | Invalid combination: Ctrl+Alt | | HkeInvalidKeyCombinationShiftCtrlAlt | 128 | Invalid combination: Shift+Ctrl+Alt | ## Properties ### Name ```vb Property Get Name() As String ``` Returns the name of the control. ### Tag ```vb Property Get/Let Tag() As String ``` Returns/sets the tag value of the control. ### Parent ```vb Property Get Parent() As Object ``` Returns the parent object of the control. ### Container ```vb Property Get/Set Container() As Object ``` Returns/sets the container of the control. ### Left ```vb Property Get/Let Left() As Single ``` Returns/sets the position of the left edge of the control. ### Top ```vb Property Get/Let Top() As Single ``` Returns/sets the position of the top edge of the control. ### Width ```vb Property Get/Let Width() As Single ``` Returns/sets the width of the control. ### Height ```vb Property Get/Let Height() As Single ``` Returns/sets the height of the control. ### Visible ```vb Property Get/Let Visible() As Boolean ``` Returns/sets whether the control is visible. ### ToolTipText ```vb Property Get/Let ToolTipText() As String ``` Returns/sets the tooltip text of the control. ### HelpContextID ```vb Property Get/Let HelpContextID() As Long ``` Returns/sets the help context ID of the control. ### WhatsThisHelpID ```vb Property Get/Let WhatsThisHelpID() As Long ``` Returns/sets the "What's This" help ID of the control. ### DragIcon ```vb Property Get/Let/Set DragIcon() As IPictureDisp ``` Returns/sets the icon displayed during drag operations. ### DragMode ```vb Property Get/Let DragMode() As Integer ``` Returns/sets the drag mode (manual or automatic). ### hWnd ```vb Property Get hWnd() As LongPtr ``` Returns the window handle of the HotKey control. ### hWndUserControl ```vb Property Get hWndUserControl() As LongPtr ``` Returns the window handle of the UserControl. ### Font ```vb Property Get/Let/Set Font() As StdFont ``` Returns/sets the font used by the control. ### VisualStyles ```vb Property Get/Let VisualStyles() As Boolean ``` Returns/sets whether visual styles are enabled. ### Enabled ```vb Property Get/Let Enabled() As Boolean ``` Returns/sets whether the control is enabled. ### OLEDropMode ```vb Property Get/Let OLEDropMode() As OLEDropModeConstants ``` Returns/sets the OLE drop mode. See common enumerations. ### MousePointer ```vb Property Get/Let MousePointer() As CCMousePointerConstants ``` Returns/sets the mouse pointer type. See common enumerations. ### MouseIcon ```vb Property Get/Let/Set MouseIcon() As IPictureDisp ``` Returns/sets the custom mouse icon. ### MouseTrack ```vb Property Get/Let MouseTrack() As Boolean ``` Returns/sets whether mouse enter/leave tracking is enabled. ### BackColor ```vb Property Get/Let BackColor() As OLE_COLOR ``` Returns/sets the background color of the control. ### BorderStyle ```vb Property Get/Let BorderStyle() As CCBorderStyleConstants ``` Returns/sets the border style of the control. See common enumerations. ### Value ```vb Property Get/Let Value(Optional ByRef Modifiers As Integer) As VBRUN.KeyCodeConstants ``` Returns/sets the key code of the hot key. The Modifiers parameter receives modifier key flags (Shift=1, Ctrl=2, Alt=4). ### RawValue ```vb Property Get/Let RawValue() As Long ``` Returns/sets the raw numeric value of the hot key (low byte is the key code, high byte is the modifier key flags). ### Text ```vb Property Get Text() As String ``` Returns the display text of the hot key. Read-only. ## Methods ### OLEDrag ```vb Public Sub OLEDrag() ``` Initiates an OLE drag operation. ### Drag ```vb Public Sub Drag(Optional ByRef Action As Variant) ``` Starts, ends, or cancels a drag operation. ### SetFocus ```vb Public Sub SetFocus() ``` Moves the focus to the control. ### ZOrder ```vb Public Sub ZOrder(Optional ByRef Position As Variant) ``` Sets the Z-order position of the control within its layer. ### Refresh ```vb Public Sub Refresh() ``` Forces a complete repaint of the control. ### SetRules ```vb Public Sub SetRules(ByVal InvalidKeyCombinations As HkeInvalidKeyCombinationConstants, Optional ByVal DefaultModifiers As VBRUN.ShiftConstants) ``` Sets invalid key combination rules and default modifier keys. InvalidKeyCombinations specifies the modifier key combinations that are not allowed; DefaultModifiers specifies the default modifier key to substitute when the user enters an invalid combination. ### SetApplicationHotKey ```vb Public Function SetApplicationHotKey(Optional ByVal hWnd As LongPtr) As Long ``` Registers the current hot key as the application hot key for a window. The return value is the result of the WM\_SETHOTKEY message. ## Events ### Click ```vb Public Event Click() ``` Occurs when the control is clicked. ### DblClick ```vb Public Event DblClick() ``` Occurs when the control is double-clicked. ### Change ```vb Public Event Change() ``` Occurs when the hot key value changes. ### PreviewKeyDown ```vb Public Event PreviewKeyDown(ByVal KeyCode As Integer, ByRef IsInputKey As Boolean) ``` Occurs before the KeyDown event; IsInputKey can be set to mark whether the key is an input key. ### PreviewKeyUp ```vb Public Event PreviewKeyUp(ByVal KeyCode As Integer, ByRef IsInputKey As Boolean) ``` Occurs before the KeyUp event. ### KeyDown ```vb Public Event KeyDown(KeyCode As Integer, Shift As Integer) ``` Occurs when a keyboard key is pressed. ### KeyUp ```vb Public Event KeyUp(KeyCode As Integer, Shift As Integer) ``` Occurs when a keyboard key is released. ### KeyPress ```vb Public Event KeyPress(KeyChar As Integer) ``` Occurs when a character key is pressed and released. ### MouseDown ```vb Public Event MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` Occurs when a mouse button is pressed. ### MouseMove ```vb Public Event MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` Occurs when the mouse is moved. ### MouseUp ```vb Public Event MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` Occurs when a mouse button is released. ### MouseEnter ```vb Public Event MouseEnter() ``` Occurs when the mouse enters the control. ### MouseLeave ```vb Public Event MouseLeave() ``` Occurs when the mouse leaves the control. ### OLECompleteDrag ```vb Public Event OLECompleteDrag(Effect As Long) ``` Occurs on the source control after an OLE drag-and-drop operation has been completed or canceled. ### OLEDragDrop ```vb Public Event OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single) ``` Occurs when data is dropped onto the control via an OLE drag-and-drop operation. ### OLEDragOver ```vb Public Event OLEDragOver(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single, State As Integer) ``` Occurs when the mouse moves over the control during an OLE drag-and-drop operation. ### OLEGiveFeedback ```vb Public Event OLEGiveFeedback(Effect As Long, DefaultCursors As Boolean) ``` Occurs on the source control when the mouse cursor needs to be changed during an OLE drag-and-drop operation. ### OLESetData ```vb Public Event OLESetData(Data As DataObject, DataFormat As Integer) ``` Occurs on the source control when the drop target requests data. ### OLEStartDrag ```vb Public Event OLEStartDrag(Data As DataObject, AllowedEffects As Long) ``` Occurs when an OLE drag-and-drop operation is initiated. ## Code Examples ### Basic Usage ```vb Private Sub Form_Load() With HotKey1 .SetRules HkeInvalidKeyCombinationNone Or _ HkeInvalidKeyCombinationShift, vbCtrlMask .VisualStyles = True End With End Sub Private Sub HotKey1_Change() Dim Modifiers As Integer Dim KeyCode As VBRUN.KeyCodeConstants KeyCode = HotKey1.Value(Modifiers) Debug.Print "Hot key: " & HotKey1.Text Debug.Print "Raw value: " & HotKey1.RawValue End Sub Private Sub cmdRegisterHotKey_Click() Dim Result As Long Result = HotKey1.SetApplicationHotKey(Me.hWnd) If Result = 1 Then Debug.Print "Hot key registered successfully" Else Debug.Print "Hot key registration failed" End If End Sub ``` --- --- url: /en/packages/vbccr/lists/imagecombo.md description: >- ImageCombo Control - VBCCR Development Manual, complete API reference based on source code --- # ImageCombo Control Provides an enhanced combo box control with icon support, where each item can be associated with an icon from an image list. ## Enumerations ### ImcStyleConstants | Constant | Value | Description | |----------|-------|-------------| | ImcStyleDropDownCombo | 0 | Drop-down combo box (editable) | | ImcStyleSimpleCombo | 1 | Simple combo box (list always visible) | | ImcStyleDropDownList | 2 | Drop-down list (selection only) | ### ImcEndEditReasonConstants | Constant | Value | Description | |----------|-------|-------------| | ImcEndEditReasonLostFocus | 1 | End edit reason: lost focus | | ImcEndEditReasonReturn | 2 | End edit reason: Enter key pressed | | ImcEndEditReasonEscape | 3 | End edit reason: Escape key pressed | | ImcEndEditReasonDropDown | 4 | End edit reason: drop-down selection | ### ImcEllipsisFormatConstants | Constant | Value | Description | |----------|-------|-------------| | ImcEllipsisFormatNone | 0 | No ellipsis | | ImcEllipsisFormatEnd | 1 | Ellipsis at the end of text | ## ImcComboItem Object Represents an item in the image combo box. ### ImcComboItem Properties #### Index ```vb Property Get Index() As Long ``` Returns the index of the item in the collection. Read-only. #### Key ```vb Property Get/Let Key() As String ``` Returns/sets the key of the item. #### Tag ```vb Property Get/Let/Set Tag() As Variant ``` Returns/sets the extra data of the item. #### Text ```vb Property Get/Let Text() As String ``` Returns/sets the text of the item. #### Image ```vb Property Get/Let Image() As Variant ``` Returns/sets the associated image index or key of the item. #### ImageIndex ```vb Property Get ImageIndex() As Long ``` Returns the associated image index of the item. Read-only. #### SelImage ```vb Property Get/Let SelImage() As Variant ``` Returns/sets the associated image index or key when the item is selected. #### SelImageIndex ```vb Property Get SelImageIndex() As Long ``` Returns the associated image index when the item is selected. Read-only. #### Indentation ```vb Property Get/Let Indentation() As Long ``` Returns/sets the indentation level of the item (in icon width units). #### Selected ```vb Property Get/Let Selected() As Boolean ``` Returns/sets whether the item is selected. #### Data ```vb Property Get/Let Data() As LongPtr ``` Returns/sets the extra numeric data of the item. ## ImcComboItems Collection Represents the collection of all items in the image combo box. ### ImcComboItems Properties and Methods #### NewEnum ```vb Public Function NewEnum() As IEnumVARIANT ``` Returns an enumerator, supporting For Each syntax. #### Add ```vb Public Function Add(Optional ByVal Index As Long, Optional ByVal Key As String, Optional ByVal Text As String, Optional ByVal Image As Variant, Optional ByVal SelImage As Variant, Optional ByVal Indentation As Variant) As ImcComboItem ``` Adds an item to the collection and returns the newly created ImcComboItem object. #### Item ```vb Public Property Get Item(ByVal Index As Variant) As ImcComboItem ``` Returns an item by index or key. #### Exists ```vb Public Function Exists(ByVal Index As Variant) As Boolean ``` Checks whether an item with the specified index or key exists. #### Count ```vb Public Property Get Count() As Long ``` Returns the number of items in the collection. #### Clear ```vb Public Sub Clear() ``` Removes all items from the collection. #### Remove ```vb Public Sub Remove(ByVal Index As Variant) ``` Removes an item by index or key. ## Properties ### ControlsEnum ```vb Property Get ControlsEnum() As VBRUN.ParentControls ``` Returns the parent controls enumerator. ### Name ```vb Property Get Name() As String ``` Returns the name of the control. ### Tag ```vb Property Get/Let Tag() As String ``` Returns/sets the tag value of the control. ### Parent ```vb Property Get Parent() As Object ``` Returns the parent object of the control. ### Container ```vb Property Get/Set Container() As Object ``` Returns/sets the container of the control. ### Left ```vb Property Get/Let Left() As Single ``` Returns/sets the position of the left edge of the control. ### Top ```vb Property Get/Let Top() As Single ``` Returns/sets the position of the top edge of the control. ### Width ```vb Property Get/Let Width() As Single ``` Returns/sets the width of the control. ### Height ```vb Property Get/Let Height() As Single ``` Returns/sets the height of the control. ### Visible ```vb Property Get/Let Visible() As Boolean ``` Returns/sets whether the control is visible. ### ToolTipText ```vb Property Get/Let ToolTipText() As String ``` Returns/sets the tooltip text of the control. ### HelpContextID ```vb Property Get/Let HelpContextID() As Long ``` Returns/sets the help context ID of the control. ### WhatsThisHelpID ```vb Property Get/Let WhatsThisHelpID() As Long ``` Returns/sets the "What's This" help ID of the control. ### DragIcon ```vb Property Get/Let/Set DragIcon() As IPictureDisp ``` Returns/sets the icon displayed during drag operations. ### DragMode ```vb Property Get/Let DragMode() As Integer ``` Returns/sets the drag mode (manual or automatic). ### hWnd ```vb Property Get hWnd() As LongPtr ``` Returns the window handle of the image combo box. ### hWndUserControl ```vb Property Get hWndUserControl() As LongPtr ``` Returns the window handle of the UserControl. ### hWndCombo ```vb Property Get hWndCombo() As LongPtr ``` Returns the window handle of the ComboBoxEx control. ### hWndEdit ```vb Property Get hWndEdit() As LongPtr ``` Returns the window handle of the edit box portion. ### hWndList ```vb Property Get hWndList() As LongPtr ``` Returns the window handle of the list portion. ### Font ```vb Property Get/Let/Set Font() As StdFont ``` Returns/sets the font used by the control. ### VisualStyles ```vb Property Get/Let VisualStyles() As Boolean ``` Returns/sets whether visual styles are enabled. ### Enabled ```vb Property Get/Let Enabled() As Boolean ``` Returns/sets whether the control is enabled. ### OLEDragMode ```vb Property Get/Let OLEDragMode() As VBRUN.OLEDragConstants ``` Returns/sets the OLE drag mode. ### OLEDropMode ```vb Property Get/Let OLEDropMode() As OLEDropModeConstants ``` Returns/sets the OLE drop mode. See common enumerations. ### MousePointer ```vb Property Get/Let MousePointer() As CCMousePointerConstants ``` Returns/sets the mouse pointer type. See common enumerations. ### MouseIcon ```vb Property Get/Let/Set MouseIcon() As IPictureDisp ``` Returns/sets the custom mouse icon. ### MouseTrack ```vb Property Get/Let MouseTrack() As Boolean ``` Returns/sets whether mouse enter/leave tracking is enabled. ### RightToLeft ```vb Property Get/Let RightToLeft() As Boolean ``` Returns/sets whether right-to-left layout is enabled. ### RightToLeftLayout ```vb Property Get/Let RightToLeftLayout() As Boolean ``` Returns/sets whether right-to-left layout mirroring is enabled. ### RightToLeftMode ```vb Property Get/Let RightToLeftMode() As CCRightToLeftModeConstants ``` Returns/sets the right-to-left mode. See common enumerations. ### ImageList ```vb Property Get/Set/Let ImageList() As Variant ``` Returns/sets the associated ImageList control used to provide item icons. ### Style ```vb Property Get/Let Style() As ImcStyleConstants ``` Returns/sets the combo box style. ### Locked ```vb Property Get/Let Locked() As Boolean ``` Returns/sets whether the control is locked (prevents editing and selection). ### Text ```vb Property Get/Let Text() As String ``` Returns/sets the text in the edit box. ### Default ```vb Property Get/Let Default() As String ``` Returns/sets the default value. ### Indentation ```vb Property Get/Let Indentation() As Long ``` Returns/sets the default indentation level for new items. ### ExtendedUI ```vb Property Get/Let ExtendedUI() As Boolean ``` Returns/sets whether extended user interface is used. ### MaxDropDownItems ```vb Property Get/Let MaxDropDownItems() As Integer ``` Returns/sets the maximum number of visible items in the drop-down list. ### ShowImages ```vb Property Get/Let ShowImages() As Boolean ``` Returns/sets whether item icons are displayed. ### MaxLength ```vb Property Get/Let MaxLength() As Long ``` Returns/sets the maximum number of characters that can be entered in the edit box. ### IMEMode ```vb Property Get/Let IMEMode() As CCIMEModeConstants ``` Returns/sets the input method editor mode. See common enumerations. ### EllipsisFormat ```vb Property Get/Let EllipsisFormat() As ImcEllipsisFormatConstants ``` Returns/sets the ellipsis format when text exceeds the width. ### ScrollTrack ```vb Property Get/Let ScrollTrack() As Boolean ``` Returns/sets whether the scroll bar tracks in real time. ### ComboItems ```vb Property Get ComboItems() As ImcComboItems ``` Returns the combo box items collection. Read-only. ### SelStart ```vb Property Get/Let SelStart() As Long ``` Returns/sets the starting position of the selected text. ### SelLength ```vb Property Get/Let SelLength() As Long ``` Returns/sets the length of the selected text. ### SelText ```vb Property Get/Let SelText() As String ``` Returns/sets the currently selected text. ### TopItem ```vb Property Get/Set TopItem() As ImcComboItem ``` Returns/sets the top visible item in the list. ### SelectedItem ```vb Property Get/Set SelectedItem() As ImcComboItem ``` Returns/sets the currently selected item. ### DroppedDown ```vb Property Get/Let DroppedDown() As Boolean ``` Returns/sets whether the drop-down list is expanded. ### DropDownWidth ```vb Property Get/Let DropDownWidth() As Single ``` Returns/sets the width of the drop-down list. Not supported in simple style. ### OLEDraggedItem ```vb Property Get OLEDraggedItem() As ImcComboItem ``` Returns the item currently being dragged in an OLE drag-drop operation. Read-only. ## Methods ### OLEDrag ```vb Public Sub OLEDrag() ``` Initiates an OLE drag operation. ### Drag ```vb Public Sub Drag(Optional ByRef Action As Variant) ``` Starts, ends, or cancels a drag operation. ### SetFocus ```vb Public Sub SetFocus() ``` Moves focus to this control. ### ZOrder ```vb Public Sub ZOrder(Optional ByRef Position As Variant) ``` Sets the control's Z-order position within its layer. ### Refresh ```vb Public Sub Refresh() ``` Forces a complete redraw of the control. ### GetItemHeight ```vb Public Function GetItemHeight() As Single ``` Returns the height of list items (taking icon height into account). ### FindItem ```vb Public Function FindItem(ByVal Text As String, Optional ByVal Index As Long, Optional ByVal Partial As Boolean, Optional ByVal Wrap As Boolean) As ImcComboItem ``` Finds an item in the list and returns a reference to it. When Partial is True, performs partial matching; when Wrap is True, continues searching from the beginning. ## Events ### Click ```vb Public Event Click() ``` Occurs when the control is clicked. ### DblClick ```vb Public Event DblClick() ``` Occurs when the control is double-clicked. ### Scroll ```vb Public Event Scroll() ``` Occurs when the list is scrolled. ### Change ```vb Public Event Change() ``` Occurs when the control content changes. ### DropDown ```vb Public Event DropDown() ``` Occurs when the drop-down list is about to expand. ### CloseUp ```vb Public Event CloseUp() ``` Occurs when the drop-down list closes. ### ItemDrag ```vb Public Event ItemDrag(ByVal Item As ImcComboItem, ByVal Button As Integer) ``` Occurs when an item initiates a drag-drop operation. ### BeginEdit ```vb Public Event BeginEdit() ``` Occurs when the user activates the drop-down list or clicks the edit box. ### EndEdit ```vb Public Event EndEdit(ByVal Changed As Boolean, ByVal NewIndex As Long, ByVal NewText As String, ByVal Reason As ImcEndEditReasonConstants) ``` Occurs when an edit operation ends. Changed indicates whether the text changed, NewIndex is the index of the newly selected item, NewText is the new text, and Reason is the end reason. ### PreviewKeyDown ```vb Public Event PreviewKeyDown(ByVal KeyCode As Integer, ByRef IsInputKey As Boolean) ``` Occurs before the KeyDown event. Set IsInputKey to mark whether the key is an input key. ### PreviewKeyUp ```vb Public Event PreviewKeyUp(ByVal KeyCode As Integer, ByRef IsInputKey As Boolean) ``` Occurs before the KeyUp event. ### KeyDown ```vb Public Event KeyDown(KeyCode As Integer, Shift As Integer) ``` Occurs when a keyboard key is pressed. ### KeyUp ```vb Public Event KeyUp(KeyCode As Integer, Shift As Integer) ``` Occurs when a keyboard key is released. ### KeyPress ```vb Public Event KeyPress(KeyChar As Integer) ``` Occurs when a character key is pressed and released. ### MouseDown ```vb Public Event MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` Occurs when a mouse button is pressed. ### MouseMove ```vb Public Event MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` Occurs when the mouse is moved. ### MouseUp ```vb Public Event MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` Occurs when a mouse button is released. ### MouseEnter ```vb Public Event MouseEnter() ``` Occurs when the mouse enters the control. ### MouseLeave ```vb Public Event MouseLeave() ``` Occurs when the mouse leaves the control. ### OLECompleteDrag ```vb Public Event OLECompleteDrag(Effect As Long) ``` Occurs on the source control after an OLE drag-drop operation is completed or canceled. ### OLEDragDrop ```vb Public Event OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single) ``` Occurs when data is dropped onto the control via an OLE drag-drop operation. ### OLEDragOver ```vb Public Event OLEDragOver(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single, State As Integer) ``` Occurs when the mouse passes over the control during an OLE drag-drop operation. ### OLEGiveFeedback ```vb Public Event OLEGiveFeedback(Effect As Long, DefaultCursors As Boolean) ``` Occurs on the source control when the mouse cursor needs to change during an OLE drag-drop operation. ### OLESetData ```vb Public Event OLESetData(Data As DataObject, DataFormat As Integer) ``` Occurs on the source control when the drop target requests data. ### OLEStartDrag ```vb Public Event OLEStartDrag(Data As DataObject, AllowedEffects As Long) ``` Occurs when an OLE drag-drop operation is started. ## Code Examples ### Basic Usage ```vb Private Sub Form_Load() Set ImageCombo1.ImageList = ImageList1 With ImageCombo1 .Style = ImcStyleDropDownCombo .ShowImages = True .MaxDropDownItems = 10 End With Dim Item As ImcComboItem Set Item = ImageCombo1.ComboItems.Add(, "k1", "Item One", 1, 2) Set Item = ImageCombo1.ComboItems.Add(, "k2", "Item Two", 1, 2) Set Item = ImageCombo1.ComboItems.Add(, "k3", "Sub Item", 3, 4) Item.Indentation = 1 End Sub Private Sub ImageCombo1_Click() If Not ImageCombo1.SelectedItem Is Nothing Then Debug.Print "Selected: " & ImageCombo1.SelectedItem.Text End If End Sub Private Sub ImageCombo1_EndEdit(ByVal Changed As Boolean, ByVal NewIndex As Long, ByVal NewText As String, ByVal Reason As ImcEndEditReasonConstants) If Changed Then Debug.Print "Edit completed: " & NewText End If End Sub ``` --- --- url: /en/packages/vbccr/system/imagelist.md description: >- ImageList Control - VBCCR Development Manual, Complete API Reference Based on Source Code --- # ImageList Control Wraps the ImageList control, used to store and manage image collections for reference by other controls. ## Enumerations ### ImlImageSizeConstants | Constant | Value | Description | |------|-----|------| | imlSmall | 0 | Small icons (16×16) | | imlLarge | 1 | Large icons (32×32) | | imlCustom | 2 | Custom size | ### CCBackStyleConstants See Common Enumerations. ## Properties ### ImageWidth ```vb Property Get ImageWidth() As Long Property Let ImageWidth(ByVal Value As Long) ``` Image width (pixels). ### ImageHeight ```vb Property Get ImageHeight() As Long Property Let ImageHeight(ByVal Value As Long) ``` Image height (pixels). ### ImageSize ```vb Property Get ImageSize() As ImlImageSizeConstants Property Let ImageSize(ByVal Value As ImlImageSizeConstants) ``` Preset image size. Setting this property automatically adjusts ImageWidth and ImageHeight. ### ColorDepth ```vb Property Get ColorDepth() As Long Property Let ColorDepth(ByVal Value As Long) ``` Color depth. Supports 4, 8, 16, 24, 32 bits. Requires comctl32.dll 6.0 or later. ### MaskColor ```vb Property Get MaskColor() As OLE_COLOR Property Let MaskColor(ByVal Value As OLE_COLOR) ``` Mask color. ### UseMaskColor ```vb Property Get UseMaskColor() As Boolean Property Let UseMaskColor(ByVal Value As Boolean) ``` Whether to use mask color. ### BackColor ```vb Property Get BackColor() As OLE_COLOR Property Let BackColor(ByVal Value As OLE_COLOR) ``` Background color. ### hImageList ```vb Property Get hImageList() As LongPtr ``` Image list handle. Read-only. ### ListImages ```vb Property Get ListImages() As ImlListImages ``` Image collection. ### Name ```vb Property Get Name() As String ``` Control name. Read-only. ### Tag ```vb Property Get Tag() As Variant Property Let Tag(ByVal Value As Variant) Property Set Tag(ByVal Value As Variant) ``` Custom data. ### Parent ```vb Property Get Parent() As Object ``` Parent object. Read-only. ### Container ```vb Property Get Container() As Object Property Set Container(ByVal Value As Object) ``` Container object. ### Left ```vb Property Get Left() As Single Property Let Left(ByVal Value As Single) ``` Left margin. ### Top ```vb Property Get Top() As Single Property Let Top(ByVal Value As Single) ``` Top margin. ### Width ```vb Property Get Width() As Single Property Let Width(ByVal Value As Single) ``` Width (used at design time). ### Height ```vb Property Get Height() As Single Property Let Height(ByVal Value As Single) ``` Height (used at design time). ### Visible ```vb Property Get Visible() As Boolean Property Let Visible(ByVal Value As Boolean) ``` Visibility (used at design time). ### hWnd ```vb Property Get hWnd() As LongPtr ``` Window handle. Read-only. ## Methods ### Refresh ```vb Sub Refresh() ``` Forces a repaint. ### CreateIcon ```vb Function CreateIcon(ByVal ImageIndex As Long) As IPictureDisp ``` Creates an icon from the specified image. ### CreateBitmap ```vb Function CreateBitmap(ByVal ImageIndex As Long) As IPictureDisp ``` Creates a bitmap from the specified image. Requires comctl32.dll 6.0 or later. ### Overlay ```vb Function Overlay(ByVal ImageIndex1 As Long, ByVal ImageIndex2 As Long) As IPictureDisp ``` Overlays two images and returns the resulting image. ### AboutBox ```vb Sub AboutBox() ``` Displays the About dialog. ## Sub-objects ### ListImage (ImlListImage) Represents a single image in the image list. #### Properties | Property | Type | Access | Description | |------|------|------|------| | Index | Long | Read-only | Index in the collection | | Key | String | Read/Write | Key in the collection | | Tag | Variant | Read/Write | Custom data | | Picture | IPictureDisp | Read/Write | Image | | MaskPicture | IPictureDisp | Read/Write | Mask image | | Overlay | Boolean | Read/Write | Whether this is an overlay image | | OverlaySourceIndex | Long | Read/Write | Overlay source index | | ExtractIcon | IPictureDisp | Read-only | Extract icon | | ExtractBitmap | IPictureDisp | Read-only | Extract bitmap | ### ListImages (ImlListImages) Image collection object. #### Properties | Property | Type | Access | Description | |------|------|------|------| | Item(ByVal Index As Variant) | ImlListImage | Read-only | Get image by index or key | | Count | Long | Read-only | Number of images | #### Methods | Method | Description | |------|------| | Add(\[Index], \[Key], \[Picture], \[MaskPicture]) As ImlListImage | Add an image | | Exists(ByVal Index As Variant) As Boolean | Check if an image exists | | Clear | Clear all images | | Remove(ByVal Index As Variant) | Remove the specified image | ## Code Examples ```vb ' Set image size and add images With ImageList1 .ImageSize = imlSmall .ListImages.Add , "open", LoadPicture("open.ico") .ListImages.Add , "save", LoadPicture("save.ico") .ListImages.Add , "exit", LoadPicture("exit.ico") End With ' Reference image by key Set cmdOpen.Picture = ImageList1.ListImages("open").ExtractIcon ' Create overlay image ImageList1.ListImages.Add , "overlay1", LoadPicture("ov1.ico") ImageList1.ListImages("overlay1").Overlay = True ImageList1.ListImages("overlay1").OverlaySourceIndex = 1 ' Use Overlay method to overlay two images Set imgOverlay = ImageList1.Overlay(1, 2) ' Iterate through all images Dim img As ImlListImage For Each img In ImageList1.ListImages Debug.Print img.Index; img.Key Next img ``` --- --- url: /zh/packages/vbccr/lists/ipaddress.md description: IP 地址控件（IPAddress） - VBCCR 开发手册，基于源码的完整 API 参考 --- # IP 地址控件（IPAddress） 封装 SysIPAddress32 系统控件，用于输入和显示 IPv4 地址。 ## 枚举 ### IPATextConstants | 常量 | 值 | 说明 | |------|-----|------| | IPAEmpty | 0 | 空地址 | | IPAInvalid | -1 | 无效地址 | ### IPAFocusConstants | 常量 | 值 | 说明 | |------|-----|------| | IPAFocusField1 | 0 | 第 1 字段 | | IPAFocusField2 | 1 | 第 2 字段 | | IPAFocusField3 | 2 | 第 3 字段 | | IPAFocusField4 | 3 | 第 4 字段 | ### CCAppearanceConstants 参见通用枚举。 ### CCBorderStyleConstants 参见通用枚举。 ### CCMousePointerConstants 参见通用枚举。 ### CCIMEModeConstants 参见通用枚举。 ### CCRightToLeftModeConstants 参见通用枚举。 ### OLEDropModeConstants 参见通用枚举。 ## 属性 ### Text ```vb Property Get Text() As IPATextConstants Property Let Text(ByVal Value As IPATextConstants) ``` IP 地址的数值表示。IPAEmpty（0）表示空地址，IPAInvalid（-1）表示无效地址。 ### Field1 ```vb Property Get Field1() As Byte Property Let Field1(ByVal Value As Byte) ``` 第 1 字段值（0-255）。 ### Field2 ```vb Property Get Field2() As Byte Property Let Field2(ByVal Value As Byte) ``` 第 2 字段值（0-255）。 ### Field3 ```vb Property Get Field3() As Byte Property Let Field3(ByVal Value As Byte) ``` 第 3 字段值（0-255）。 ### Field4 ```vb Property Get Field4() As Byte Property Let Field4(ByVal Value As Byte) ``` 第 4 字段值（0-255）。 ### Field1RangeMin ```vb Property Get Field1RangeMin() As Byte Property Let Field1RangeMin(ByVal Value As Byte) ``` 第 1 字段最小值。默认 0。 ### Field1RangeMax ```vb Property Get Field1RangeMax() As Byte Property Let Field1RangeMax(ByVal Value As Byte) ``` 第 1 字段最大值。默认 255。 ### Field2RangeMin ```vb Property Get Field2RangeMin() As Byte Property Let Field2RangeMin(ByVal Value As Byte) ``` 第 2 字段最小值。默认 0。 ### Field2RangeMax ```vb Property Get Field2RangeMax() As Byte Property Let Field2RangeMax(ByVal Value As Byte) ``` 第 2 字段最大值。默认 255。 ### Field3RangeMin ```vb Property Get Field3RangeMin() As Byte Property Let Field3RangeMin(ByVal Value As Byte) ``` 第 3 字段最小值。默认 0。 ### Field3RangeMax ```vb Property Get Field3RangeMax() As Byte Property Let Field3RangeMax(ByVal Value As Byte) ``` 第 3 字段最大值。默认 255。 ### Field4RangeMin ```vb Property Get Field4RangeMin() As Byte Property Let Field4RangeMin(ByVal Value As Byte) ``` 第 4 字段最小值。默认 0。 ### Field4RangeMax ```vb Property Get Field4RangeMax() As Byte Property Let Field4RangeMax(ByVal Value As Byte) ``` 第 4 字段最大值。默认 255。 ### FocusField ```vb Property Get FocusField() As IPAFocusConstants Property Let FocusField(ByVal Value As IPAFocusConstants) ``` 当前焦点字段。 ### BorderStyle ```vb Property Get BorderStyle() As CCBorderStyleConstants Property Let BorderStyle(ByVal Value As CCBorderStyleConstants) ``` 边框样式。参见通用枚举。 ### Font ```vb Property Get Font() As StdFont Property Let Font(ByVal NewFont As StdFont) Property Set Font(ByVal NewFont As StdFont) ``` 字体。 ### Enabled ```vb Property Get Enabled() As Boolean Property Let Enabled(ByVal Value As Boolean) ``` 是否可用。 ### BackColor ```vb Property Get BackColor() As OLE_COLOR Property Let BackColor(ByVal Value As OLE_COLOR) ``` 背景颜色。 ### ForeColor ```vb Property Get ForeColor() As OLE_COLOR Property Let ForeColor(ByVal Value As OLE_COLOR) ``` 前景颜色。 ### MousePointer ```vb Property Get MousePointer() As CCMousePointerConstants Property Let MousePointer(ByVal Value As CCMousePointerConstants) ``` 鼠标指针样式。参见通用枚举。 ### MouseIcon ```vb Property Get MouseIcon() As IPictureDisp Property Let MouseIcon(ByVal Value As IPictureDisp) Property Set MouseIcon(ByVal Value As IPictureDisp) ``` 自定义鼠标图标。 ### MouseTrack ```vb Property Get MouseTrack() As Boolean Property Let MouseTrack(ByVal Value As Boolean) ``` 是否启用鼠标进入/离开跟踪。 ### RightToLeft ```vb Property Get RightToLeft() As Boolean Property Let RightToLeft(ByVal Value As Boolean) ``` 从右到左显示方向。 ### RightToLeftLayout ```vb Property Get RightToLeftLayout() As Boolean Property Let RightToLeftLayout(ByVal Value As Boolean) ``` 从右到左镜像布局。 ### RightToLeftMode ```vb Property Get RightToLeftMode() As CCRightToLeftModeConstants Property Let RightToLeftMode(ByVal Value As CCRightToLeftModeConstants) ``` 从右到左模式。参见通用枚举。 ### IMEMode ```vb Property Get IMEMode() As CCIMEModeConstants Property Let IMEMode(ByVal Value As CCIMEModeConstants) ``` 输入法编辑器模式。参见通用枚举。 ### OLEDropMode ```vb Property Get OLEDropMode() As OLEDropModeConstants Property Let OLEDropMode(ByVal Value As OLEDropModeConstants) ``` OLE 拖放模式。参见通用枚举。 ### Appearance ```vb Property Get Appearance() As CCAppearanceConstants Property Let Appearance(ByVal Value As CCAppearanceConstants) ``` 外观样式。参见通用枚举。 ### hWnd ```vb Property Get hWnd() As LongPtr ``` IP 地址控件的窗口句柄。只读。 ### ToolTipText ```vb Property Get ToolTipText() As String Property Let ToolTipText(ByVal Value As String) ``` 工具提示文本。 ### hWndUserControl ```vb Property Get hWndUserControl() As LongPtr ``` 用户控件的窗口句柄。只读。 ### Name ```vb Property Get Name() As String ``` 控件名称。只读。 ### Tag ```vb Property Get Tag() As Variant Property Let Tag(ByVal Value As Variant) Property Set Tag(ByVal Value As Variant) ``` 自定义数据。 ### Parent ```vb Property Get Parent() As Object ``` 父对象。只读。 ### Container ```vb Property Get Container() As Object Property Set Container(ByVal Value As Object) ``` 容器对象。 ### Left ```vb Property Get Left() As Single Property Let Left(ByVal Value As Single) ``` 左边距。 ### Top ```vb Property Get Top() As Single Property Let Top(ByVal Value As Single) ``` 顶边距。 ### Width ```vb Property Get Width() As Single Property Let Width(ByVal Value As Single) ``` 宽度（设计时使用）。 ### Height ```vb Property Get Height() As Single Property Let Height(ByVal Value As Single) ``` 高度（设计时使用）。 ### Visible ```vb Property Get Visible() As Boolean Property Let Visible(ByVal Value As Boolean) ``` 可见性。 ## 方法 ### Refresh ```vb Sub Refresh() ``` 强制重绘。 ### Clear ```vb Sub Clear() ``` 清除 IP 地址，将所有字段设为空。 ### SetFocusField ```vb Sub SetFocusField(ByVal FocusField As IPAFocusConstants) ``` 设置焦点到指定字段。 ### AboutBox ```vb Sub AboutBox() ``` 显示关于对话框。 ## 事件 ### Change ```vb Event Change() ``` IP 地址改变时触发。 ### FieldChange ```vb Event FieldChange(ByVal Field As Integer) ``` 指定字段改变时触发。 ### KeyDown ```vb Event KeyDown(KeyCode As Integer, Shift As Integer) ``` 按键按下时触发。 ### KeyUp ```vb Event KeyUp(KeyCode As Integer, Shift As Integer) ``` 按键释放时触发。 ### KeyPress ```vb Event KeyPress(KeyChar As Integer) ``` 按键输入时触发。 ### Click ```vb Event Click() ``` 单击时触发。 ### DblClick ```vb Event DblClick() ``` 双击时触发。 ### MouseDown ```vb Event MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) ``` 鼠标按下时触发。 ### MouseUp ```vb Event MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) ``` 鼠标释放时触发。 ### MouseMove ```vb Event MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) ``` 鼠标移动时触发。 ### MouseEnter ```vb Event MouseEnter() ``` 鼠标进入控件时触发。 ### MouseLeave ```vb Event MouseLeave() ``` 鼠标离开控件时触发。 ### OLEStartDrag ```vb Event OLEStartDrag(Data As DataObject, AllowedEffects As Long) ``` OLE 拖拽开始时触发。 ### OLEGiveFeedback ```vb Event OLEGiveFeedback(Effect As Long, DefaultCursors As Boolean) ``` OLE 拖拽反馈。 ### OLESetData ```vb Event OLESetData(Data As DataObject, DataFormat As Integer) ``` OLE 设置数据。 ### OLECompleteDrag ```vb Event OLECompleteDrag(Effect As Long) ``` OLE 拖拽完成。 ### OLEDragOver ```vb Event OLEDragOver(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single, State As Integer) ``` OLE 拖拽经过时触发。 ### OLEDragDrop ```vb Event OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single) ``` OLE 拖放时触发。 ## 代码示例 ```vb ' 设置 IP 地址（数值形式） IPAddress1.Text = &H0100007F ' 127.0.0.1 ' 逐字段设置 IPAddress1.Field1 = 192 IPAddress1.Field2 = 168 IPAddress1.Field3 = 1 IPAddress1.Field4 = 100 ' 读取 IP 地址 If IPAddress1.Text <> IPAEmpty Then MsgBox "IP: " & IPAddress1.Field1 & "." & IPAddress1.Field2 & "." & _ IPAddress1.Field3 & "." & IPAddress1.Field4 End If ' 设置字段范围限制 IPAddress1.Field1RangeMin = 10 IPAddress1.Field1RangeMax = 192 ' 监听变化 Private Sub IPAddress1_FieldChange(ByVal Field As Integer) Debug.Print "字段 " & Field & " 已更改" End Sub ``` --- --- url: /en/packages/vbccr/lists/ipaddress.md description: >- IPAddress Control - VBCCR Development Manual, complete API reference based on source code --- # IPAddress Control Wraps the SysIPAddress32 system control for entering and displaying IPv4 addresses. ## Enumerations ### IPATextConstants | Constant | Value | Description | |----------|-------|-------------| | IPAEmpty | 0 | Empty address | | IPAInvalid | -1 | Invalid address | ### IPAFocusConstants | Constant | Value | Description | |----------|-------|-------------| | IPAFocusField1 | 0 | Field 1 | | IPAFocusField2 | 1 | Field 2 | | IPAFocusField3 | 2 | Field 3 | | IPAFocusField4 | 3 | Field 4 | ### CCAppearanceConstants See common enumerations. ### CCBorderStyleConstants See common enumerations. ### CCMousePointerConstants See common enumerations. ### CCIMEModeConstants See common enumerations. ### CCRightToLeftModeConstants See common enumerations. ### OLEDropModeConstants See common enumerations. ## Properties ### Text ```vb Property Get Text() As IPATextConstants Property Let Text(ByVal Value As IPATextConstants) ``` Numeric representation of the IP address. IPAEmpty (0) indicates an empty address, IPAInvalid (-1) indicates an invalid address. ### Field1 ```vb Property Get Field1() As Byte Property Let Field1(ByVal Value As Byte) ``` Field 1 value (0-255). ### Field2 ```vb Property Get Field2() As Byte Property Let Field2(ByVal Value As Byte) ``` Field 2 value (0-255). ### Field3 ```vb Property Get Field3() As Byte Property Let Field3(ByVal Value As Byte) ``` Field 3 value (0-255). ### Field4 ```vb Property Get Field4() As Byte Property Let Field4(ByVal Value As Byte) ``` Field 4 value (0-255). ### Field1RangeMin ```vb Property Get Field1RangeMin() As Byte Property Let Field1RangeMin(ByVal Value As Byte) ``` Minimum value for field 1. Default is 0. ### Field1RangeMax ```vb Property Get Field1RangeMax() As Byte Property Let Field1RangeMax(ByVal Value As Byte) ``` Maximum value for field 1. Default is 255. ### Field2RangeMin ```vb Property Get Field2RangeMin() As Byte Property Let Field2RangeMin(ByVal Value As Byte) ``` Minimum value for field 2. Default is 0. ### Field2RangeMax ```vb Property Get Field2RangeMax() As Byte Property Let Field2RangeMax(ByVal Value As Byte) ``` Maximum value for field 2. Default is 255. ### Field3RangeMin ```vb Property Get Field3RangeMin() As Byte Property Let Field3RangeMin(ByVal Value As Byte) ``` Minimum value for field 3. Default is 0. ### Field3RangeMax ```vb Property Get Field3RangeMax() As Byte Property Let Field3RangeMax(ByVal Value As Byte) ``` Maximum value for field 3. Default is 255. ### Field4RangeMin ```vb Property Get Field4RangeMin() As Byte Property Let Field4RangeMin(ByVal Value As Byte) ``` Minimum value for field 4. Default is 0. ### Field4RangeMax ```vb Property Get Field4RangeMax() As Byte Property Let Field4RangeMax(ByVal Value As Byte) ``` Maximum value for field 4. Default is 255. ### FocusField ```vb Property Get FocusField() As IPAFocusConstants Property Let FocusField(ByVal Value As IPAFocusConstants) ``` Current focus field. ### BorderStyle ```vb Property Get BorderStyle() As CCBorderStyleConstants Property Let BorderStyle(ByVal Value As CCBorderStyleConstants) ``` Border style. See common enumerations. ### Font ```vb Property Get Font() As StdFont Property Let Font(ByVal NewFont As StdFont) Property Set Font(ByVal NewFont As StdFont) ``` Font. ### Enabled ```vb Property Get Enabled() As Boolean Property Let Enabled(ByVal Value As Boolean) ``` Whether the control is enabled. ### BackColor ```vb Property Get BackColor() As OLE_COLOR Property Let BackColor(ByVal Value As OLE_COLOR) ``` Background color. ### ForeColor ```vb Property Get ForeColor() As OLE_COLOR Property Let ForeColor(ByVal Value As OLE_COLOR) ``` Foreground color. ### MousePointer ```vb Property Get MousePointer() As CCMousePointerConstants Property Let MousePointer(ByVal Value As CCMousePointerConstants) ``` Mouse pointer style. See common enumerations. ### MouseIcon ```vb Property Get MouseIcon() As IPictureDisp Property Let MouseIcon(ByVal Value As IPictureDisp) Property Set MouseIcon(ByVal Value As IPictureDisp) ``` Custom mouse icon. ### MouseTrack ```vb Property Get MouseTrack() As Boolean Property Let MouseTrack(ByVal Value As Boolean) ``` Whether to enable mouse enter/leave tracking. ### RightToLeft ```vb Property Get RightToLeft() As Boolean Property Let RightToLeft(ByVal Value As Boolean) ``` Right-to-left display direction. ### RightToLeftLayout ```vb Property Get RightToLeftLayout() As Boolean Property Let RightToLeftLayout(ByVal Value As Boolean) ``` Right-to-left mirrored layout. ### RightToLeftMode ```vb Property Get RightToLeftMode() As CCRightToLeftModeConstants Property Let RightToLeftMode(ByVal Value As CCRightToLeftModeConstants) ``` Right-to-left mode. See common enumerations. ### IMEMode ```vb Property Get IMEMode() As CCIMEModeConstants Property Let IMEMode(ByVal Value As CCIMEModeConstants) ``` Input method editor mode. See common enumerations. ### OLEDropMode ```vb Property Get OLEDropMode() As OLEDropModeConstants Property Let OLEDropMode(ByVal Value As OLEDropModeConstants) ``` OLE drag-drop mode. See common enumerations. ### Appearance ```vb Property Get Appearance() As CCAppearanceConstants Property Let Appearance(ByVal Value As CCAppearanceConstants) ``` Appearance style. See common enumerations. ### hWnd ```vb Property Get hWnd() As LongPtr ``` Window handle of the IP address control. Read-only. ### ToolTipText ```vb Property Get ToolTipText() As String Property Let ToolTipText(ByVal Value As String) ``` Tooltip text. ### hWndUserControl ```vb Property Get hWndUserControl() As LongPtr ``` Window handle of the UserControl. Read-only. ### Name ```vb Property Get Name() As String ``` Control name. Read-only. ### Tag ```vb Property Get Tag() As Variant Property Let Tag(ByVal Value As Variant) Property Set Tag(ByVal Value As Variant) ``` Custom data. ### Parent ```vb Property Get Parent() As Object ``` Parent object. Read-only. ### Container ```vb Property Get Container() As Object Property Set Container(ByVal Value As Object) ``` Container object. ### Left ```vb Property Get Left() As Single Property Let Left(ByVal Value As Single) ``` Left position. ### Top ```vb Property Get Top() As Single Property Let Top(ByVal Value As Single) ``` Top position. ### Width ```vb Property Get Width() As Single Property Let Width(ByVal Value As Single) ``` Width (used at design time). ### Height ```vb Property Get Height() As Single Property Let Height(ByVal Value As Single) ``` Height (used at design time). ### Visible ```vb Property Get Visible() As Boolean Property Let Visible(ByVal Value As Boolean) ``` Visibility. ## Methods ### Refresh ```vb Sub Refresh() ``` Forces a redraw. ### Clear ```vb Sub Clear() ``` Clears the IP address, setting all fields to empty. ### SetFocusField ```vb Sub SetFocusField(ByVal FocusField As IPAFocusConstants) ``` Sets focus to the specified field. ### AboutBox ```vb Sub AboutBox() ``` Displays the About dialog. ## Events ### Change ```vb Event Change() ``` Fired when the IP address changes. ### FieldChange ```vb Event FieldChange(ByVal Field As Integer) ``` Fired when a specific field changes. ### KeyDown ```vb Event KeyDown(KeyCode As Integer, Shift As Integer) ``` Fired when a key is pressed. ### KeyUp ```vb Event KeyUp(KeyCode As Integer, Shift As Integer) ``` Fired when a key is released. ### KeyPress ```vb Event KeyPress(KeyChar As Integer) ``` Fired on key input. ### Click ```vb Event Click() ``` Fired on click. ### DblClick ```vb Event DblClick() ``` Fired on double-click. ### MouseDown ```vb Event MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) ``` Fired when a mouse button is pressed. ### MouseUp ```vb Event MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) ``` Fired when a mouse button is released. ### MouseMove ```vb Event MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) ``` Fired when the mouse is moved. ### MouseEnter ```vb Event MouseEnter() ``` Fired when the mouse enters the control. ### MouseLeave ```vb Event MouseLeave() ``` Fired when the mouse leaves the control. ### OLEStartDrag ```vb Event OLEStartDrag(Data As DataObject, AllowedEffects As Long) ``` Fired when an OLE drag starts. ### OLEGiveFeedback ```vb Event OLEGiveFeedback(Effect As Long, DefaultCursors As Boolean) ``` OLE drag feedback. ### OLESetData ```vb Event OLESetData(Data As DataObject, DataFormat As Integer) ``` OLE set data. ### OLECompleteDrag ```vb Event OLECompleteDrag(Effect As Long) ``` OLE drag completed. ### OLEDragOver ```vb Event OLEDragOver(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single, State As Integer) ``` Fired when an OLE drag passes over. ### OLEDragDrop ```vb Event OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single) ``` Fired on OLE drag-drop. ## Code Examples ```vb ' Set IP address (numeric form) IPAddress1.Text = &H0100007F ' 127.0.0.1 ' Set field by field IPAddress1.Field1 = 192 IPAddress1.Field2 = 168 IPAddress1.Field3 = 1 IPAddress1.Field4 = 100 ' Read IP address If IPAddress1.Text <> IPAEmpty Then MsgBox "IP: " & IPAddress1.Field1 & "." & IPAddress1.Field2 & "." & _ IPAddress1.Field3 & "." & IPAddress1.Field4 End If ' Set field range limits IPAddress1.Field1RangeMin = 10 IPAddress1.Field1RangeMax = 192 ' Listen for changes Private Sub IPAddress1_FieldChange(ByVal Field As Integer) Debug.Print "Field " & Field & " changed" End Sub ``` --- --- url: /en/packages/vbccr/text/labelw.md description: >- LabelW Control - VBCCR Development Manual, complete API reference based on source code --- # LabelW Control Enhanced Unicode label control, replacing the standard VB6 Label control, providing text effects, border effects, mouse tracking, and other enhanced features. ## Enumerations ### LblTextEffectsConstants | Constant | Value | Description | |----------|-------|-------------| | LblTextEffectNone | 0 | No effect | | LblTextEffectShadow | 1 | Shadow | | LblTextEffectEmboss | 2 | Emboss | | LblTextEffectEngrave | 3 | Engrave | ### LblBorderEffectsConstants | Constant | Value | Description | |----------|-------|-------------| | LblBorderEffectNone | 0 | No border effect | | LblBorderEffectSoftEdge | 1 | Soft edge | | LblBorderEffectEtched | 2 | Etched | ### CCBackStyleConstants See common enumerations. ### CCAppearanceConstants See common enumerations. ### CCBorderStyleConstants See common enumerations. ### CCMousePointerConstants See common enumerations. ### CCVerticalAlignmentConstants See common enumerations. ### CCRightToLeftModeConstants See common enumerations. ## Properties ### Alignment ```vb Property Get Alignment() As Long Property Let Alignment(ByVal Value As Long) ``` Text alignment. 0 = Left-aligned, 1 = Right-aligned, 2 = Centered. ### AutoSize ```vb Property Get AutoSize() As Boolean Property Let AutoSize(ByVal Value As Boolean) ``` Whether to automatically resize to fit the content. ### BackColor ```vb Property Get BackColor() As OLE_COLOR Property Let BackColor(ByVal Value As OLE_COLOR) ``` The background color. ### BackStyle ```vb Property Get BackStyle() As CCBackStyleConstants Property Let BackStyle(ByVal Value As CCBackStyleConstants) ``` The background style. See common enumerations. ### BorderStyle ```vb Property Get BorderStyle() As CCBorderStyleConstants Property Let BorderStyle(ByVal Value As CCBorderStyleConstants) ``` The border style. See common enumerations. ### Caption ```vb Property Get Caption() As String Property Let Caption(ByVal Value As String) ``` The display text. ### Enabled ```vb Property Get Enabled() As Boolean Property Let Enabled(ByVal Value As Boolean) ``` Whether the control is enabled. ### Font ```vb Property Get Font() As StdFont Property Let Font(ByVal NewFont As StdFont) Property Set Font(ByVal NewFont As StdFont) ``` The font. ### ForeColor ```vb Property Get ForeColor() As OLE_COLOR Property Let ForeColor(ByVal Value As OLE_COLOR) ``` The foreground color. ### MousePointer ```vb Property Get MousePointer() As CCMousePointerConstants Property Let MousePointer(ByVal Value As CCMousePointerConstants) ``` The mouse pointer style. See common enumerations. ### MouseIcon ```vb Property Get MouseIcon() As IPictureDisp Property Let MouseIcon(ByVal Value As IPictureDisp) Property Set MouseIcon(ByVal Value As IPictureDisp) ``` The custom mouse icon. ### MouseTrack ```vb Property Get MouseTrack() As Boolean Property Let MouseTrack(ByVal Value As Boolean) ``` Whether mouse enter/leave tracking is enabled. ### UseMnemonic ```vb Property Get UseMnemonic() As Boolean Property Let UseMnemonic(ByVal Value As Boolean) ``` Whether the & character is interpreted as an accelerator prefix. ### TextEffect ```vb Property Get TextEffect() As LblTextEffectsConstants Property Let TextEffect(ByVal Value As LblTextEffectsConstants) ``` The text effect. ### TextEffectColor ```vb Property Get TextEffectColor() As OLE_COLOR Property Let TextEffectColor(ByVal Value As OLE_COLOR) ``` The text effect color. ### BorderEffect ```vb Property Get BorderEffect() As LblBorderEffectsConstants Property Let BorderEffect(ByVal Value As LblBorderEffectsConstants) ``` The border effect. ### BorderEffectColor ```vb Property Get BorderEffectColor() As OLE_COLOR Property Let BorderEffectColor(ByVal Value As OLE_COLOR) ``` The border effect color. ### WordWrap ```vb Property Get WordWrap() As Boolean Property Let WordWrap(ByVal Value As Boolean) ``` Whether text wraps automatically. ### RightToLeft ```vb Property Get RightToLeft() As Boolean Property Let RightToLeft(ByVal Value As Boolean) ``` The right-to-left display direction. ### RightToLeftLayout ```vb Property Get RightToLeftLayout() As Boolean Property Let RightToLeftLayout(ByVal Value As Boolean) ``` The right-to-left mirrored layout. ### RightToLeftMode ```vb Property Get RightToLeftMode() As CCRightToLeftModeConstants Property Let RightToLeftMode(ByVal Value As CCRightToLeftModeConstants) ``` The right-to-left mode. See common enumerations. ### Appearance ```vb Property Get Appearance() As CCAppearanceConstants Property Let Appearance(ByVal Value As CCAppearanceConstants) ``` The appearance style. See common enumerations. ### VerticalAlignment ```vb Property Get VerticalAlignment() As CCVerticalAlignmentConstants Property Let VerticalAlignment(ByVal Value As CCVerticalAlignmentConstants) ``` The vertical alignment. See common enumerations. ### hWnd ```vb Property Get hWnd() As LongPtr ``` The window handle. Read-only. ### ToolTipText ```vb Property Get ToolTipText() As String Property Let ToolTipText(ByVal Value As String) ``` The tooltip text. ### Name ```vb Property Get Name() As String ``` The control name. Read-only. ### Tag ```vb Property Get Tag() As Variant Property Let Tag(ByVal Value As Variant) Property Set Tag(ByVal Value As Variant) ``` Custom data. ### Parent ```vb Property Get Parent() As Object ``` The parent object. Read-only. ### Container ```vb Property Get Container() As Object Property Set Container(ByVal Value As Object) ``` The container object. ### Left ```vb Property Get Left() As Single Property Let Left(ByVal Value As Single) ``` The left margin. ### Top ```vb Property Get Top() As Single Property Let Top(ByVal Value As Single) ``` The top margin. ### Width ```vb Property Get Width() As Single Property Let Width(ByVal Value As Single) ``` The width. ### Height ```vb Property Get Height() As Single Property Let Height(ByVal Value As Single) ``` The height. ### Visible ```vb Property Get Visible() As Boolean Property Let Visible(ByVal Value As Boolean) ``` The visibility. ## Methods ### Refresh ```vb Sub Refresh() ``` Forces a repaint. ### AboutBox ```vb Sub AboutBox() ``` Displays the About dialog. ## Events ### Click ```vb Event Click() ``` Occurs when the control is clicked. ### DblClick ```vb Event DblClick() ``` Occurs when the control is double-clicked. ### MouseDown ```vb Event MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) ``` Occurs when a mouse button is pressed. ### MouseUp ```vb Event MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) ``` Occurs when a mouse button is released. ### MouseMove ```vb Event MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) ``` Occurs when the mouse is moved. ### MouseEnter ```vb Event MouseEnter() ``` Occurs when the mouse enters the control. ### MouseLeave ```vb Event MouseLeave() ``` Occurs when the mouse leaves the control. ### OLEStartDrag ```vb Event OLEStartDrag(Data As DataObject, AllowedEffects As Long) ``` Occurs when an OLE drag operation starts. ### OLEGiveFeedback ```vb Event OLEGiveFeedback(Effect As Long, DefaultCursors As Boolean) ``` OLE drag feedback. ### OLESetData ```vb Event OLESetData(Data As DataObject, DataFormat As Integer) ``` OLE set data. ### OLECompleteDrag ```vb Event OLECompleteDrag(Effect As Long) ``` OLE drag completed. ### OLEDragOver ```vb Event OLEDragOver(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single, State As Integer) ``` Occurs when data is dragged over during an OLE drag operation. ### OLEDragDrop ```vb Event OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single) ``` Occurs when data is dropped during an OLE drag-and-drop operation. ## Code Examples ```vb ' Label with shadow effect With LabelW1 .Caption = "Welcome to VBCCR" .TextEffect = LblTextEffectShadow .TextEffectColor = vbGrayText .Font.Size = 14 .Font.Bold = True End With ' Respond to mouse enter/leave Private Sub LabelW1_MouseEnter() LabelW1.ForeColor = vbBlue End Sub Private Sub LabelW1_MouseLeave() LabelW1.ForeColor = vbWindowText End Sub ' Vertically centered label with etched border With LabelW2 .Caption = "Settings" .VerticalAlignment = ccVCenter .BorderEffect = LblBorderEffectEtched .BorderEffectColor = vb3DShadow End With ``` --- --- url: /en/cases/case-iot-cloud.md description: >- Read/write data with just a URL - A lightweight IoT data storage service built on VBMAN HttpServer --- # Lightweight IoT Cloud Platform > **Read/write data with just a URL** — A lightweight HTTP data storage service built on VBMAN `cHttpServer`, making IoT device data cloud upload incredibly simple. > > 📎 Source: [Lightweight IoT Cloud Platform - User Documentation](http://101.43.146.127:800/3.html) ## Project Overview | Project Info | Details | | ------------ | ------- | | **Project Name** | Lightweight IoT Cloud Platform | | **Author** | TechGeek LaoBai | | **Core Module** | VBMAN `cHttpServer` | | **Application Domain** | IoT / Smart Hardware / Data Acquisition | | **Technical Difficulty** | Intermediate | | **Last Updated** | 2026-06-12 | ## Use Cases * 🌡️ IoT sensor data upload (temperature/humidity, air quality, water level, etc.) * 💡 Remote device control (switches, dimming, motors, etc.) * 📱 Web/applet data display * 🏠 Smart home data hub * 🔧 Rapid project prototype validation ## Core Advantages | Feature | Description | | ------- | ----------- | | ⚡ Lightning Fast Integration | No SDK needed, just send an HTTP request, up and running in 30 seconds | | 💰 Free Reads | Read operations are completely free, only writes consume credits | | 🌐 CORS Friendly | Native CORS support, direct frontend calls | | 🔒 Data Security | Each Key has independent storage space, no interference | | 💾 Persistent Storage | Data auto-saved to disk, survives service restarts | ## VBMAN Technical Implementation This project is built on the following VBMAN `cHttpServer` capabilities: ### 1. Custom Route Mapping Using VBMAN `cHttpServer`'s routing system, paths like `/yun/w/{key}/{var}/{val}`, `/yun/r/{key}/{var}` are mapped to business handler classes: ```vb ' === Register business class === Dim HttpServer As New cHttpServer With HttpServer .Router.Reg "Yun", New bYunCloud ' Register cloud platform business class .Router.AutoRoute = True ' Enable auto-routing .Start 800 ' Listen on port 800 End With ``` ### 2. Business Handler Class ```vb ' === bYunCloud.cls - Cloud Platform Core Business === ' Write data: /yun/w/{key}/{var}/{val} Public Sub W(ctx As cHttpServerContext) Dim sKey As String: sKey = ctx.Request.UrlParam(1) Dim sVar As String: sVar = ctx.Request.UrlParam(2) Dim sVal As String: sVal = ctx.Request.UrlParam(3) ' Validate Key If Not ValidateKey(sKey) Then ctx.Response.Json "{""status"":""fail"",""msg"":""invalid key""}" Exit Sub End If ' Check write count If GetWriteCount(sKey) <= 0 Then ctx.Response.Json "{""status"":""fail"",""msg"":""no count""}" Exit Sub End If ' Save data and deduct count SaveData sKey, sVar, sVal DeductCount sKey ctx.Response.Json "{""status"":""ok"",""var"":""" & sVar & """,""val"":""" & sVal & """,""count"":" & GetWriteCount(sKey) & "}" End Sub ' Read data: /yun/r/{key}/{var} Public Sub R(ctx As cHttpServerContext) Dim sKey As String: sKey = ctx.Request.UrlParam(1) Dim sVar As String: sVar = ctx.Request.UrlParam(2) Dim sVal As String: sVal = ReadData(sKey, sVar) If sVal = "" Then ctx.Response.Json "{""status"":""notfound""}" Else ctx.Response.Json "{""status"":""ok"",""var"":""" & sVar & """,""val"":""" & sVal & """}" End If End Sub ' Query count: /yun/q/{key} Public Sub Q(ctx As cHttpServerContext) Dim sKey As String: sKey = ctx.Request.UrlParam(1) ctx.Response.Json "{""status"":""ok"",""count"":" & GetWriteCount(sKey) & "}" End Sub ``` ### 3. CORS Cross-Origin Support VBMAN `cHttpServer` natively supports CORS configuration, allowing direct cross-origin calls from frontend: ```vb With HttpServer .Cors.AllowOrigin = "*" ' Allow all origins .Cors.AllowMethods = "GET" ' Only allow GET method End With ``` ## API Reference ### Write Data Write a variable's value to the cloud platform. ``` GET /yun/w/{key}/{var}/{val} ``` | Parameter | Description | Example | | --------- | ----------- | ------- | | `key` | 32-character authorization Key | `a1b2c3d4...` | | `var` | Variable name (custom) | `temp`, `led_state` | | `val` | Variable value (string) | `25.6`, `1`, `hello` | **Response Example:** ```json { "status": "ok", "var": "temp", "val": "25.6", "count": 999999 } ``` ### Read Data Read a variable's value from the cloud platform. ``` GET /yun/r/{key}/{var} ``` **Response Example:** ```json { "status": "ok", "var": "temp", "val": "25.6" } ``` ::::: tip Read operations are free Read operations are completely free — read as many times as you want. ::::: ### Query Remaining Count Query how many write credits are left for a Key. ``` GET /yun/q/{key} ``` **Response Example:** ```json { "status": "ok", "count": 999999 } ``` ### Error Status | status | Description | | ------ | ----------- | | `ok` | Success | | `fail` | Failed (invalid Key, insufficient credits, etc.) | | `notfound` | Variable not found | ## Multi-Language Call Examples ### Browser / Web (fetch) ```javascript // Write data async function yunWrite(key, varName, value) { const res = await fetch( `http://your-server-address/yun/w/${key}/${varName}/${value}`, ); return res.json(); } // Read data async function yunRead(key, varName) { const res = await fetch(`http://your-server-address/yun/r/${key}/${varName}`); return res.json(); } // Usage example yunWrite("your-key", "temp", "25.6").then((data) => { console.log("Write successful, remaining credits: " + data.count); }); yunRead("your-key", "temp").then((data) => { console.log("Temperature is: " + data.val); }); ``` ### JSONP Cross-Origin Solution If you encounter cross-origin issues and CORS is not available, you can use path-style JSONP (no `?` parameters needed): ```javascript // JSONP read data function yunReadJSONP(key, varName, callbackName) { var script = document.createElement("script"); script.src = "http://your-server-address/yun/r/" + key + "/" + varName + "/" + callbackName; document.body.appendChild(script); script.onload = function () { document.body.removeChild(script); }; } // Define global callback function function handleTempData(data) { console.log("Temperature is: " + data.val); } // Call yunReadJSONP("your-key", "temp", "handleTempData"); ``` ::::: warning Note Path-style JSONP requires server-side support. If unsure, prefer the fetch + CORS approach. ::::: ### ESP32 / Arduino ```cpp #include // Write data void yunWrite(String key, String varName, String value) { HTTPClient http; String url = "http://your-server-address/yun/w/" + key + "/" + varName + "/" + value; http.begin(url); int httpCode = http.GET(); if (httpCode == 200) { Serial.println("Write successful"); } http.end(); } // Read data String yunRead(String key, String varName) { HTTPClient http; String url = "http://your-server-address/yun/r/" + key + "/" + varName; http.begin(url); int httpCode = http.GET(); if (httpCode == 200) { return http.getString(); } return ""; } ``` ### Python ```python import requests BASE_URL = "http://your-server-address" KEY = "your-32-char-key" # Write data r = requests.get(f"{BASE_URL}/yun/w/{KEY}/temp/25.6") print(r.json()) # Read data r = requests.get(f"{BASE_URL}/yun/r/{KEY}/temp") print(r.json()) # Query count r = requests.get(f"{BASE_URL}/yun/q/{KEY}") print(r.json()) ``` ### cURL Command Line ```bash # Write data curl "http://your-server-address/yun/w/your-key/temp/25.6" # Read data curl "http://your-server-address/yun/r/your-key/temp" # Query count curl "http://your-server-address/yun/q/your-key" ``` ## Important Notes ::::: danger Do Not Use QueryString **Never** add `?` parameters at the end of the URL: * ❌ Wrong: `/yun/r/key/temp?_=123456` * ✅ Correct: `/yun/r/key/temp` The platform does not support parameters after `?`. Adding them will cause variable name misidentification and data read failures. :::: info Technical Reason The developer of this case **did not use VBMAN's route parameter (Route Params) mechanism**, but instead implemented custom URL path splitting (splitting `/yun/r/key/var` by `/` to extract parameters). This custom parsing approach only handles path segments, not the QueryString part. If you add `?_=123456` after the URL, the custom parser will mistakenly treat `?_=123456` as part of the path, causing variable name errors. In contrast, VBMAN `cHttpServer` provides standard route parameter functionality (`ctx.Request.UrlParam`, `ctx.Request.QueryString`) that correctly distinguishes between path parameters and query parameters. If you use VBMAN route parameters in your own project, you don't need to worry about this issue. :::: ::::: ### Variable Name Rules * Allowed characters: letters, numbers, underscore `_`, hyphen `-` * Variable names are case-sensitive: `Temp` and `temp` are different variables * Avoid using non-ASCII variable names ### Value Limits * Value length should be kept within 1024 characters * Supports multilingual text, numbers, common symbols * Special characters should use URL encoding ### Data Persistence * Data is automatically saved and survives server restarts * Data is batch-flushed to disk every 50 seconds; in extreme cases (e.g., sudden power loss), writes within the last 50 seconds may be lost ## Pricing | Item | Price | Description | | ---- | ----- | ----------- | | Read Data | Free | Unlimited | | Write Data | 10 CNY / 1 million times | Each write deducts 1 credit | | Query Count | Free | Unlimited | **Top-up Method:** Contact the admin to add credits. After top-up, you can check the latest balance via the `/yun/q/{key}` endpoint. ## FAQ ### Q: What if I forget my Key? Contact the admin to retrieve it. ### Q: Can others see my data? As long as your Key is not leaked, others cannot read your data. Treat your Key like a password — do not share it publicly. ### Q: Is HTTPS supported? Currently only HTTP is supported. If you need HTTPS, contact the admin for configuration, or use VBMAN HttpServer's TLS functionality for self-deployment. ### Q: How many variables can I store? There is no limit on the number of variables per Key. ### Q: Will data be automatically deleted? Data is permanently stored unless you actively overwrite or delete it. ### Q: What happens when credits run out? The write endpoint will return a failure status, while read and query operations remain available. Credits are automatically restored after top-up. ## Project Highlights Summary | Dimension | Highlight | | --------- | --------- | | **VBMAN Capabilities** | `cHttpServer` routing system + CORS + JSON response + data persistence | | **Ultra-Simple Integration** | URL as API, zero SDK, up and running in 30 seconds | | **Cross-Platform** | Browser / ESP32 / Arduino / Python / cURL full coverage | | **Business Model** | Free reads, pay-per-write, lightweight Data-as-a-Service cloud | --- --- url: /en/packages/vbccr/text/linklabel.md description: >- LinkLabel Control - VBCCR Development Manual, complete API reference based on source code --- # LinkLabel Control Enhanced link label control, supporting hyperlink display and custom link collections. ## Enumerations ### LlbLinkBehaviorConstants | Constant | Value | Description | |----------|-------|-------------| | LlbLinkBehaviorSystemDefault | 0 | System default | | LlbLinkBehaviorAlwaysUnderline | 1 | Always underline | | LlbLinkBehaviorHoverUnderline | 2 | Underline on hover | | LlbLinkBehaviorNeverUnderline | 3 | Never underline | ### CCAppearanceConstants See common enumerations. ### CCBorderStyleConstants See common enumerations. ### CCBackStyleConstants See common enumerations. ### CCMousePointerConstants See common enumerations. ### CCVerticalAlignmentConstants See common enumerations. ### CCRightToLeftModeConstants See common enumerations. ## Properties ### Caption ```vb Property Get Caption() As String Property Let Caption(ByVal Value As String) ``` The display text. ### ActiveLinkColor ```vb Property Get ActiveLinkColor() As OLE_COLOR Property Let ActiveLinkColor(ByVal Value As OLE_COLOR) ``` The active link color. ### LinkColor ```vb Property Get LinkColor() As OLE_COLOR Property Let LinkColor(ByVal Value As OLE_COLOR) ``` The link color. ### VisitedLinkColor ```vb Property Get VisitedLinkColor() As OLE_COLOR Property Let VisitedLinkColor(ByVal Value As OLE_COLOR) ``` The visited link color. ### DisabledLinkColor ```vb Property Get DisabledLinkColor() As OLE_COLOR Property Let DisabledLinkColor(ByVal Value As OLE_COLOR) ``` The disabled link color. ### LinkBehavior ```vb Property Get LinkBehavior() As LlbLinkBehaviorConstants Property Let LinkBehavior(ByVal Value As LlbLinkBehaviorConstants) ``` The link behavior style. ### Text ```vb Property Get Text() As String Property Let Text(ByVal Value As String) ``` The complete text content of the control, including link markup. ### Links ```vb Property Get Links() As LlbLinks ``` The link collection. ### AutoSize ```vb Property Get AutoSize() As Boolean Property Let AutoSize(ByVal Value As Boolean) ``` Whether to automatically resize to fit the content. ### BorderStyle ```vb Property Get BorderStyle() As CCBorderStyleConstants Property Let BorderStyle(ByVal Value As CCBorderStyleConstants) ``` The border style. See common enumerations. ### BackColor ```vb Property Get BackColor() As OLE_COLOR Property Let BackColor(ByVal Value As OLE_COLOR) ``` The background color. ### BackStyle ```vb Property Get BackStyle() As CCBackStyleConstants Property Let BackStyle(ByVal Value As CCBackStyleConstants) ``` The background style. See common enumerations. ### ForeColor ```vb Property Get ForeColor() As OLE_COLOR Property Let ForeColor(ByVal Value As OLE_COLOR) ``` The foreground color. ### Font ```vb Property Get Font() As StdFont Property Let Font(ByVal NewFont As StdFont) Property Set Font(ByVal NewFont As StdFont) ``` The font. ### Enabled ```vb Property Get Enabled() As Boolean Property Let Enabled(ByVal Value As Boolean) ``` Whether the control is enabled. ### MousePointer ```vb Property Get MousePointer() As CCMousePointerConstants Property Let MousePointer(ByVal Value As CCMousePointerConstants) ``` The mouse pointer style. See common enumerations. ### MouseIcon ```vb Property Get MouseIcon() As IPictureDisp Property Let MouseIcon(ByVal Value As IPictureDisp) Property Set MouseIcon(ByVal Value As IPictureDisp) ``` The custom mouse icon. ### MouseTrack ```vb Property Get MouseTrack() As Boolean Property Let MouseTrack(ByVal Value As Boolean) ``` Whether mouse enter/leave tracking is enabled. ### WordWrap ```vb Property Get WordWrap() As Boolean Property Let WordWrap(ByVal Value As Boolean) ``` Whether text wraps automatically. ### UseMnemonic ```vb Property Get UseMnemonic() As Boolean Property Let UseMnemonic(ByVal Value As Boolean) ``` Whether the & character is interpreted as an accelerator prefix. ### RightToLeft ```vb Property Get RightToLeft() As Boolean Property Let RightToLeft(ByVal Value As Boolean) ``` The right-to-left display direction. ### RightToLeftLayout ```vb Property Get RightToLeftLayout() As Boolean Property Let RightToLeftLayout(ByVal Value As Boolean) ``` The right-to-left mirrored layout. ### RightToLeftMode ```vb Property Get RightToLeftMode() As CCRightToLeftModeConstants Property Let RightToLeftMode(ByVal Value As CCRightToLeftModeConstants) ``` The right-to-left mode. See common enumerations. ### Appearance ```vb Property Get Appearance() As CCAppearanceConstants Property Let Appearance(ByVal Value As CCAppearanceConstants) ``` The appearance style. See common enumerations. ### VerticalAlignment ```vb Property Get VerticalAlignment() As CCVerticalAlignmentConstants Property Let VerticalAlignment(ByVal Value As CCVerticalAlignmentConstants) ``` The vertical alignment. See common enumerations. ### hWnd ```vb Property Get hWnd() As LongPtr ``` The window handle. Read-only. ### ToolTipText ```vb Property Get ToolTipText() As String Property Let ToolTipText(ByVal Value As String) ``` The tooltip text. ### Name ```vb Property Get Name() As String ``` The control name. Read-only. ### Tag ```vb Property Get Tag() As Variant Property Let Tag(ByVal Value As Variant) Property Set Tag(ByVal Value As Variant) ``` Custom data. ### Parent ```vb Property Get Parent() As Object ``` The parent object. Read-only. ### Container ```vb Property Get Container() As Object Property Set Container(ByVal Value As Object) ``` The container object. ### Left ```vb Property Get Left() As Single Property Let Left(ByVal Value As Single) ``` The left margin. ### Top ```vb Property Get Top() As Single Property Let Top(ByVal Value As Single) ``` The top margin. ### Width ```vb Property Get Width() As Single Property Let Width(ByVal Value As Single) ``` The width. ### Height ```vb Property Get Height() As Single Property Let Height(ByVal Value As Single) ``` The height. ### Visible ```vb Property Get Visible() As Boolean Property Let Visible(ByVal Value As Boolean) ``` The visibility. ## Methods ### Refresh ```vb Sub Refresh() ``` Forces a repaint. ### AboutBox ```vb Sub AboutBox() ``` Displays the About dialog. ## Events ### LinkClick ```vb Event LinkClick(ByVal Link As LlbLink) ``` Occurs when a link is clicked. ### Click ```vb Event Click() ``` Occurs when the control is clicked. ### DblClick ```vb Event DblClick() ``` Occurs when the control is double-clicked. ### MouseDown ```vb Event MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) ``` Occurs when a mouse button is pressed. ### MouseUp ```vb Event MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) ``` Occurs when a mouse button is released. ### MouseMove ```vb Event MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) ``` Occurs when the mouse is moved. ### MouseEnter ```vb Event MouseEnter() ``` Occurs when the mouse enters the control. ### MouseLeave ```vb Event MouseLeave() ``` Occurs when the mouse leaves the control. ## Sub-objects ### Link (LlbLink) Represents a single link within the link label. #### Properties | Property | Type | Access | Description | |----------|------|--------|-------------| | Start As Long | Long | Read/Write | Starting position of the link text (0-based) | | Length As Long | Long | Read/Write | Length of the link text | | Visited As Boolean | Boolean | Read/Write | Whether the link has been visited | | Key As String | String | Read/Write | Link key | | Tag As Variant | Variant | Read/Write | Custom data | ### Links (LlbLinks) The link collection object. #### Properties | Property | Type | Access | Description | |----------|------|--------|-------------| | Item(ByVal Index As Variant) As LlbLink | LlbLink | Read-only | Gets a link by index | | Count As Long | Long | Read-only | Number of links | #### Methods | Method | Description | |--------|-------------| | Add(ByVal Start As Long, ByVal Length As Long, Optional ByVal Key As String) As LlbLink | Adds a link | | Clear() | Clears all links | | Remove(ByVal Index As Variant) | Removes the specified link | ## Code Examples ```vb ' Set up text with links With LinkLabel1 .Caption = "Visit the VBCCR project homepage for more information" .LinkColor = vbBlue .VisitedLinkColor = vbPurple .LinkBehavior = LlbLinkBehaviorHoverUnderline ' Add links .Links.Add 2, 7, "url_main" .Links.Add 15, 4, "url_more" End With ' Handle link clicks Private Sub LinkLabel1_LinkClick(ByVal Link As LlbLink) Select Case Link.Key Case "url_main" ShellExecute 0, "open", "https://github.com/Kr00l/VBCCR", vbNullString, vbNullString, 1 Case "url_more" MsgBox "More information..." End Select Link.Visited = True End Sub ' Create multi-link text With LinkLabel2 .Caption = "Please read the License Agreement and Privacy Policy" .Links.Clear .Links.Add 3, 4, "license" .Links.Add 10, 4, "privacy" End With ``` --- --- url: /zh/vbman/redis/list-operations.md --- # List 操作 Redis List 是一个简单的字符串列表，按照插入顺序排序。支持从列表两端插入和弹出元素。 ## LPush - 从左侧插入 ### 插入单个值 ```vb oRedis.LPush "mylist", "item1" ``` ### 插入多个值 ```vb oRedis.LPush "mylist", "item2", "item3" ``` **注意：** 使用 LPush 插入的元素会出现在列表的开头。 ## RPush - 从右侧插入 ```vb ' 从右侧插入 oRedis.RPush "mylist", "item4" ``` **注意：** 使用 RPush 插入的元素会出现在列表的末尾。 ## LPop - 从左侧弹出 ```vb Dim sValue As String sValue = oRedis.LPop("mylist") Debug.Print sValue ' 输出最左侧的元素 ``` ## RPop - 从右侧弹出 ```vb sValue = oRedis.RPop("mylist") Debug.Print sValue ' 输出最右侧的元素 ``` ## LLen - 获取列表长度 ```vb Dim lLen As Long lLen = oRedis.lLen("mylist") Debug.Print "列表长度: " & lLen ``` ## LRange - 获取列表范围内的元素 ### 获取所有元素 ```vb Dim vItems As Variant vItems = oRedis.LRange("mylist", 0, -1) If IsArray(vItems) Then Dim i As Long For i = 0 To UBound(vItems) Debug.Print vItems(i) Next End If ``` ### 获取前 10 个元素 ```vb vItems = oRedis.LRange("mylist", 0, 9) ``` ### 获取指定范围的元素 ```vb ' 获取从第 6 个到第 10 个元素（索引从 0 开始） vItems = oRedis.LRange("mylist", 5, 9) ``` ## 应用场景 ### 1. 任务队列 ```vb Sub TaskQueue() Dim oRedis As New cRedisClient If Not oRedis.Connect() Then Exit Sub Dim sQueue As String sQueue = "tasks:queue" ' 添加任务到队列 oRedis.RPush sQueue, "发送邮件给用户1" oRedis.RPush sQueue, "生成报表" oRedis.RPush sQueue, "备份数据库" oRedis.RPush sQueue, "清理缓存" ' 查看队列长度 Debug.Print "待处理任务数: " & oRedis.lLen(sQueue) ' 查看所有任务 Dim vTasks As Variant vTasks = oRedis.LRange(sQueue, 0, -1) Debug.Print vbCrLf & "所有任务:" Dim i As Long For i = 0 To UBound(vTasks) Debug.Print " " & (i + 1) & ". " & vTasks(i) Next ' 处理任务（从左侧取出） Debug.Print vbCrLf & "开始处理任务..." While oRedis.lLen(sQueue) > 0 Dim sTask As String sTask = oRedis.LPop(sQueue) Debug.Print "处理任务: " & sTask Debug.Print "剩余任务数: " & oRedis.lLen(sQueue) Wend oRedis.DisConnect End Sub ``` ### 2. 消息队列 ```vb Sub MessageQueue() Dim oRedis As New cRedisClient If Not oRedis.Connect() Then Exit Sub Dim sQueue As String sQueue = "messages:inbox" ' 发送消息（生产者） oRedis.RPush sQueue, "消息1: 你好" oRedis.RPush sQueue, "消息2: Redis 很棒" oRedis.RPush sQueue, "消息3: 学习中" ' 接收消息（消费者） Debug.Print "收到新消息:" Dim lCount As Long lCount = oRedis.lLen(sQueue) For i = 1 To lCount Dim sMsg As String sMsg = oRedis.LPop(sQueue) Debug.Print " " & sMsg Next oRedis.DisConnect End Sub ``` ### 3. 历史记录 ```vb Sub SearchHistory() Dim oRedis As New cRedisClient If Not oRedis.Connect() Then Exit Sub Dim sUserId As String sUserId = "user:123:history" ' 添加搜索记录 oRedis.LPush sUserId, "Redis 教程" oRedis.LPush sUserId, "VB6 编程" oRedis.LPush sUserId, "数据库设计" ' 限制历史记录数量（只保留最近 10 条） While oRedis.lLen(sUserId) > 10 oRedis.RPop sUserId Wend ' 获取最近搜索记录 Dim vHistory As Variant vHistory = oRedis.LRange(sUserId, 0, 4) ' 最近 5 条 Debug.Print "最近搜索记录:" Dim i As Long If IsArray(vHistory) Then For i = 0 To UBound(vHistory) Debug.Print " " & (i + 1) & ". " & vHistory(i) Next End If oRedis.DisConnect End Sub ``` ### 4. 最新动态 ```vb Sub RecentActivity() Dim oRedis As New cRedisClient If Not oRedis.Connect() Then Exit Sub Dim sKey As String sKey = "activity:recent" ' 添加动态 oRedis.LPush sKey, "用户张三发布了新文章" oRedis.LPush sKey, "用户李四评论了文章" oRedis.LPush sKey, "用户王五点赞了帖子" oRedis.LPush sKey, "用户赵六关注了新用户" ' 只保留最新 20 条动态 While oRedis.lLen(sKey) > 20 oRedis.RPop sKey Wend ' 显示最新动态 Dim vActivities As Variant vActivities = oRedis.LRange(sKey, 0, 9) Debug.Print "最新动态:" Dim i As Long If IsArray(vActivities) Then For i = 0 To UBound(vActivities) Debug.Print " " & (i + 1) & ". " & vActivities(i) Next End If oRedis.DisConnect End Sub ``` ### 5. 栈（后进先出） ```vb Sub StackExample() Dim oRedis As New cRedisClient If Not oRedis.Connect() Then Exit Sub Dim sStack As String sStack = "stack:operations" ' 压栈（Push） Debug.Print "压栈操作:" oRedis.LPush sStack, "元素A" Debug.Print " 压入: 元素A" oRedis.LPush sStack, "元素B" Debug.Print " 压入: 元素B" oRedis.LPush sStack, "元素C" Debug.Print " 压入: 元素C" Debug.Print "栈深度: " & oRedis.lLen(sStack) ' 出栈（Pop） Debug.Print vbCrLf & "出栈操作:" While oRedis.lLen(sStack) > 0 Dim sItem As String sItem = oRedis.LPop(sStack) Debug.Print " 弹出: " & sItem Debug.Print " 剩余: " & oRedis.lLen(sStack) Wend oRedis.DisConnect End Sub ``` ### 6. 队列（先进先出） ```vb Sub QueueExample() Dim oRedis As New cRedisClient If Not oRedis.Connect() Then Exit Sub Dim sQueue As String sQueue = "queue:customers" ' 入队（Enqueue） Debug.Print "入队操作:" oRedis.RPush sQueue, "客户A" Debug.Print " 入队: 客户A" oRedis.RPush sQueue, "客户B" Debug.Print " 入队: 客户B" oRedis.RPush sQueue, "客户C" Debug.Print " 入队: 客户C" Debug.Print "队列长度: " & oRedis.lLen(sQueue) ' 出队（Dequeue） Debug.Print vbCrLf & "出队操作:" While oRedis.lLen(sQueue) > 0 Dim sCustomer As String sCustomer = oRedis.LPop(sQueue) Debug.Print " 服务: " & sCustomer Debug.Print " 等待: " & oRedis.lLen(sQueue) Wend oRedis.DisConnect End Sub ``` ## 完整示例 ```vb Sub Example_ListOperations() Dim oRedis As New cRedisClient If Not oRedis.Connect() Then Debug.Print "连接失败: " & oRedis.LastError Exit Sub End If ' 清空现有列表 oRedis.Del "tasks" ' 添加任务 oRedis.RPush "tasks", "任务1" oRedis.RPush "tasks", "任务2" oRedis.RPush "tasks", "任务3" oRedis.RPush "tasks", "任务4" oRedis.RPush "tasks", "任务5" ' 获取列表长度 Debug.Print "任务列表长度: " & oRedis.lLen("tasks") ' 获取所有任务 Dim vTasks As Variant vTasks = oRedis.LRange("tasks", 0, -1) Debug.Print vbCrLf & "所有任务:" Dim i As Long For i = 0 To UBound(vTasks) Debug.Print " " & (i + 1) & ". " & vTasks(i) Next ' 处理第一个任务 Debug.Print vbCrLf & "处理任务: " & oRedis.LPop("tasks") Debug.Print "剩余任务数: " & oRedis.lLen("tasks") ' 添加新任务到前面 oRedis.LPush "tasks", "紧急任务" ' 查看更新后的列表 vTasks = oRedis.LRange("tasks", 0, -1) Debug.Print vbCrLf & "更新后的任务列表:" If IsArray(vTasks) Then For i = 0 To UBound(vTasks) Debug.Print " " & (i + 1) & ". " & vTasks(i) Next End If oRedis.DisConnect End Sub ``` ## List 操作总结 | 操作 | 方法 | 说明 | |------|------|------| | 左侧插入 | LPush | 从列表开头插入 | | 右侧插入 | RPush | 从列表末尾插入 | | 左侧弹出 | LPop | 从列表开头弹出 | | 右侧弹出 | RPop | 从列表末尾弹出 | | 获取长度 | LLen | 获取列表元素数量 | | 获取范围 | LRange | 获取指定范围内的元素 | ## 使用建议 1. **任务队列**：使用 `RPush` + `LPop` 实现先进先出 2. **栈**：使用 `LPush` + `LPop` 实现后进先出 3. **限制大小**：使用 `RPush` + `RPop` 或 `LPush` + `RPop` 控制列表长度 4. **历史记录**：使用 `LPush` 添加新记录，`LRANGE` 获取最近记录 --- --- url: /en/vbman/redis/list-operations.md --- # List Operations Redis List is a simple string list, ordered by insertion order. Supports inserting and popping elements from both ends of the list. ## LPush - Insert from Left ### Insert Single Value ```vb oRedis.LPush "mylist", "item1" ``` ### Insert Multiple Values ```vb oRedis.LPush "mylist", "item2", "item3" ``` **Note:** Elements inserted using LPush appear at the beginning of the list. ## RPush - Insert from Right ```vb ' Insert from right oRedis.RPush "mylist", "item4" ``` **Note:** Elements inserted using RPush appear at the end of the list. ## LPop - Pop from Left ```vb Dim sValue As String sValue = oRedis.LPop("mylist") Debug.Print sValue ' Output: leftmost element ``` ## RPop - Pop from Right ```vb sValue = oRedis.RPop("mylist") Debug.Print sValue ' Output: rightmost element ``` ## LLen - Get List Length ```vb Dim lLen As Long lLen = oRedis.lLen("mylist") Debug.Print "List length: " & lLen ``` ## LRange - Get Elements in Range ### Get All Elements ```vb Dim vItems As Variant vItems = oRedis.LRange("mylist", 0, -1) If IsArray(vItems) Then Dim i As Long For i = 0 To UBound(vItems) Debug.Print vItems(i) Next End If ``` ### Get First 10 Elements ```vb vItems = oRedis.LRange("mylist", 0, 9) ``` ### Get Specified Range Elements ```vb ' Get elements from 6th to 10th (index starts from 0) vItems = oRedis.LRange("mylist", 5, 9) ``` ## Use Cases ### 1. Task Queue ```vb Sub TaskQueue() Dim oRedis As New cRedisClient If Not oRedis.Connect() Then Exit Sub Dim sQueue As String sQueue = "tasks:queue" ' Add tasks to queue oRedis.RPush sQueue, "Send email to user1" oRedis.RPush sQueue, "Generate report" oRedis.RPush sQueue, "Backup database" oRedis.RPush sQueue, "Clear cache" ' View queue length Debug.Print "Pending tasks: " & oRedis.lLen(sQueue) ' View all tasks Dim vTasks As Variant vTasks = oRedis.LRange(sQueue, 0, -1) Debug.Print vbCrLf & "All tasks:" Dim i As Long For i = 0 To UBound(vTasks) Debug.Print " " & (i + 1) & ". " & vTasks(i) Next ' Process tasks (pop from left) Debug.Print vbCrLf & "Processing tasks..." While oRedis.lLen(sQueue) > 0 Dim sTask As String sTask = oRedis.LPop(sQueue) Debug.Print "Processing: " & sTask Debug.Print "Remaining: " & oRedis.lLen(sQueue) Wend oRedis.DisConnect End Sub ``` ### 2. Message Queue ```vb Sub MessageQueue() Dim oRedis As New cRedisClient If Not oRedis.Connect() Then Exit Sub Dim sQueue As String sQueue = "messages:inbox" ' Send messages (producer) oRedis.RPush sQueue, "Message1: Hello" oRedis.RPush sQueue, "Message2: Redis is great" oRedis.RPush sQueue, "Message3: Learning" ' Receive messages (consumer) Debug.Print "New messages:" Dim lCount As Long lCount = oRedis.lLen(sQueue) For i = 1 To lCount Dim sMsg As String sMsg = oRedis.LPop(sQueue) Debug.Print " " & sMsg Next oRedis.DisConnect End Sub ``` ### 3. History Records ```vb Sub SearchHistory() Dim oRedis As New cRedisClient If Not oRedis.Connect() Then Exit Sub Dim sUserId As String sUserId = "user:123:history" ' Add search records oRedis.LPush sUserId, "Redis tutorial" oRedis.LPush sUserId, "VB6 programming" oRedis.LPush sUserId, "Database design" ' Limit history records (keep only recent 10) While oRedis.lLen(sUserId) > 10 oRedis.RPop sUserId Wend ' Get recent search records Dim vHistory As Variant vHistory = oRedis.LRange(sUserId, 0, 4) ' Recent 5 Debug.Print "Recent search records:" Dim i As Long If IsArray(vHistory) Then For i = 0 To UBound(vHistory) Debug.Print " " & (i + 1) & ". " & vHistory(i) Next End If oRedis.DisConnect End Sub ``` ### 4. Recent Activity ```vb Sub RecentActivity() Dim oRedis As New cRedisClient If Not oRedis.Connect() Then Exit Sub Dim sKey As String sKey = "activity:recent" ' Add activities oRedis.LPush sKey, "User Zhang San published new article" oRedis.LPush sKey, "User Li Si commented on article" oRedis.LPush sKey, "User Wang Wu liked post" oRedis.LPush sKey, "User Zhao Liu followed new user" ' Keep only latest 20 activities While oRedis.lLen(sKey) > 20 oRedis.RPop sKey Wend ' Show recent activities Dim vActivities As Variant vActivities = oRedis.LRange(sKey, 0, 9) Debug.Print "Recent activities:" Dim i As Long If IsArray(vActivities) Then For i = 0 To UBound(vActivities) Debug.Print " " & (i + 1) & ". " & vActivities(i) Next End If oRedis.DisConnect End Sub ``` ### 5. Stack (LIFO) ```vb Sub StackExample() Dim oRedis As New cRedisClient If Not oRedis.Connect() Then Exit Sub Dim sStack As String sStack = "stack:operations" ' Push operations Debug.Print "Push operations:" oRedis.LPush sStack, "Element A" Debug.Print " Pushed: Element A" oRedis.LPush sStack, "Element B" Debug.Print " Pushed: Element B" oRedis.LPush sStack, "Element C" Debug.Print " Pushed: Element C" Debug.Print "Stack depth: " & oRedis.lLen(sStack) ' Pop operations Debug.Print vbCrLf & "Pop operations:" While oRedis.lLen(sStack) > 0 Dim sItem As String sItem = oRedis.LPop(sStack) Debug.Print " Popped: " & sItem Debug.Print " Remaining: " & oRedis.lLen(sStack) Wend oRedis.DisConnect End Sub ``` ### 6. Queue (FIFO) ```vb Sub QueueExample() Dim oRedis As New cRedisClient If Not oRedis.Connect() Then Exit Sub Dim sQueue As String sQueue = "queue:customers" ' Enqueue operations Debug.Print "Enqueue operations:" oRedis.RPush sQueue, "Customer A" Debug.Print " Enqueued: Customer A" oRedis.RPush sQueue, "Customer B" Debug.Print " Enqueued: Customer B" oRedis.RPush sQueue, "Customer C" Debug.Print " Enqueued: Customer C" Debug.Print "Queue length: " & oRedis.lLen(sQueue) ' Dequeue operations Debug.Print vbCrLf & "Dequeue operations:" While oRedis.lLen(sQueue) > 0 Dim sCustomer As String sCustomer = oRedis.LPop(sQueue) Debug.Print " Serving: " & sCustomer Debug.Print " Waiting: " & oRedis.lLen(sQueue) Wend oRedis.DisConnect End Sub ``` ## Complete Example ```vb Sub Example_ListOperations() Dim oRedis As New cRedisClient If Not oRedis.Connect() Then Debug.Print "Connection failed: " & oRedis.LastError Exit Sub End If ' Clear existing list oRedis.Del "tasks" ' Add tasks oRedis.RPush "tasks", "Task1" oRedis.RPush "tasks", "Task2" oRedis.RPush "tasks", "Task3" oRedis.RPush "tasks", "Task4" oRedis.RPush "tasks", "Task5" ' Get list length Debug.Print "Task list length: " & oRedis.lLen("tasks") ' Get all tasks Dim vTasks As Variant vTasks = oRedis.LRange("tasks", 0, -1) Debug.Print vbCrLf & "All tasks:" Dim i As Long For i = 0 To UBound(vTasks) Debug.Print " " & (i + 1) & ". " & vTasks(i) Next ' Process first task Debug.Print vbCrLf & "Processing task: " & oRedis.LPop("tasks") Debug.Print "Remaining tasks: " & oRedis.lLen("tasks") ' Add new task to front oRedis.LPush "tasks", "Urgent task" ' View updated list vTasks = oRedis.LRange("tasks", 0, -1) Debug.Print vbCrLf & "Updated task list:" If IsArray(vTasks) Then For i = 0 To UBound(vTasks) Debug.Print " " & (i + 1) & ". " & vTasks(i) Next End If oRedis.DisConnect End Sub ``` ## List Operations Summary | Operation | Method | Description | | ------------ | ------ | ------------------------------- | | Left insert | LPush | Insert from list beginning | | Right insert | RPush | Insert from list end | | Left pop | LPop | Pop from list beginning | | Right pop | RPop | Pop from list end | | Get length | LLen | Get number of list elements | | Get range | LRange | Get elements in specified range | ## Usage Recommendations 1. **Task Queue**: Use `RPush` + `LPop` for FIFO 2. **Stack**: Use `LPush` + `LPop` for LIFO 3. **Limit Size**: Use `RPush` + `RPop` or `LPush` + `RPop` to control list length 4. **History Records**: Use `LPush` to add new records, `LRANGE` to get recent records --- --- url: /en/packages/vbccr/lists/listboxw.md description: >- ListBoxW Control - VBCCR Development Manual, complete API reference based on source code --- # ListBoxW Control Wraps the Win32 native list box control with support for checkbox/radio styles, owner-draw, insertion marks, and multi-column display. ## Enumerations ### LstStyleConstants | Constant | Value | Description | |----------|-------|-------------| | LstStyleStandard | 0 | Standard list box | | LstStyleCheckbox | 1 | Checkbox style | | LstStyleOption | 2 | Option button style | ### LstDrawModeConstants | Constant | Value | Description | |----------|-------|-------------| | LstDrawModeNormal | 0 | System-drawn | | LstDrawModeOwnerDrawFixed | 1 | Owner-draw fixed height | | LstDrawModeOwnerDrawVariable | 2 | Owner-draw variable height | ### CCBorderStyleConstants See common enumerations. ### CCMousePointerConstants See common enumerations. ### CCRightToLeftModeConstants See common enumerations. ## Properties ### Text ```vb Property Get Text() As String Property Let Text(ByVal Value As String) ``` Text of the currently selected item. ### List ```vb Property Get List(ByVal Index As Long) As String Property Let List(ByVal Index As Long, ByVal Value As String) ``` Gets or sets list item text by index. ### ItemData ```vb Property Get ItemData(ByVal Index As Long) As LongPtr Property Let ItemData(ByVal Index As Long, ByVal Value As LongPtr) ``` Gets or sets item-associated data by index. ### ItemChecked ```vb Property Get ItemChecked(ByVal Index As Long) As Boolean Property Let ItemChecked(ByVal Index As Long, ByVal Value As Boolean) ``` Gets or sets the checked state of an item by index (effective when Style is Checkbox or Option). ### ListCount ```vb Property Get ListCount() As Long ``` Total number of list items. Read-only. ### ListIndex ```vb Property Get ListIndex() As Long Property Let ListIndex(ByVal Value As Long) ``` Index of the currently selected item. ### NewIndex ```vb Property Get NewIndex() As Long ``` Index of the most recently added item. Read-only. ### TopIndex ```vb Property Get TopIndex() As Long Property Let TopIndex(ByVal Value As Long) ``` Index of the first visible item in the list. ### AnchorIndex ```vb Property Get AnchorIndex() As Long Property Let AnchorIndex(ByVal Value As Long) ``` Index of the selection anchor. ### SelCount ```vb Property Get SelCount() As Long ``` Number of selected items. Read-only. ### Selected ```vb Property Get Selected(ByVal Index As Long) As Boolean Property Let Selected(ByVal Index As Long, ByVal Value As Boolean) ``` Gets or sets the selected state of an item by index. ### ItemHeight ```vb Property Get ItemHeight(Optional ByVal Index As Long) As Single Property Let ItemHeight(Optional ByVal Index As Long, ByVal Value As Single) ``` Item height. In variable-height owner-draw mode, it can be set per index. ### InsertMark ```vb Property Get InsertMark(Optional ByRef After As Boolean) As Long Property Let InsertMark(Optional ByRef After As Boolean, ByVal Value As Long) ``` Index of the insertion mark. ### OptionIndex ```vb Property Get OptionIndex() As Long Property Let OptionIndex(ByVal Value As Long) ``` Index of the selected item in option button style. ### OLEDraggedItem ```vb Property Get OLEDraggedItem() As Long ``` Index of the dragged item in an OLE drag-drop operation. Read-only. ### Style ```vb Property Get Style() As LstStyleConstants Property Let Style(ByVal Value As LstStyleConstants) ``` List box style. Read-only at design time. ### DrawMode ```vb Property Get DrawMode() As LstDrawModeConstants Property Let DrawMode(ByVal Value As LstDrawModeConstants) ``` Drawing mode. Read-only at design time. ### MultiSelect ```vb Property Get MultiSelect() As VBRUN.MultiSelectConstants Property Let MultiSelect(ByVal Value As VBRUN.MultiSelectConstants) ``` Multi-selection mode. ### Sorted ```vb Property Get Sorted() As Boolean Property Let Sorted(ByVal Value As Boolean) ``` Whether to automatically sort items. ### MultiColumn ```vb Property Get MultiColumn() As Boolean Property Let MultiColumn(ByVal Value As Boolean) ``` Whether to enable multi-column display. ### IntegralHeight ```vb Property Get IntegralHeight() As Boolean Property Let IntegralHeight(ByVal Value As Boolean) ``` Whether to show only complete items. Can be set at design time. ### AllowSelection ```vb Property Get AllowSelection() As Boolean Property Let AllowSelection(ByVal Value As Boolean) ``` Whether to allow item selection. ### UseTabStops ```vb Property Get UseTabStops() As Boolean Property Let UseTabStops(ByVal Value As Boolean) ``` Whether to recognize and expand tab characters. ### DisableNoScroll ```vb Property Get DisableNoScroll() As Boolean Property Let DisableNoScroll(ByVal Value As Boolean) ``` Whether to disable (instead of hide) the scroll bar when scrolling is not needed. ### HorizontalExtent ```vb Property Get HorizontalExtent() As Single Property Let HorizontalExtent(ByVal Value As Single) ``` Horizontal scroll width. ### InsertMarkColor ```vb Property Get InsertMarkColor() As OLE_COLOR Property Let InsertMarkColor(ByVal Value As OLE_COLOR) ``` Color of the insertion mark. ### ScrollTrack ```vb Property Get ScrollTrack() As Boolean Property Let ScrollTrack(ByVal Value As Boolean) ``` Whether to scroll content in real time while dragging the scroll bar. ### Redraw ```vb Property Get Redraw() As Boolean Property Let Redraw(ByVal Value As Boolean) ``` Whether to redraw the list box when items change. Disabling can speed up batch additions. ### BorderStyle ```vb Property Get BorderStyle() As CCBorderStyleConstants Property Let BorderStyle(ByVal Value As CCBorderStyleConstants) ``` Border style. See common enumerations. ### VisualStyles ```vb Property Get VisualStyles() As Boolean Property Let VisualStyles(ByVal Value As Boolean) ``` Whether to enable visual styles. ### BackColor ```vb Property Get BackColor() As OLE_COLOR Property Let BackColor(ByVal Value As OLE_COLOR) ``` Background color. ### ForeColor ```vb Property Get ForeColor() As OLE_COLOR Property Let ForeColor(ByVal Value As OLE_COLOR) ``` Foreground color. ### Font ```vb Property Get Font() As StdFont Property Let Font(ByVal NewFont As StdFont) Property Set Font(ByVal NewFont As StdFont) ``` Font. ### Enabled ```vb Property Get Enabled() As Boolean Property Let Enabled(ByVal Value As Boolean) ``` Whether the control is enabled. ### AllowDropFiles ```vb Property Get AllowDropFiles() As Boolean Property Let AllowDropFiles(ByVal Value As Boolean) ``` Whether to allow file drop. ### OLEDragMode ```vb Property Get OLEDragMode() As VBRUN.OLEDragConstants Property Let OLEDragMode(ByVal Value As VBRUN.OLEDragConstants) ``` OLE drag mode. ### OLEDragDropScroll ```vb Property Get OLEDragDropScroll() As Boolean Property Let OLEDragDropScroll(ByVal Value As Boolean) ``` Whether to auto-scroll during OLE drag-drop. ### OLEDropMode ```vb Property Get OLEDropMode() As OLEDropModeConstants Property Let OLEDropMode(ByVal Value As OLEDropModeConstants) ``` OLE drop mode. ### MousePointer ```vb Property Get MousePointer() As CCMousePointerConstants Property Let MousePointer(ByVal Value As CCMousePointerConstants) ``` Mouse pointer style. See common enumerations. ### MouseIcon ```vb Property Get MouseIcon() As IPictureDisp Property Let MouseIcon(ByVal Value As IPictureDisp) Property Set MouseIcon(ByVal Value As IPictureDisp) ``` Custom mouse icon. ### MouseTrack ```vb Property Get MouseTrack() As Boolean Property Let MouseTrack(ByVal Value As Boolean) ``` Whether to enable mouse enter/leave tracking. ### RightToLeft ```vb Property Get RightToLeft() As Boolean Property Let RightToLeft(ByVal Value As Boolean) ``` Right-to-left display direction. ### RightToLeftMode ```vb Property Get RightToLeftMode() As CCRightToLeftModeConstants Property Let RightToLeftMode(ByVal Value As CCRightToLeftModeConstants) ``` Right-to-left mode. See common enumerations. ### hWnd ```vb Property Get hWnd() As LongPtr ``` Window handle of the list box control. ### hWndUserControl ```vb Property Get hWndUserControl() As LongPtr ``` Window handle of the UserControl. ### ToolTipText ```vb Property Get ToolTipText() As String Property Let ToolTipText(ByVal Value As String) ``` Tooltip text. ### Name ```vb Property Get Name() As String ``` Control name. Read-only. ### Tag ```vb Property Get Tag() As String Property Let Tag(ByVal Value As String) ``` Custom data. ### Parent ```vb Property Get Parent() As Object ``` Parent object. Read-only. ### Container ```vb Property Get Container() As Object Property Set Container(ByVal Value As Object) ``` Container object. ### Left ```vb Property Get Left() As Single Property Let Left(ByVal Value As Single) ``` Left position. ### Top ```vb Property Get Top() As Single Property Let Top(ByVal Value As Single) ``` Top position. ### Width ```vb Property Get Width() As Single Property Let Width(ByVal Value As Single) ``` Width. ### Height ```vb Property Get Height() As Single Property Let Height(ByVal Value As Single) ``` Height. ### Visible ```vb Property Get Visible() As Boolean Property Let Visible(ByVal Value As Boolean) ``` Whether the control is visible. ### HelpContextID ```vb Property Get HelpContextID() As Long Property Let HelpContextID(ByVal Value As Long) ``` Help context ID. ### WhatsThisHelpID ```vb Property Get WhatsThisHelpID() As Long Property Let WhatsThisHelpID(ByVal Value As Long) ``` "What's This" help ID. ### DragIcon ```vb Property Get DragIcon() As IPictureDisp Property Let DragIcon(ByVal Value As IPictureDisp) Property Set DragIcon(ByVal Value As IPictureDisp) ``` Drag icon. ### DragMode ```vb Property Get DragMode() As Integer Property Let DragMode(ByVal Value As Integer) ``` Drag mode. ## Methods ### AddItem ```vb Public Sub AddItem(ByVal Item As String, Optional ByVal Index As Variant) ``` Adds a list item. ### RemoveItem ```vb Public Sub RemoveItem(ByVal Index As Long) ``` Removes the list item at the specified index. ### Clear ```vb Public Sub Clear() ``` Clears all list items. ### Refresh ```vb Public Sub Refresh() ``` Forces a redraw of the control. ### SetSelRange ```vb Public Sub SetSelRange(ByVal StartIndex As Long, ByVal EndIndex As Long) ``` Sets the selection range (in multi-select mode). ### SetColumnWidth ```vb Public Sub SetColumnWidth(ByVal Value As Single) ``` Sets the column width in multi-column mode. ### SelectItem ```vb Public Function SelectItem(ByVal Text As String, Optional ByVal Index As Long = -1) As Long ``` Selects an item matching the text and returns the selected item index. ### FindItem ```vb Public Function FindItem(ByVal Text As String, Optional ByVal Index As Long = -1, Optional ByVal Partial As Boolean) As Long ``` Finds an item matching the text and returns its index. ### HitTest ```vb Public Function HitTest(ByVal X As Single, ByVal Y As Single) As Long ``` Hit test, returns the item index at the specified coordinates. ### HitTestInsertMark ```vb Public Function HitTestInsertMark(ByVal X As Single, ByVal Y As Single, Optional ByRef After As Boolean) As Long ``` Insertion mark hit test, returns the insertion position index. ### ItemsPerColumn ```vb Public Function ItemsPerColumn() As Long ``` Gets the number of items per column. ### SelectedIndices ```vb Public Function SelectedIndices() As Collection ``` Returns a collection of all selected item indices. ### CheckedIndices ```vb Public Function CheckedIndices() As Collection ``` Returns a collection of all checked item (checkbox/radio) indices. ### GetIdealHorizontalExtent ```vb Public Function GetIdealHorizontalExtent() As Single ``` Gets the ideal horizontal scroll width. ### OLEDrag ```vb Public Sub OLEDrag() ``` Initiates an OLE drag-drop operation. ### Drag ```vb Public Sub Drag(Optional ByRef Action As Variant) ``` Starts, ends, or cancels a drag operation. ### SetFocus ```vb Public Sub SetFocus() ``` Sets focus. ### ZOrder ```vb Public Sub ZOrder(Optional ByRef Position As Variant) ``` Adjusts the Z-order. ### Move ```vb Public Sub Move(ByVal Left As Single, Optional ByVal Top As Variant, Optional ByVal Width As Variant, Optional ByVal Height As Variant) ``` Moves and resizes the control. ## Events ### Click ```vb Public Event Click() ``` Click. ### DblClick ```vb Public Event DblClick() ``` Double-click. ### Scroll ```vb Public Event Scroll() ``` Fired when scrolling. ### ItemCheck ```vb Public Event ItemCheck(ByVal Item As Long) ``` Fired when an item is checked or unchecked. ### ItemBeforeCheck ```vb Public Event ItemBeforeCheck(ByVal Item As Long, ByRef Cancel As Boolean) ``` Fired before an item is checked or unchecked, can be canceled. ### ItemMeasure ```vb Public Event ItemMeasure(ByVal Item As Long, ByRef ItemHeight As Long) ``` Fired when measuring item height in variable-height owner-draw mode. ### ItemDraw ```vb Public Event ItemDraw(ByVal Item As Long, ByVal ItemAction As Long, ByVal ItemState As Long, ByVal hDC As Long, ByVal Left As Long, ByVal Top As Long, ByVal Right As Long, ByVal Bottom As Long) ``` Fired when drawing an item in owner-draw mode. ### DropFiles ```vb Public Event DropFiles(ByRef FileList As Variant, ByVal X As Single, ByVal Y As Single) ``` Fired when files are dropped onto the control. ### ContextMenu ```vb Public Event ContextMenu(ByVal X As Single, ByVal Y As Single) ``` Fired when a context menu is requested. ### PreviewKeyDown ```vb Public Event PreviewKeyDown(ByVal KeyCode As Integer, ByRef IsInputKey As Boolean) ``` Preview key down event, fired before KeyDown. ### PreviewKeyUp ```vb Public Event PreviewKeyUp(ByVal KeyCode As Integer, ByRef IsInputKey As Boolean) ``` Preview key up event, fired before KeyUp. ### KeyDown ```vb Public Event KeyDown(KeyCode As Integer, Shift As Integer) ``` Key pressed. ### KeyUp ```vb Public Event KeyUp(KeyCode As Integer, Shift As Integer) ``` Key released. ### KeyPress ```vb Public Event KeyPress(KeyChar As Integer) ``` Key character. ### MouseDown ```vb Public Event MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` Mouse button pressed. ### MouseMove ```vb Public Event MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` Mouse moved. ### MouseUp ```vb Public Event MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` Mouse button released. ### MouseEnter ```vb Public Event MouseEnter() ``` Mouse entered the control. ### MouseLeave ```vb Public Event MouseLeave() ``` Mouse left the control. ### OLECompleteDrag ```vb Public Event OLECompleteDrag(Effect As Long) ``` OLE drag-drop completed. ### OLEDragDrop ```vb Public Event OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single) ``` OLE drag-drop dropped. ### OLEDragOver ```vb Public Event OLEDragOver(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single, State As Integer) ``` OLE drag-drop hover. ### OLEGiveFeedback ```vb Public Event OLEGiveFeedback(Effect As Long, DefaultCursors As Boolean) ``` OLE give feedback. ### OLESetData ```vb Public Event OLESetData(Data As DataObject, DataFormat As Integer) ``` OLE set data. ### OLEStartDrag ```vb Public Event OLEStartDrag(Data As DataObject, AllowedEffects As Long) ``` OLE drag started. ## Code Examples ### Basic Usage ```vb ' Add list items ListBoxW1.AddItem "Item 1" ListBoxW1.AddItem "Item 2", 0 ' Set the currently selected item ListBoxW1.ListIndex = 0 ' Get selected item text Dim s As String s = ListBoxW1.Text ``` ### Checkbox and Option Styles ```vb ' Checkbox style (set at design time) ' ListBoxW1.Style = LstStyleCheckbox ' Get checked items Dim i As Long For i = 0 To ListBoxW1.ListCount - 1 If ListBoxW1.ItemChecked(i) Then Debug.Print ListBoxW1.List(i) End If Next i ``` ### Owner-Draw ```vb ' Variable-height owner-draw (set DrawMode = LstDrawModeOwnerDrawVariable at design time) Private Sub ListBoxW1_ItemMeasure(ByVal Item As Long, ByRef ItemHeight As Long) ItemHeight = 30 End Sub Private Sub ListBoxW1_ItemDraw(ByVal Item As Long, ByVal ItemAction As Long, _ ByVal ItemState As Long, ByVal hDC As Long, _ ByVal Left As Long, ByVal Top As Long, ByVal Right As Long, ByVal Bottom As Long) ' Custom drawing logic End Sub ``` ### Batch Addition ```vb ' Disable redraw to speed up batch addition ListBoxW1.Redraw = False Dim i As Long For i = 1 To 1000 ListBoxW1.AddItem "Item " & i Next i ListBoxW1.Redraw = True ``` --- --- url: /en/packages/vbccr/views/listview.md description: >- ListView Control - VBCCR Developer Reference, complete API documentation based on source code --- # ListView Control Wraps the SysListView32 system list view control, supporting large icon, small icon, list, report, and tile views, as well as grouping, virtual mode, column filtering, and other advanced features. ## Enumerations ### LvwViewConstants | Constant | Value | Description | |----------|-------|-------------| | LvwViewIcon | 0 | Large icon view | | LvwViewSmallIcon | 1 | Small icon view | | LvwViewList | 2 | List view | | LvwViewReport | 3 | Report view | | LvwViewTile | 4 | Tile view | ### LvwArrangeConstants | Constant | Value | Description | |----------|-------|-------------| | LvwArrangeNone | 0 | No arrangement | | LvwArrangeAutoLeft | 1 | Auto arrange left | | LvwArrangeAutoTop | 2 | Auto arrange top | | LvwArrangeLeft | 3 | Arrange left | | LvwArrangeTop | 4 | Arrange top | ### LvwColumnHeaderAlignmentConstants | Constant | Value | Description | |----------|-------|-------------| | LvwColumnHeaderAlignmentLeft | 0 | Left aligned | | LvwColumnHeaderAlignmentRight | 1 | Right aligned | | LvwColumnHeaderAlignmentCenter | 2 | Centered | ### LvwColumnHeaderSortArrowConstants | Constant | Value | Description | |----------|-------|-------------| | LvwColumnHeaderSortArrowNone | 0 | No sort arrow | | LvwColumnHeaderSortArrowDown | 1 | Down arrow (ascending) | | LvwColumnHeaderSortArrowUp | 2 | Up arrow (descending) | ### LvwColumnHeaderAutoSizeConstants | Constant | Value | Description | |----------|-------|-------------| | LvwColumnHeaderAutoSizeToItems | 0 | Auto size to items | | LvwColumnHeaderAutoSizeToHeader | 1 | Auto size to header | ### LvwColumnHeaderFilterTypeConstants | Constant | Value | Description | |----------|-------|-------------| | LvwColumnHeaderFilterTypeText | 0 | Text filter | | LvwColumnHeaderFilterTypeNumber | 1 | Number filter | ### LvwLabelEditConstants | Constant | Value | Description | |----------|-------|-------------| | LvwLabelEditAutomatic | 0 | Automatic label edit | | LvwLabelEditManual | 1 | Manual label edit | | LvwLabelEditDisabled | 2 | Label edit disabled | ### LvwSortOrderConstants | Constant | Value | Description | |----------|-------|-------------| | LvwSortOrderAscending | 0 | Ascending order | | LvwSortOrderDescending | 1 | Descending order | ### LvwSortTypeConstants | Constant | Value | Description | |----------|-------|-------------| | LvwSortTypeBinary | 0 | Binary sort | | LvwSortTypeText | 1 | Text sort | | LvwSortTypeNumeric | 2 | Numeric sort | | LvwSortTypeCurrency | 3 | Currency sort | | LvwSortTypeDate | 4 | Date sort | | LvwSortTypeLogical | 5 | Logical sort | ### LvwPictureAlignmentConstants | Constant | Value | Description | |----------|-------|-------------| | LvwPictureAlignmentTopLeft | 0 | Top left | | LvwPictureAlignmentTopRight | 1 | Top right | | LvwPictureAlignmentBottomLeft | 2 | Bottom left | | LvwPictureAlignmentBottomRight | 3 | Bottom right | | LvwPictureAlignmentCenter | 4 | Centered | | LvwPictureAlignmentTile | 5 | Tiled | ### LvwGroupHeaderAlignmentConstants | Constant | Value | Description | |----------|-------|-------------| | LvwGroupHeaderAlignmentLeft | 0 | Left aligned | | LvwGroupHeaderAlignmentRight | 1 | Right aligned | | LvwGroupHeaderAlignmentCenter | 2 | Centered | ### LvwGroupFooterAlignmentConstants | Constant | Value | Description | |----------|-------|-------------| | LvwGroupFooterAlignmentLeft | 0 | Left aligned | | LvwGroupFooterAlignmentRight | 1 | Right aligned | | LvwGroupFooterAlignmentCenter | 2 | Centered | ### LvwVisualThemeConstants | Constant | Value | Description | |----------|-------|-------------| | LvwVisualThemeStandard | 0 | Standard theme | | LvwVisualThemeExplorer | 1 | Explorer theme | ### LvwVirtualPropertyConstants | Constant | Value | Description | |----------|-------|-------------| | LvwVirtualPropertyText | 1 | Text property | | LvwVirtualPropertyIcon | 2 | Icon property | | LvwVirtualPropertyIndentation | 4 | Indentation property | | LvwVirtualPropertyToolTipText | 8 | ToolTip text property | | LvwVirtualPropertyBold | 16 | Bold property | | LvwVirtualPropertyForeColor | 32 | Fore color property | | LvwVirtualPropertyChecked | 64 | Checked property | ### LvwFindDirectionConstants | Constant | Value | Description | |----------|-------|-------------| | LvwFindDirectionUndefined | 0 | Undefined | | LvwFindDirectionPrior | vbKeyPageUp | Page up direction | | LvwFindDirectionNext | vbKeyPageDown | Page down direction | | LvwFindDirectionEnd | vbKeyEnd | End direction | | LvwFindDirectionHome | vbKeyHome | Home direction | | LvwFindDirectionLeft | vbKeyLeft | Left direction | | LvwFindDirectionUp | vbKeyUp | Up direction | | LvwFindDirectionRight | vbKeyRight | Right direction | | LvwFindDirectionDown | vbKeyDown | Down direction | ### CCBorderStyleConstants See common enumerations. ### CCAppearanceConstants See common enumerations. ### CCMousePointerConstants See common enumerations. ### CCIMEModeConstants See common enumerations. ### CCBackStyleConstants See common enumerations. ### CCRightToLeftModeConstants See common enumerations. ### CCScrollOrientationConstants See common enumerations. ### OLEDropModeConstants See common enumerations. ## Properties ### View ```vb Property Get View() As LvwViewConstants Property Let View(ByVal Value As LvwViewConstants) ``` View mode. ### Arrange ```vb Property Get Arrange() As LvwArrangeConstants Property Let Arrange(ByVal Value As LvwArrangeConstants) ``` Icon arrangement. ### SortKey ```vb Property Get SortKey() As Integer Property Let SortKey(ByVal Value As Integer) ``` Sort key column index. ### SortOrder ```vb Property Get SortOrder() As LvwSortOrderConstants Property Let SortOrder(ByVal Value As LvwSortOrderConstants) ``` Sort order. ### SortType ```vb Property Get SortType() As LvwSortTypeConstants Property Let SortType(ByVal Value As LvwSortTypeConstants) ``` Sort type. ### Sorted ```vb Property Get Sorted() As Boolean Property Let Sorted(ByVal Value As Boolean) ``` Whether sorting is enabled. ### LabelEdit ```vb Property Get LabelEdit() As LvwLabelEditConstants Property Let LabelEdit(ByVal Value As LvwLabelEditConstants) ``` Label edit mode. ### LabelWrap ```vb Property Get LabelWrap() As Boolean Property Let LabelWrap(ByVal Value As Boolean) ``` Whether label text wrapping is allowed. ### MultiSelect ```vb Property Get MultiSelect() As Boolean Property Let MultiSelect(ByVal Value As Boolean) ``` Whether multiple selection is allowed. ### FullRowSelect ```vb Property Get FullRowSelect() As Boolean Property Let FullRowSelect(ByVal Value As Boolean) ``` Whether full row selection is enabled. ### GridLines ```vb Property Get GridLines() As Boolean Property Let GridLines(ByVal Value As Boolean) ``` Whether grid lines are displayed. ### Checkboxes ```vb Property Get Checkboxes() As Boolean Property Let Checkboxes(ByVal Value As Boolean) ``` Whether checkboxes are displayed. ### HideSelection ```vb Property Get HideSelection() As Boolean Property Let HideSelection(ByVal Value As Boolean) ``` Whether the selection is hidden when the control loses focus. ### HideColumnHeaders ```vb Property Get HideColumnHeaders() As Boolean Property Let HideColumnHeaders(ByVal Value As Boolean) ``` Whether column headers are hidden. ### AllowColumnReorder ```vb Property Get AllowColumnReorder() As Boolean Property Let AllowColumnReorder(ByVal Value As Boolean) ``` Whether column reordering by dragging is allowed. ### AllowColumnCheckboxes ```vb Property Get AllowColumnCheckboxes() As Boolean Property Let AllowColumnCheckboxes(ByVal Value As Boolean) ``` Whether column checkboxes are allowed. ### AllowDropFiles ```vb Property Get AllowDropFiles() As Boolean Property Let AllowDropFiles(ByVal Value As Boolean) ``` Whether dropping files is allowed. ### ShowInfoTips ```vb Property Get ShowInfoTips() As Boolean Property Let ShowInfoTips(ByVal Value As Boolean) ``` Whether info tips are displayed. ### ShowLabelTips ```vb Property Get ShowLabelTips() As Boolean Property Let ShowLabelTips(ByVal Value As Boolean) ``` Whether label tips are displayed. ### ShowColumnTips ```vb Property Get ShowColumnTips() As Boolean Property Let ShowColumnTips(ByVal Value As Boolean) ``` Whether column tips are displayed. ### DoubleBuffer ```vb Property Get DoubleBuffer() As Boolean Property Let DoubleBuffer(ByVal Value As Boolean) ``` Whether double buffering is enabled. ### VisualStyles ```vb Property Get VisualStyles() As Boolean Property Let VisualStyles(ByVal Value As Boolean) ``` Whether visual styles are enabled. ### VisualTheme ```vb Property Get VisualTheme() As LvwVisualThemeConstants Property Let VisualTheme(ByVal Value As LvwVisualThemeConstants) ``` Visual theme. ### HoverSelection ```vb Property Get HoverSelection() As Boolean Property Let HoverSelection(ByVal Value As Boolean) ``` Whether hover selection is enabled. ### HoverSelectionTime ```vb Property Get HoverSelectionTime() As Long Property Let HoverSelectionTime(ByVal Value As Long) ``` Hover selection delay time (milliseconds). ### HotTracking ```vb Property Get HotTracking() As Boolean Property Let HotTracking(ByVal Value As Boolean) ``` Whether hot tracking is enabled. ### HighlightHot ```vb Property Get HighlightHot() As Boolean Property Let HighlightHot(ByVal Value As Boolean) ``` Whether hot items are highlighted. ### UnderlineHot ```vb Property Get UnderlineHot() As Boolean Property Let UnderlineHot(ByVal Value As Boolean) ``` Whether hot items are underlined. ### InsertMarkColor ```vb Property Get InsertMarkColor() As OLE_COLOR Property Let InsertMarkColor(ByVal Value As OLE_COLOR) ``` Insert mark color. ### TextBackground ```vb Property Get TextBackground() As CCBackStyleConstants Property Let TextBackground(ByVal Value As CCBackStyleConstants) ``` Text background style. See common enumerations. ### ClickableColumnHeaders ```vb Property Get ClickableColumnHeaders() As Boolean Property Let ClickableColumnHeaders(ByVal Value As Boolean) ``` Whether column headers are clickable. ### HighlightColumnHeaders ```vb Property Get HighlightColumnHeaders() As Boolean Property Let HighlightColumnHeaders(ByVal Value As Boolean) ``` Whether column headers are highlighted. ### TrackSizeColumnHeaders ```vb Property Get TrackSizeColumnHeaders() As Boolean Property Let TrackSizeColumnHeaders(ByVal Value As Boolean) ``` Whether column header size tracking is enabled. ### ResizableColumnHeaders ```vb Property Get ResizableColumnHeaders() As Boolean Property Let ResizableColumnHeaders(ByVal Value As Boolean) ``` Whether column headers are resizable. ### Picture ```vb Property Get Picture() As IPictureDisp Property Let Picture(ByVal Value As IPictureDisp) Property Set Picture(ByVal Value As IPictureDisp) ``` Background picture. ### PictureAlignment ```vb Property Get PictureAlignment() As LvwPictureAlignmentConstants Property Let PictureAlignment(ByVal Value As LvwPictureAlignmentConstants) ``` Background picture alignment. ### PictureWatermark ```vb Property Get PictureWatermark() As Boolean Property Let PictureWatermark(ByVal Value As Boolean) ``` Whether the background picture is used as a watermark. ### TileViewLines ```vb Property Get TileViewLines() As Long Property Let TileViewLines(ByVal Value As Long) ``` Number of text lines in tile view. ### SnapToGrid ```vb Property Get SnapToGrid() As Boolean Property Let SnapToGrid(ByVal Value As Boolean) ``` Whether snap to grid is enabled. ### GroupView ```vb Property Get GroupView() As Boolean Property Let GroupView(ByVal Value As Boolean) ``` Whether group view is enabled. ### GroupSubsetCount ```vb Property Get GroupSubsetCount() As Long Property Let GroupSubsetCount(ByVal Value As Long) ``` Number of items displayed in a group subset. ### UseColumnChevron ```vb Property Get UseColumnChevron() As Boolean Property Let UseColumnChevron(ByVal Value As Boolean) ``` Whether column chevrons are used. ### UseColumnFilterBar ```vb Property Get UseColumnFilterBar() As Boolean Property Let UseColumnFilterBar(ByVal Value As Boolean) ``` Whether the column filter bar is used. ### AutoSelectFirstItem ```vb Property Get AutoSelectFirstItem() As Boolean Property Let AutoSelectFirstItem(ByVal Value As Boolean) ``` Whether the first item is automatically selected. ### IMEMode ```vb Property Get IMEMode() As CCIMEModeConstants Property Let IMEMode(ByVal Value As CCIMEModeConstants) ``` Input method editor mode. See common enumerations. ### VirtualMode ```vb Property Get VirtualMode() As Boolean Property Let VirtualMode(ByVal Value As Boolean) ``` Whether virtual mode is enabled. ### VirtualItemCount ```vb Property Get VirtualItemCount() As Long Property Let VirtualItemCount(ByVal Value As Long) ``` Total item count in virtual mode. ### VirtualDisabledInfos ```vb Property Get VirtualDisabledInfos() As LvwVirtualPropertyConstants Property Let VirtualDisabledInfos(ByVal Value As LvwVirtualPropertyConstants) ``` Disabled property mask in virtual mode. ### ListItems ```vb Property Get ListItems() As LvwListItems ``` List items collection. Read-only. ### VirtualListItems ```vb Property Get VirtualListItems() As LvwVirtualListItems ``` Virtual list items collection. Read-only. ### ColumnHeaders ```vb Property Get ColumnHeaders() As LvwColumnHeaders ``` Column headers collection. Read-only. ### Groups ```vb Property Get Groups() As LvwGroups ``` Groups collection. Read-only. ### WorkAreas ```vb Property Get WorkAreas() As LvwWorkAreas ``` Work areas collection. Read-only. ### TopItem ```vb Property Get TopItem() As LvwListItem ``` First visible item. Read-only. ### SelectedItem ```vb Property Get SelectedItem() As LvwListItem Property Let SelectedItem(ByVal Value As LvwListItem) Property Set SelectedItem(ByVal Value As LvwListItem) ``` Currently selected item. ### HotItem ```vb Property Get HotItem() As LvwListItem Property Let HotItem(ByVal Value As LvwListItem) Property Set HotItem(ByVal Value As LvwListItem) ``` Hot item (the item under the mouse cursor). ### SelectionMark ```vb Property Get SelectionMark() As LvwListItem Property Let SelectionMark(ByVal Value As LvwListItem) Property Set SelectionMark(ByVal Value As LvwListItem) ``` Selection mark item. ### DropHighlight ```vb Property Get DropHighlight() As LvwListItem Property Let DropHighlight(ByVal Value As LvwListItem) Property Set DropHighlight(ByVal Value As LvwListItem) ``` Drop highlight item. ### InsertMark ```vb Property Get InsertMark(Optional ByRef After As Boolean) As LvwListItem Property Let InsertMark(Optional ByRef After As Boolean, ByVal Value As LvwListItem) Property Set InsertMark(Optional ByRef After As Boolean, ByVal Value As LvwListItem) ``` Insert mark item. ### OLEDraggedItem ```vb Property Get OLEDraggedItem() As LvwListItem ``` The item being dragged during an OLE drag-and-drop operation. Read-only. ### SelectedGroup ```vb Property Get SelectedGroup() As LvwGroup Property Let SelectedGroup(ByVal Value As LvwGroup) Property Set SelectedGroup(ByVal Value As LvwGroup) ``` Currently selected group. ### SelectedColumn ```vb Property Get SelectedColumn() As LvwColumnHeader Property Let SelectedColumn(ByVal Value As LvwColumnHeader) Property Set SelectedColumn(ByVal Value As LvwColumnHeader) ``` Currently selected column. ### ColumnOrder ```vb Property Get ColumnOrder() As Variant Property Let ColumnOrder(ByVal ArgList As Variant) ``` Column order array. ### ColumnWidth ```vb Property Get ColumnWidth() As Single Property Let ColumnWidth(ByVal Value As Single) ``` Current column width. ### ColumnFilterChangedTimeout ```vb Property Get ColumnFilterChangedTimeout() As Long Property Let ColumnFilterChangedTimeout(ByVal Value As Long) ``` Column filter change timeout. ### IconSpacingWidth ```vb Property Get IconSpacingWidth() As Single Property Let IconSpacingWidth(ByVal Value As Single) ``` Icon spacing width. ### IconSpacingHeight ```vb Property Get IconSpacingHeight() As Single Property Let IconSpacingHeight(ByVal Value As Single) ``` Icon spacing height. ### IncrementalSearchString ```vb Property Get IncrementalSearchString() As String ``` Incremental search string. Read-only. ### Redraw ```vb Property Get Redraw() As Boolean Property Let Redraw(ByVal Value As Boolean) ``` Whether redrawing is enabled. ### BorderStyle ```vb Property Get BorderStyle() As CCBorderStyleConstants Property Let BorderStyle(ByVal Value As CCBorderStyleConstants) ``` Border style. See common enumerations. ### BackColor ```vb Property Get BackColor() As OLE_COLOR Property Let BackColor(ByVal Value As OLE_COLOR) ``` Background color. ### ForeColor ```vb Property Get ForeColor() As OLE_COLOR Property Let ForeColor(ByVal Value As OLE_COLOR) ``` Foreground color. ### Font ```vb Property Get Font() As StdFont Property Let Font(ByVal NewFont As StdFont) Property Set Font(ByVal NewFont As StdFont) ``` Font. ### Enabled ```vb Property Get Enabled() As Boolean Property Let Enabled(ByVal Value As Boolean) ``` Whether the control is enabled. ### Icons ```vb Property Get Icons() As Variant Property Set Icons(ByVal Value As Variant) Property Let Icons(ByVal Value As Variant) ``` Large icon image list. ### SmallIcons ```vb Property Get SmallIcons() As Variant Property Set SmallIcons(ByVal Value As Variant) Property Let SmallIcons(ByVal Value As Variant) ``` Small icon image list. ### ColumnHeaderIcons ```vb Property Get ColumnHeaderIcons() As Variant Property Set ColumnHeaderIcons(ByVal Value As Variant) Property Let ColumnHeaderIcons(ByVal Value As Variant) ``` Column header image list. ### GroupIcons ```vb Property Get GroupIcons() As Variant Property Set GroupIcons(ByVal Value As Variant) Property Let GroupIcons(ByVal Value As Variant) ``` Group header image list. ### OLEDragMode ```vb Property Get OLEDragMode() As VBRUN.OLEDragConstants Property Let OLEDragMode(ByVal Value As VBRUN.OLEDragConstants) ``` OLE drag mode. ### OLEDragDropScroll ```vb Property Get OLEDragDropScroll() As Boolean Property Let OLEDragDropScroll(ByVal Value As Boolean) ``` Whether automatic scrolling is enabled during OLE drag-and-drop. ### OLEDragDropScrollOrientation ```vb Property Get OLEDragDropScrollOrientation() As CCScrollOrientationConstants Property Let OLEDragDropScrollOrientation(ByVal Value As CCScrollOrientationConstants) ``` OLE drag-and-drop auto-scroll orientation. See common enumerations. ### OLEDropMode ```vb Property Get OLEDropMode() As OLEDropModeConstants Property Let OLEDropMode(ByVal Value As OLEDropModeConstants) ``` OLE drop mode. ### MousePointer ```vb Property Get MousePointer() As CCMousePointerConstants Property Let MousePointer(ByVal Value As CCMousePointerConstants) ``` Mouse pointer style. See common enumerations. ### MouseIcon ```vb Property Get MouseIcon() As IPictureDisp Property Let MouseIcon(ByVal Value As IPictureDisp) Property Set MouseIcon(ByVal Value As IPictureDisp) ``` Custom mouse icon. ### HotMousePointer ```vb Property Get HotMousePointer() As CCMousePointerConstants Property Let HotMousePointer(ByVal Value As CCMousePointerConstants) ``` Hot item mouse pointer style. See common enumerations. ### HotMouseIcon ```vb Property Get HotMouseIcon() As IPictureDisp Property Let HotMouseIcon(ByVal Value As IPictureDisp) Property Set HotMouseIcon(ByVal Value As IPictureDisp) ``` Hot item custom mouse icon. ### HeaderMousePointer ```vb Property Get HeaderMousePointer() As CCMousePointerConstants Property Let HeaderMousePointer(ByVal Value As CCMousePointerConstants) ``` Column header mouse pointer style. See common enumerations. ### HeaderMouseIcon ```vb Property Get HeaderMouseIcon() As IPictureDisp Property Let HeaderMouseIcon(ByVal Value As IPictureDisp) Property Set HeaderMouseIcon(ByVal Value As IPictureDisp) ``` Column header custom mouse icon. ### MouseTrack ```vb Property Get MouseTrack() As Boolean Property Let MouseTrack(ByVal Value As Boolean) ``` Whether mouse enter/leave tracking is enabled. ### RightToLeft ```vb Property Get RightToLeft() As Boolean Property Let RightToLeft(ByVal Value As Boolean) ``` Right-to-left display direction. ### RightToLeftLayout ```vb Property Get RightToLeftLayout() As Boolean Property Let RightToLeftLayout(ByVal Value As Boolean) ``` Right-to-left mirrored layout. ### RightToLeftMode ```vb Property Get RightToLeftMode() As CCRightToLeftModeConstants Property Let RightToLeftMode(ByVal Value As CCRightToLeftModeConstants) ``` Right-to-left mode. See common enumerations. ### hWnd ```vb Property Get hWnd() As LongPtr ``` Window handle of the list view control. ### hWndUserControl ```vb Property Get hWndUserControl() As LongPtr ``` Window handle of the user control. ### hWndHeader ```vb Property Get hWndHeader() As LongPtr ``` Window handle of the column header control. ### hWndLabelEdit ```vb Property Get hWndLabelEdit() As LongPtr ``` Window handle of the label edit box. ### ToolTipText ```vb Property Get ToolTipText() As String Property Let ToolTipText(ByVal Value As String) ``` ToolTip text. ### Name ```vb Property Get Name() As String ``` Control name. Read-only. ### Tag ```vb Property Get Tag() As String Property Let Tag(ByVal Value As String) ``` Custom data. ### Parent ```vb Property Get Parent() As Object ``` Parent object. Read-only. ### Container ```vb Property Get Container() As Object Property Set Container(ByVal Value As Object) ``` Container object. ### Left ```vb Property Get Left() As Single Property Let Left(ByVal Value As Single) ``` Left edge distance. ### Top ```vb Property Get Top() As Single Property Let Top(ByVal Value As Single) ``` Top edge distance. ### Width ```vb Property Get Width() As Single Property Let Width(ByVal Value As Single) ``` Width. ### Height ```vb Property Get Height() As Single Property Let Height(ByVal Value As Single) ``` Height. ### Visible ```vb Property Get Visible() As Boolean Property Let Visible(ByVal Value As Boolean) ``` Whether the control is visible. ### HelpContextID ```vb Property Get HelpContextID() As Long Property Let HelpContextID(ByVal Value As Long) ``` Help context ID. ### WhatsThisHelpID ```vb Property Get WhatsThisHelpID() As Long Property Let WhatsThisHelpID(ByVal Value As Long) ``` "What's This" help ID. ### DragIcon ```vb Property Get DragIcon() As IPictureDisp Property Let DragIcon(ByVal Value As IPictureDisp) Property Set DragIcon(ByVal Value As IPictureDisp) ``` Drag icon. ### DragMode ```vb Property Get DragMode() As Integer Property Let DragMode(ByVal Value As Integer) ``` Drag mode. ## Methods ### Refresh ```vb Public Sub Refresh() ``` Forces a redraw of the control. ### HitTest ```vb Public Function HitTest(ByVal X As Single, ByVal Y As Single, Optional ByRef SubItemIndex As Variant) As LvwListItem ``` Hit test; returns the list item at the specified coordinates. ### HitTestInsertMark ```vb Public Function HitTestInsertMark(ByVal X As Single, ByVal Y As Single, Optional ByRef After As Boolean) As LvwListItem ``` Insert mark hit test; returns the list item at the insertion position. ### FindItem ```vb Public Function FindItem(ByVal Text As String, Optional ByVal Index As Long, Optional ByVal Partial As Boolean, Optional ByVal Wrap As Boolean) As LvwListItem ``` Finds a list item matching the specified text. ### FindNearestItem ```vb Public Function FindNearestItem(ByVal X As Single, ByVal Y As Single, Optional ByVal Direction As LvwFindDirectionConstants) As LvwListItem ``` Finds the nearest list item in the specified direction. ### FindSubItem ```vb Public Function FindSubItem(ByVal Text As String, Optional ByVal Index As Long, Optional ByRef SubItemIndex As Long, Optional ByVal Partial As Boolean, Optional ByVal Wrap As Boolean) As LvwListItem ``` Finds a sub-item matching the specified text. ### GetVisibleCount ```vb Public Function GetVisibleCount() As Long ``` Returns the number of visible items. ### GetSelectedCount ```vb Public Function GetSelectedCount() As Long ``` Returns the number of selected items. ### GetHeaderHeight ```vb Public Function GetHeaderHeight() As Single ``` Returns the column header height. ### StartLabelEdit ```vb Public Sub StartLabelEdit() ``` Starts label editing. ### EndLabelEdit ```vb Public Sub EndLabelEdit() ``` Ends label editing. ### Scroll ```vb Public Sub Scroll(ByVal X As Single, ByVal Y As Single) ``` Scrolls the list view content. ### ResetEmptyMarkup ```vb Public Sub ResetEmptyMarkup() ``` Resets the empty markup text. ### ComputeControlSize ```vb Public Sub ComputeControlSize(ByVal VisibleCount As Long, ByRef Width As Single, ByRef Height As Single, Optional ByVal ProposedWidth As Single, Optional ByVal ProposedHeight As Single) ``` Calculates the control size needed to display the specified number of items. ### TextWidth ```vb Public Function TextWidth(ByVal Text As String) As Single ``` Calculates the text width. ### ResetForeColors ```vb Public Sub ResetForeColors() ``` Resets the foreground color of all list items and sub-items. ### SelectedIndices ```vb Public Function SelectedIndices() As Collection ``` Returns a collection of all selected item indices. ### GhostedIndices ```vb Public Function GhostedIndices() As Collection ``` Returns a collection of all ghosted item indices. ### CheckedIndices ```vb Public Function CheckedIndices() As Collection ``` Returns a collection of all checked item indices. ### ResetIconSpacing ```vb Public Sub ResetIconSpacing() ``` Resets icon spacing to the default value. ### OLEDrag ```vb Public Sub OLEDrag() ``` Initiates an OLE drag-and-drop operation. ### Drag ```vb Public Sub Drag(Optional ByRef Action As Variant) ``` Starts, ends, or cancels a drag operation. ### SetFocus ```vb Public Sub SetFocus() ``` Sets focus to the control. ### ZOrder ```vb Public Sub ZOrder(Optional ByRef Position As Variant) ``` Adjusts the Z-order. ### Move ```vb Public Sub Move(ByVal Left As Single, Optional ByVal Top As Variant, Optional ByVal Width As Variant, Optional ByVal Height As Variant) ``` Moves and resizes the control. ## Events ### Click ```vb Public Event Click() ``` Click. ### DblClick ```vb Public Event DblClick() ``` Double-click. ### ItemClick ```vb Public Event ItemClick(ByVal Item As LvwListItem, ByVal Button As Integer) ``` A list item was clicked. ### ItemDblClick ```vb Public Event ItemDblClick(ByVal Item As LvwListItem, ByVal Button As Integer) ``` A list item was double-clicked. ### ItemFocus ```vb Public Event ItemFocus(ByVal Item As LvwListItem) ``` A list item received focus. ### ItemActivate ```vb Public Event ItemActivate(ByVal Item As LvwListItem, ByVal SubItemIndex As Long, ByVal Shift As Integer) ``` A list item was activated. ### ItemSelect ```vb Public Event ItemSelect(ByVal Item As LvwListItem, ByVal Selected As Boolean) ``` A list item's selection state changed. ### ItemCheck ```vb Public Event ItemCheck(ByVal Item As LvwListItem, ByVal Checked As Boolean) ``` A list item's checkbox state changed. ### ItemDrag ```vb Public Event ItemDrag(ByVal Item As LvwListItem, ByVal Button As Integer) ``` A drag-and-drop operation was initiated on a list item. ### ItemBkColor ```vb Public Event ItemBkColor(ByVal Item As LvwListItem, ByRef RGBColor As Long) ``` List item background color request (report view); allows providing an alternate background color. ### GetVirtualItem ```vb Public Event GetVirtualItem(ByVal ItemIndex As Long, ByVal SubItemIndex As Long, ByVal VirtualProperty As LvwVirtualPropertyConstants, ByRef Value As Variant) ``` Requests item properties in virtual mode. ### FindVirtualItem ```vb Public Event FindVirtualItem(ByVal StartIndex As Long, ByVal SearchText As String, ByVal Partial As Boolean, ByVal Wrap As Boolean, ByRef FoundIndex As Long) ``` Finds an item in virtual mode. ### CacheVirtualItems ```vb Public Event CacheVirtualItems(ByVal FromIndex As Long, ByVal ToIndex As Long) ``` Requests caching of an item range in virtual mode. ### BeforeLabelEdit ```vb Public Event BeforeLabelEdit(ByRef Cancel As Boolean) ``` Raised before label editing begins; can be canceled. ### AfterLabelEdit ```vb Public Event AfterLabelEdit(ByRef Cancel As Boolean, ByRef NewString As String) ``` Raised after label editing ends. ### ColumnClick ```vb Public Event ColumnClick(ByVal ColumnHeader As LvwColumnHeader) ``` A column header was clicked. ### ColumnDblClick ```vb Public Event ColumnDblClick(ByVal ColumnHeader As LvwColumnHeader) ``` A column header was double-clicked. ### ColumnCheck ```vb Public Event ColumnCheck(ByVal ColumnHeader As LvwColumnHeader) ``` A column header's checkbox state changed. ### ColumnBeforeResize ```vb Public Event ColumnBeforeResize(ByVal ColumnHeader As LvwColumnHeader, ByRef Cancel As Boolean) ``` Column width is about to change; can be canceled. ### ColumnAfterResize ```vb Public Event ColumnAfterResize(ByVal ColumnHeader As LvwColumnHeader, ByRef NewWidth As Single) ``` Column width change completed. ### ColumnDividerDblClick ```vb Public Event ColumnDividerDblClick(ByVal ColumnHeader As LvwColumnHeader, ByRef Cancel As Boolean) ``` A column divider was double-clicked. ### ColumnBeforeDrag ```vb Public Event ColumnBeforeDrag(ByVal ColumnHeader As LvwColumnHeader) ``` A column header drag is starting. ### ColumnAfterDrag ```vb Public Event ColumnAfterDrag(ByVal ColumnHeader As LvwColumnHeader, ByVal NewPosition As Long, ByRef Cancel As Boolean) ``` A column header drag completed. ### ColumnDropDown ```vb Public Event ColumnDropDown(ByVal ColumnHeader As LvwColumnHeader) ``` A column header dropdown button was clicked. ### ColumnChevronPushed ```vb Public Event ColumnChevronPushed(ByVal ColumnHeader As LvwColumnHeader) ``` A column chevron button was clicked. ### ColumnFilterChanged ```vb Public Event ColumnFilterChanged(ByVal ColumnHeader As LvwColumnHeader) ``` Column filter criteria changed. ### ColumnFilterButtonClick ```vb Public Event ColumnFilterButtonClick(ByVal ColumnHeader As LvwColumnHeader, ByRef RaiseFilterChanged As Boolean, ByVal ButtonLeft As Long, ByVal ButtonTop As Long, ByVal ButtonRight As Long, ByVal ButtonBottom As Long) ``` A column filter button was clicked. ### BeforeFilterEdit ```vb Public Event BeforeFilterEdit(ByVal ColumnHeader As LvwColumnHeader, ByVal hWndFilterEdit As LongPtr) ``` Raised before a column filter edit begins. ### AfterFilterEdit ```vb Public Event AfterFilterEdit(ByVal ColumnHeader As LvwColumnHeader) ``` Raised after a column filter edit ends. ### GetEmptyMarkup ```vb Public Event GetEmptyMarkup(ByRef Text As String, ByRef Center As Boolean) ``` Requests markup text when the list is empty. ### GroupCollapsedChanged ```vb Public Event GroupCollapsedChanged(ByVal Group As LvwGroup) ``` A group's collapsed state changed. ### GroupSelectedChanged ```vb Public Event GroupSelectedChanged(ByVal Group As LvwGroup) ``` A group's selection state changed. ### GroupLinkClick ```vb Public Event GroupLinkClick(ByVal Group As LvwGroup) ``` A group link was clicked. ### BeginMarqueeSelection ```vb Public Event BeginMarqueeSelection(ByRef Cancel As Boolean) ``` Marquee selection is starting; can be canceled. ### BeforeScroll ```vb Public Event BeforeScroll(ByVal DeltaX As Single, ByVal DeltaY As Single) ``` Raised before scrolling begins. ### AfterScroll ```vb Public Event AfterScroll(ByVal DeltaX As Single, ByVal DeltaY As Single) ``` Raised after scrolling completes. ### DropFiles ```vb Public Event DropFiles(ByRef FileList As Variant, ByVal X As Single, ByVal Y As Single) ``` Raised when files are dropped onto the control. ### ContextMenu ```vb Public Event ContextMenu(ByVal X As Single, ByVal Y As Single) ``` Raised when a context menu is requested. ### PreviewKeyDown ```vb Public Event PreviewKeyDown(ByVal KeyCode As Integer, ByRef IsInputKey As Boolean) ``` Key preview event; raised before KeyDown. ### PreviewKeyUp ```vb Public Event PreviewKeyUp(ByVal KeyCode As Integer, ByRef IsInputKey As Boolean) ``` Key release preview event; raised before KeyUp. ### KeyDown ```vb Public Event KeyDown(KeyCode As Integer, Shift As Integer) ``` Key pressed. ### KeyUp ```vb Public Event KeyUp(KeyCode As Integer, Shift As Integer) ``` Key released. ### KeyPress ```vb Public Event KeyPress(KeyChar As Integer) ``` Key character. ### MouseDown ```vb Public Event MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` Mouse button pressed. ### MouseMove ```vb Public Event MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` Mouse moved. ### MouseUp ```vb Public Event MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` Mouse button released. ### MouseEnter ```vb Public Event MouseEnter() ``` Mouse entered the control. ### MouseLeave ```vb Public Event MouseLeave() ``` Mouse left the control. ### OLECompleteDrag ```vb Public Event OLECompleteDrag(Effect As Long) ``` OLE drag-and-drop completed. ### OLEDragDrop ```vb Public Event OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single) ``` OLE drag-and-drop drop. ### OLEDragOver ```vb Public Event OLEDragOver(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single, State As Integer) ``` OLE drag-and-drop hover. ### OLEGiveFeedback ```vb Public Event OLEGiveFeedback(Effect As Long, DefaultCursors As Boolean) ``` OLE give feedback. ### OLESetData ```vb Public Event OLESetData(Data As DataObject, DataFormat As Integer) ``` OLE set data. ### OLEStartDrag ```vb Public Event OLEStartDrag(Data As DataObject, AllowedEffects As Long) ``` OLE start drag. ## Sub-Objects ### LvwColumnHeader Column header object. #### Properties | Name | Signature | Description | |------|-----------|-------------| | Index | `Property Get Index() As Long` | Index. Read-only | | Key | `Property Get Key() As String` / `Property Let Key(ByVal Value As String)` | Key value | | Tag | `Property Get Tag() As Variant` / `Property Let Tag(ByVal Value As Variant)` / `Property Set Tag(ByVal Value As Variant)` | Custom data | | Text | `Property Get Text() As String` / `Property Let Text(ByVal Value As String)` | Header text | | Icon | `Property Get Icon() As Variant` / `Property Let Icon(ByVal Value As Variant)` | Icon | | IconIndex | `Property Get IconIndex() As Long` | Icon index. Read-only | | Width | `Property Get Width() As Single` / `Property Let Width(ByVal Value As Single)` | Column width | | Alignment | `Property Get Alignment() As LvwColumnHeaderAlignmentConstants` / `Property Let Alignment(ByVal Value As LvwColumnHeaderAlignmentConstants)` | Alignment | | Position | `Property Get Position() As Long` / `Property Let Position(ByVal Value As Long)` | Position | | SortArrow | `Property Get SortArrow() As LvwColumnHeaderSortArrowConstants` / `Property Let SortArrow(ByVal Value As LvwColumnHeaderSortArrowConstants)` | Sort arrow | | IconOnRight | `Property Get IconOnRight() As Boolean` / `Property Let IconOnRight(ByVal Value As Boolean)` | Icon on right | | Resizable | `Property Get Resizable() As Boolean` / `Property Let Resizable(ByVal Value As Boolean)` | Whether resizable | | SplitButton | `Property Get SplitButton() As Boolean` / `Property Let SplitButton(ByVal Value As Boolean)` | Whether split button is shown | | CheckBox | `Property Get CheckBox() As Boolean` / `Property Let CheckBox(ByVal Value As Boolean)` | Whether checkbox is shown | | Checked | `Property Get Checked() As Boolean` / `Property Let Checked(ByVal Value As Boolean)` | Checkbox checked state | | Bold | `Property Get Bold() As Boolean` / `Property Let Bold(ByVal Value As Boolean)` | Whether bold | | ForeColor | `Property Get ForeColor() As OLE_COLOR` / `Property Let ForeColor(ByVal Value As OLE_COLOR)` | Foreground color | | ToolTipText | `Property Get ToolTipText() As String` / `Property Let ToolTipText(ByVal Value As String)` | ToolTip text | | ToolTipTextFilterBtn | `Property Get ToolTipTextFilterBtn() As String` / `Property Let ToolTipTextFilterBtn(ByVal Value As String)` | Filter button ToolTip | | ToolTipTextDropDown | `Property Get ToolTipTextDropDown() As String` / `Property Let ToolTipTextDropDown(ByVal Value As String)` | Dropdown button ToolTip | | FilterType | `Property Get FilterType() As LvwColumnHeaderFilterTypeConstants` / `Property Let FilterType(ByVal Value As LvwColumnHeaderFilterTypeConstants)` | Filter type | | FilterValue | `Property Get FilterValue() As Variant` / `Property Let FilterValue(ByVal Value As Variant)` | Filter value | | Left | `Property Get Left() As Single` / `Property Let Left(ByVal Value As Single)` | Left edge distance | #### Methods | Name | Signature | Description | |------|-----------|-------------| | AutoSize | `Public Sub AutoSize(ByVal Value As LvwColumnHeaderAutoSizeConstants)` | Auto size column width | | EditFilter | `Public Sub EditFilter()` | Edit filter criteria | | ClearFilter | `Public Sub ClearFilter()` | Clear filter criteria | | SubItemIndex | `Public Function SubItemIndex() As Long` | Get the corresponding sub-item index | ### LvwColumnHeaders Column headers collection. #### Properties | Name | Signature | Description | |------|-----------|-------------| | Item | `Property Get Item(ByVal Index As Variant) As LvwColumnHeader` | Get column header by index | | ItemFromPosition | `Property Get ItemFromPosition(ByVal Position As Long) As LvwColumnHeader` | Get column header by position | | Count | `Property Get Count() As Long` | Column header count. Read-only | #### Methods | Name | Signature | Description | |------|-----------|-------------| | Add | `Public Function Add(Optional ByVal Index As Long, Optional ByVal Key As String, Optional ByVal Text As String, Optional ByVal Width As Variant, Optional ByVal Alignment As LvwColumnHeaderAlignmentConstants, Optional ByVal Icon As Variant) As LvwColumnHeader` | Add column header | | Exists | `Public Function Exists(ByVal Index As Variant) As Boolean` | Check if column header exists | | Clear | `Public Sub Clear()` | Clear all column headers | | Remove | `Public Sub Remove(ByVal Index As Variant)` | Remove column header | | NewEnum | `Public Function NewEnum() As IEnumVARIANT` | Enumerator | ### LvwListItem List item object. #### Properties | Name | Signature | Description | |------|-----------|-------------| | Index | `Property Get Index() As Long` | Index. Read-only | | Key | `Property Get Key() As String` / `Property Let Key(ByVal Value As String)` | Key value | | Tag | `Property Get Tag() As Variant` / `Property Let Tag(ByVal Value As Variant)` / `Property Set Tag(ByVal Value As Variant)` | Custom data | | Text | `Property Get Text() As String` / `Property Let Text(ByVal Value As String)` | Text | | Icon | `Property Get Icon() As Variant` / `Property Let Icon(ByVal Value As Variant)` | Large icon | | IconIndex | `Property Get IconIndex() As Long` | Large icon index. Read-only | | SmallIcon | `Property Get SmallIcon() As Variant` / `Property Let SmallIcon(ByVal Value As Variant)` | Small icon | | SmallIconIndex | `Property Get SmallIconIndex() As Long` | Small icon index. Read-only | | Indentation | `Property Get Indentation() As Long` / `Property Let Indentation(ByVal Value As Long)` | Indentation | | Selected | `Property Get Selected() As Boolean` / `Property Let Selected(ByVal Value As Boolean)` | Whether selected | | Checked | `Property Get Checked() As Boolean` / `Property Let Checked(ByVal Value As Boolean)` | Checkbox state | | Ghosted | `Property Get Ghosted() As Boolean` / `Property Let Ghosted(ByVal Value As Boolean)` | Whether ghosted | | Hot | `Property Get Hot() As Boolean` / `Property Let Hot(ByVal Value As Boolean)` | Whether hot | | Bold | `Property Get Bold() As Boolean` / `Property Let Bold(ByVal Value As Boolean)` | Whether bold | | ForeColor | `Property Get ForeColor() As OLE_COLOR` / `Property Let ForeColor(ByVal Value As OLE_COLOR)` | Foreground color | | ToolTipText | `Property Get ToolTipText() As String` / `Property Let ToolTipText(ByVal Value As String)` | ToolTip text | | Left | `Property Get Left() As Single` / `Property Let Left(ByVal Value As Single)` | Left edge distance | | Top | `Property Get Top() As Single` / `Property Let Top(ByVal Value As Single)` | Top edge distance | | Width | `Property Get Width() As Single` / `Property Let Width(ByVal Value As Single)` | Width | | Height | `Property Get Height() As Single` / `Property Let Height(ByVal Value As Single)` | Height | | Visible | `Property Get Visible() As Boolean` | Whether visible. Read-only | | TileViewIndices | `Property Get TileViewIndices() As Variant` / `Property Let TileViewIndices(ByVal ArgList As Variant)` | Tile view sub-item column indices | | Group | `Property Get Group() As LvwGroup` / `Property Let Group(ByVal Value As LvwGroup)` / `Property Set Group(ByVal Value As LvwGroup)` | Owning group | | WorkArea | `Property Get WorkArea() As LvwWorkArea` | Owning work area. Read-only | | ListSubItems | `Property Get ListSubItems() As LvwListSubItems` | Sub-items collection. Read-only | | SubItems | `Property Get SubItems(ByVal Index As Integer) As String` / `Property Let SubItems(ByVal Index As Integer, ByVal Value As String)` | Get or set sub-item text by index | #### Methods | Name | Signature | Description | |------|-----------|-------------| | EnsureVisible | `Public Sub EnsureVisible()` | Ensure item is visible | | CreateDragImage | `Public Function CreateDragImage(Optional ByRef X As Single, Optional ByRef Y As Single) As LongPtr` | Create drag image | ### LvwListItems List items collection. #### Properties | Name | Signature | Description | |------|-----------|-------------| | Item | `Property Get Item(ByVal Index As Variant) As LvwListItem` | Get list item by index | | Count | `Property Get Count() As Long` | List item count. Read-only | #### Methods | Name | Signature | Description | |------|-----------|-------------| | Add | `Public Function Add(Optional ByVal Index As Long, Optional ByVal Key As String, Optional ByVal Text As String, Optional ByVal Icon As Variant, Optional ByVal SmallIcon As Variant) As LvwListItem` | Add list item | | Exists | `Public Function Exists(ByVal Index As Variant) As Boolean` | Check if list item exists | | Clear | `Public Sub Clear()` | Clear all list items | | Remove | `Public Sub Remove(ByVal Index As Variant)` | Remove list item | | NewEnum | `Public Function NewEnum() As IEnumVARIANT` | Enumerator | ### LvwListSubItem List sub-item object. #### Properties | Name | Signature | Description | |------|-----------|-------------| | Index | `Property Get Index() As Long` | Index. Read-only | | Key | `Property Get Key() As String` | Key value. Read-only | | Tag | `Property Get Tag() As Variant` / `Property Let Tag(ByVal Value As Variant)` / `Property Set Tag(ByVal Value As Variant)` | Custom data | | Text | `Property Get Text() As String` / `Property Let Text(ByVal Value As String)` | Text | | ReportIcon | `Property Get ReportIcon() As Variant` / `Property Let ReportIcon(ByVal Value As Variant)` | Report view icon | | ReportIconIndex | `Property Get ReportIconIndex() As Long` | Report view icon index. Read-only | | Bold | `Property Get Bold() As Boolean` / `Property Let Bold(ByVal Value As Boolean)` | Whether bold | | ForeColor | `Property Get ForeColor() As OLE_COLOR` / `Property Let ForeColor(ByVal Value As OLE_COLOR)` | Foreground color | | ToolTipText | `Property Get ToolTipText() As String` / `Property Let ToolTipText(ByVal Value As String)` | ToolTip text | | Left | `Property Get Left() As Single` / `Property Let Left(ByVal Value As Single)` | Left edge distance | | Top | `Property Get Top() As Single` / `Property Let Top(ByVal Value As Single)` | Top edge distance | | Width | `Property Get Width() As Single` / `Property Let Width(ByVal Value As Single)` | Width | | Height | `Property Get Height() As Single` / `Property Let Height(ByVal Value As Single)` | Height | ### LvwListSubItems List sub-items collection. #### Properties | Name | Signature | Description | |------|-----------|-------------| | Item | `Property Get Item(ByVal Index As Variant) As LvwListSubItem` | Get sub-item by index | | Count | `Property Get Count() As Long` | Sub-item count. Read-only | #### Methods | Name | Signature | Description | |------|-----------|-------------| | Add | `Public Function Add(Optional ByVal Index As Long, Optional ByVal Key As String, Optional ByVal Text As String, Optional ByVal ReportIcon As Variant, Optional ByVal ToolTipText As String) As LvwListSubItem` | Add sub-item | | Exists | `Public Function Exists(ByVal Index As Variant) As Boolean` | Check if sub-item exists | | Clear | `Public Sub Clear()` | Clear all sub-items | | Remove | `Public Sub Remove(ByVal Index As Variant)` | Remove sub-item | | NewEnum | `Public Function NewEnum() As IEnumVARIANT` | Enumerator | ### LvwGroup Group object. #### Properties | Name | Signature | Description | |------|-----------|-------------| | Index | `Property Get Index() As Long` | Index. Read-only | | Key | `Property Get Key() As String` / `Property Let Key(ByVal Value As String)` | Key value | | Tag | `Property Get Tag() As Variant` / `Property Let Tag(ByVal Value As Variant)` / `Property Set Tag(ByVal Value As Variant)` | Custom data | | ID | `Property Get ID() As Long` | Group ID. Read-only | | Header | `Property Get Header() As String` / `Property Let Header(ByVal Value As String)` | Group header | | HeaderAlignment | `Property Get HeaderAlignment() As LvwGroupHeaderAlignmentConstants` / `Property Let HeaderAlignment(ByVal Value As LvwGroupHeaderAlignmentConstants)` | Header alignment | | Footer | `Property Get Footer() As String` / `Property Let Footer(ByVal Value As String)` | Group footer | | FooterAlignment | `Property Get FooterAlignment() As LvwGroupFooterAlignmentConstants` / `Property Let FooterAlignment(ByVal Value As LvwGroupFooterAlignmentConstants)` | Footer alignment | | Hint | `Property Get Hint() As String` / `Property Let Hint(ByVal Value As String)` | Hint text | | Link | `Property Get Link() As String` / `Property Let Link(ByVal Value As String)` | Link text | | SubsetLink | `Property Get SubsetLink() As String` / `Property Let SubsetLink(ByVal Value As String)` | Subset link text | | Collapsible | `Property Get Collapsible() As Boolean` / `Property Let Collapsible(ByVal Value As Boolean)` | Whether collapsible | | Collapsed | `Property Get Collapsed() As Boolean` / `Property Let Collapsed(ByVal Value As Boolean)` | Whether collapsed | | ShowHeader | `Property Get ShowHeader() As Boolean` / `Property Let ShowHeader(ByVal Value As Boolean)` | Whether header is shown | | Selected | `Property Get Selected() As Boolean` / `Property Let Selected(ByVal Value As Boolean)` | Whether selected | | Subseted | `Property Get Subseted() As Boolean` / `Property Let Subseted(ByVal Value As Boolean)` | Whether subsetted | | SubsetLinkSelected | `Property Get SubsetLinkSelected() As Boolean` / `Property Let SubsetLinkSelected(ByVal Value As Boolean)` | Whether subset link is selected | | Icon | `Property Get Icon() As Variant` / `Property Let Icon(ByVal Value As Variant)` | Icon | | IconIndex | `Property Get IconIndex() As Long` | Icon index. Read-only | | Position | `Property Get Position() As Long` / `Property Let Position(ByVal Value As Long)` | Position | | Left | `Property Get Left() As Single` / `Property Let Left(ByVal Value As Single)` | Left edge distance | | Top | `Property Get Top() As Single` / `Property Let Top(ByVal Value As Single)` | Top edge distance | | Width | `Property Get Width() As Single` / `Property Let Width(ByVal Value As Single)` | Width | | Height | `Property Get Height() As Single` / `Property Let Height(ByVal Value As Single)` | Height | | ListItemCount | `Property Get ListItemCount() As Long` | List item count. Read-only | | ListItemIndices | `Property Get ListItemIndices() As Collection` | List item index collection. Read-only | ### LvwGroups Groups collection. #### Properties | Name | Signature | Description | |------|-----------|-------------| | Item | `Property Get Item(ByVal Index As Variant) As LvwGroup` | Get group by index | | Count | `Property Get Count() As Long` | Group count. Read-only | | Sorted | `Property Get Sorted() As Boolean` / `Property Let Sorted(ByVal Value As Boolean)` | Whether sorted | | SortOrder | `Property Get SortOrder() As LvwSortOrderConstants` / `Property Let SortOrder(ByVal Value As LvwSortOrderConstants)` | Sort order | | SortType | `Property Get SortType() As LvwSortTypeConstants` / `Property Let SortType(ByVal Value As LvwSortTypeConstants)` | Sort type | #### Methods | Name | Signature | Description | |------|-----------|-------------| | Add | `Public Function Add(Optional ByVal Index As Long, Optional ByVal Key As String, Optional ByVal Header As String, Optional ByVal HeaderAlignment As LvwGroupHeaderAlignmentConstants, Optional ByVal Footer As String, Optional ByVal FooterAlignment As LvwGroupFooterAlignmentConstants) As LvwGroup` | Add group | | Exists | `Public Function Exists(ByVal Index As Variant) As Boolean` | Check if group exists | | Clear | `Public Sub Clear()` | Clear all groups | | Remove | `Public Sub Remove(ByVal Index As Variant)` | Remove group | | NewEnum | `Public Function NewEnum() As IEnumVARIANT` | Enumerator | ### LvwVirtualListItem Virtual list item object. #### Properties | Name | Signature | Description | |------|-----------|-------------| | Index | `Property Get Index() As Long` | Index. Read-only | | Text | `Property Get Text() As String` | Text. Read-only | | Indentation | `Property Get Indentation() As Long` | Indentation. Read-only | | Selected | `Property Get Selected() As Boolean` / `Property Let Selected(ByVal Value As Boolean)` | Whether selected | | Checked | `Property Get Checked() As Boolean` | Checkbox state. Read-only | | Hot | `Property Get Hot() As Boolean` / `Property Let Hot(ByVal Value As Boolean)` | Whether hot | | Left | `Property Get Left() As Single` / `Property Let Left(ByVal Value As Single)` | Left edge distance | | Top | `Property Get Top() As Single` / `Property Let Top(ByVal Value As Single)` | Top edge distance | | Width | `Property Get Width() As Single` / `Property Let Width(ByVal Value As Single)` | Width | | Height | `Property Get Height() As Single` / `Property Let Height(ByVal Value As Single)` | Height | | Visible | `Property Get Visible() As Boolean` | Whether visible. Read-only | | SubItems | `Property Get SubItems(ByVal Index As Integer) As String` | Get sub-item text by index. Read-only | #### Methods | Name | Signature | Description | |------|-----------|-------------| | EnsureVisible | `Public Sub EnsureVisible()` | Ensure item is visible | | CreateDragImage | `Public Function CreateDragImage(Optional ByRef X As Single, Optional ByRef Y As Single) As LongPtr` | Create drag image | ### LvwVirtualListItems Virtual list items collection. #### Properties | Name | Signature | Description | |------|-----------|-------------| | Item | `Property Get Item(ByVal Index As Long) As LvwVirtualListItem` | Get virtual list item by index | | Count | `Property Get Count() As Long` | Virtual list item count. Read-only | #### Methods | Name | Signature | Description | |------|-----------|-------------| | Exists | `Public Function Exists(ByVal Index As Long) As Boolean` | Check if virtual list item exists | | NewEnum | `Public Function NewEnum() As IEnumVARIANT` | Enumerator | ### LvwWorkArea Work area object. #### Properties | Name | Signature | Description | |------|-----------|-------------| | Index | `Property Get Index() As Long` | Index. Read-only | | Left | `Property Get Left() As Single` / `Property Let Left(ByVal Value As Single)` | Left edge distance | | Top | `Property Get Top() As Single` / `Property Let Top(ByVal Value As Single)` | Top edge distance | | Width | `Property Get Width() As Single` / `Property Let Width(ByVal Value As Single)` | Width | | Height | `Property Get Height() As Single` / `Property Let Height(ByVal Value As Single)` | Height | | ListItemIndices | `Property Get ListItemIndices() As Collection` | List item index collection in the work area. Read-only | ### LvwWorkAreas Work areas collection. #### Properties | Name | Signature | Description | |------|-----------|-------------| | Item | `Property Get Item(ByVal Index As Long) As LvwWorkArea` | Get work area by index | | Count | `Property Get Count() As Long` | Work area count. Read-only | #### Methods | Name | Signature | Description | |------|-----------|-------------| | Add | `Public Function Add(ByVal Left As Single, ByVal Top As Single, ByVal Width As Single, ByVal Height As Single, Optional ByVal Index As Long) As LvwWorkArea` | Add work area | | Exists | `Public Function Exists(ByVal Index As Long) As Boolean` | Check if work area exists | | Clear | `Public Sub Clear()` | Clear all work areas | | Remove | `Public Sub Remove(ByVal Index As Long)` | Remove work area | | NewEnum | `Public Function NewEnum() As IEnumVARIANT` | Enumerator | ## Code Examples ### Report View Basic Usage ```vb ' Set report view ListView1.View = LvwViewReport ' Add column headers With ListView1.ColumnHeaders .Add , , "Name", 120 .Add , , "Age", 60, LvwColumnHeaderAlignmentCenter .Add , , "City", 100 End With ' Add list items Dim li As LvwListItem Set li = ListView1.ListItems.Add(, , "Zhang San") li.SubItems(1) = "28" li.SubItems(2) = "Beijing" Set li = ListView1.ListItems.Add(, , "Li Si") li.SubItems(1) = "35" li.SubItems(2) = "Shanghai" ``` ### Group View ```vb ' Enable grouping ListView1.GroupView = True ListView1.View = LvwViewReport ' Add groups Dim grp1 As LvwGroup, grp2 As LvwGroup Set grp1 = ListView1.Groups.Add(, , "Group 1") Set grp2 = ListView1.Groups.Add(, , "Group 2") ' Assign items to groups Set ListView1.ListItems(1).Group = grp1 Set ListView1.ListItems(2).Group = grp2 ``` ### Virtual Mode ```vb ' Enable virtual mode ListView1.VirtualMode = True ListView1.VirtualItemCount = 10000 ' Provide data in the GetVirtualItem event Private Sub ListView1_GetVirtualItem(ByVal ItemIndex As Long, _ ByVal SubItemIndex As Long, _ ByVal VirtualProperty As LvwVirtualPropertyConstants, _ ByRef Value As Variant) If VirtualProperty = LvwVirtualPropertyText Then If SubItemIndex = 0 Then Value = "Item " & ItemIndex Else Value = "Sub " & SubItemIndex End If End If End Sub ``` ### Sorting and Filtering ```vb ' Sort ListView1.SortKey = 0 ListView1.SortOrder = LvwSortOrderAscending ListView1.SortType = LvwSortTypeText ListView1.Sorted = True ' Set sort arrow ListView1.ColumnHeaders(1).SortArrow = LvwColumnHeaderSortArrowDown ' Enable column filtering ListView1.UseColumnFilterBar = True ``` --- --- url: /demo/markdown-examples.md --- # Markdown Extension Examples This page demonstrates some of the built-in markdown extensions provided by VitePress. ## Syntax Highlighting VitePress provides Syntax Highlighting powered by [Shiki](https://github.com/shikijs/shiki), with additional features like line-highlighting: **Input** ````md ```js{4} export default { data () { return { msg: 'Highlighted!' } } } ``` ```` **Output** ```js{4} export default { data () { return { msg: 'Highlighted!' } } } ``` ## Custom Containers **Input** ```md ::: info This is an info box. ::: ::: tip This is a tip. ::: ::: warning This is a warning. ::: ::: danger This is a dangerous warning. ::: ::: details This is a details block. ::: ``` **Output** ::: info This is an info box. ::: ::: tip This is a tip. ::: ::: warning This is a warning. ::: ::: danger This is a dangerous warning. ::: ::: details This is a details block. ::: ## More Check out the documentation for the [full list of markdown extensions](https://vitepress.dev/guide/markdown). --- --- url: /zh/packages/vbccr/system/mciwnd.md description: MCIWnd 控件（MCIWnd） - VBCCR 开发手册，基于源码的完整 API 参考 --- # MCIWnd 控件（MCIWnd） 封装 MCIWnd 窗口类，提供多媒体设备控制和音视频播放功能。 ## 枚举 ### MciFormatConstants | 常量 | 值 | 说明 | |------|-----|------| | MciFormatMpeg | 0 | MPEG 格式 | | MciFormatAvi | 1 | AVI 格式 | | MciFormatMidi | 2 | MIDI 格式 | | MciFormatWave | 3 | Wave 格式 | | MciFormatOle | 4 | OLE 存储 | | MciFormatOleStream | 5 | OLE 流 | | MciFormatRiff | 6 | RIFF 格式 | | MciFormatExif | 7 | Exif 格式 | | MciFormatJpeg | 8 | JPEG 格式 | | MciFormatPng | 9 | PNG 格式 | | MciFormatGif | 10 | GIF 格式 | ### MciModeConstants | 常量 | 值 | 说明 | |------|-----|------| | MciModeNotOpen | 524 | 设备未打开 | | MciModeStop | 525 | 设备已停止 | | MciModePlay | 526 | 设备正在播放 | | MciModeRecord | 527 | 设备正在录制 | | MciModeSeek | 528 | 设备正在定位 | | MciModePause | 529 | 设备已暂停 | | MciModeReady | 530 | 设备就绪 | ### MciNotifyConstants | 常量 | 值 | 说明 | |------|-----|------| | MciNotifyAborted | \&H4 | 操作被中止 | | MciNotifySuperseded | \&H8 | 操作被替代 | | MciNotifySuccessful | \&H1 | 操作成功完成 | | MciNotifyFailure | \&H2 | 操作失败 | ### MciCaptionConstants | 常量 | 值 | 说明 | |------|-----|------| | MciCaptionOff | 0 | 不显示标题 | | MciCaptionFileName | 1 | 显示文件名 | | MciCaptionDevice | 2 | 显示设备名称 | | MciCaptionMode | 3 | 显示当前模式 | | MciCaptionPosition | 4 | 显示当前位置 | | MciCaptionLength | 5 | 显示媒体长度 | | MciCaptionError | 6 | 显示错误信息 | | MciCaptionInfo | 7 | 显示所有信息 | ### CCBorderStyleConstants 参见通用枚举。 ### CCMousePointerConstants 参见通用枚举。 ## 属性 ### Command ```vb Property Let Command(ByVal Value As String) ``` 向 MCI 设备发送命令字符串。 ### CommandReturn ```vb Property Get CommandReturn() As String ``` 返回最后一次 MCI 命令的返回结果。只读。 ### FileName ```vb Property Get FileName() As String Property Let FileName(ByVal Value As String) ``` 要打开或加载的媒体文件名。 ### DeviceAlias ```vb Property Get DeviceAlias() As String ``` 返回设备的别名。只读。 ### DeviceID ```vb Property Get DeviceID() As Long ``` 返回设备的 ID。只读。 ### Device ```vb Property Get Device() As String ``` 返回当前设备类型。只读。 ### NewDevice ```vb Property Let NewDevice(ByVal Value As String) ``` 设置要打开的新设备类型。只写。 ### Error ```vb Property Get Error() As Long ``` 返回最近的 MCI 错误代码。只读。 ### ErrorString ```vb Property Get ErrorString() As String ``` 返回最近的 MCI 错误描述字符串。只读。 ### TimeFormat ```vb Property Get TimeFormat() As MciFormatConstants Property Let TimeFormat(ByVal Value As MciFormatConstants) ``` 时间格式。 ### Mode ```vb Property Get Mode() As MciModeConstants ``` 返回当前设备模式。只读。 ### ModeString ```vb Property Get ModeString() As String ``` 返回当前设备模式的字符串描述。只读。 ### Position ```vb Property Get Position() As Long ``` 返回当前位置。只读。 ### PositionString ```vb Property Get PositionString() As String ``` 返回当前位置的字符串表示。只读。 ### StartPosition ```vb Property Get StartPosition() As Long ``` 返回起始位置。只读。 ### Length ```vb Property Get Length() As Long ``` 返回媒体总长度。只读。 ### EndPosition ```vb Property Get EndPosition() As Long ``` 返回结束位置。只读。 ### Volume ```vb Property Get Volume() As Long Property Let Volume(ByVal Value As Long) ``` 音量。 ### Speed ```vb Property Get Speed() As Long Property Let Speed(ByVal Value As Long) ``` 播放速度。 ### Repeat ```vb Property Get Repeat() As Boolean Property Let Repeat(ByVal Value As Boolean) ``` 是否循环播放。 ### ErrorDlg ```vb Property Get ErrorDlg() As Boolean Property Let ErrorDlg(ByVal Value As Boolean) ``` 是否显示错误对话框。 ### Record ```vb Property Get Record() As Boolean Property Let Record(ByVal Value As Boolean) ``` 是否处于录制模式。 ### Playbar ```vb Property Get Playbar() As Boolean Property Let Playbar(ByVal Value As Boolean) ``` 是否显示播放条。 ### Menu ```vb Property Get Menu() As Boolean Property Let Menu(ByVal Value As Boolean) ``` 是否显示菜单。 ### AllowOpen ```vb Property Get AllowOpen() As Boolean Property Let AllowOpen(ByVal Value As Boolean) ``` 是否允许通过用户界面打开文件。 ### AutoSizeWindow ```vb Property Get AutoSizeWindow() As Boolean Property Let AutoSizeWindow(ByVal Value As Boolean) ``` 是否自动调整窗口大小以适应媒体。 ### AutoSizeMovie ```vb Property Get AutoSizeMovie() As Boolean Property Let AutoSizeMovie(ByVal Value As Boolean) ``` 是否自动调整媒体大小以适应窗口。 ### TimerFreq ```vb Property Get TimerFreq() As Long Property Let TimerFreq(ByVal Value As Long) ``` 计时器频率。 ### Zoom ```vb Property Get Zoom() As Long Property Let Zoom(ByVal Value As Long) ``` 缩放比例。 ### Caption ```vb Property Get Caption() As MciCaptionConstants Property Let Caption(ByVal Value As MciCaptionConstants) ``` 标题显示模式。 ### BackColor ```vb Property Get BackColor() As OLE_COLOR Property Let BackColor(ByVal Value As OLE_COLOR) ``` 背景颜色。 ### BorderStyle ```vb Property Get BorderStyle() As CCBorderStyleConstants Property Let BorderStyle(ByVal Value As CCBorderStyleConstants) ``` 边框样式。参见通用枚举。 ### VisualStyles ```vb Property Get VisualStyles() As Boolean Property Let VisualStyles(ByVal Value As Boolean) ``` 是否启用视觉样式。 ### hWnd ```vb Property Get hWnd() As LongPtr ``` MCIWnd 控件的窗口句柄。 ### hWndUserControl ```vb Property Get hWndUserControl() As LongPtr ``` 用户控件的窗口句柄。 ### Font ```vb Property Get Font() As StdFont Property Let Font(ByVal NewFont As StdFont) Property Set Font(ByVal NewFont As StdFont) ``` 字体。 ### Enabled ```vb Property Get Enabled() As Boolean Property Let Enabled(ByVal Value As Boolean) ``` 是否可用。 ### MousePointer ```vb Property Get MousePointer() As CCMousePointerConstants Property Let MousePointer(ByVal Value As CCMousePointerConstants) ``` 鼠标指针样式。参见通用枚举。 ### MouseIcon ```vb Property Get MouseIcon() As IPictureDisp Property Let MouseIcon(ByVal Value As IPictureDisp) Property Set MouseIcon(ByVal Value As IPictureDisp) ``` 自定义鼠标图标。 ### MouseTrack ```vb Property Get MouseTrack() As Boolean Property Let MouseTrack(ByVal Value As Boolean) ``` 是否启用鼠标进入/离开跟踪。 ### RightToLeft ```vb Property Get RightToLeft() As Boolean Property Let RightToLeft(ByVal Value As Boolean) ``` 从右到左显示方向。 ### RightToLeftMode ```vb Property Get RightToLeftMode() As CCRightToLeftModeConstants Property Let RightToLeftMode(ByVal Value As CCRightToLeftModeConstants) ``` 从右到左模式。参见通用枚举。 ### Name ```vb Property Get Name() As String ``` 控件名称。只读。 ### Tag ```vb Property Get Tag() As String Property Let Tag(ByVal Value As String) ``` 自定义数据。 ### Parent ```vb Property Get Parent() As Object ``` 父对象。只读。 ### Container ```vb Property Get Container() As Object Property Set Container(ByVal Value As Object) ``` 容器对象。 ### Left ```vb Property Get Left() As Single Property Let Left(ByVal Value As Single) ``` 左边距。 ### Top ```vb Property Get Top() As Single Property Let Top(ByVal Value As Single) ``` 顶边距。 ### Width ```vb Property Get Width() As Single Property Let Width(ByVal Value As Single) ``` 宽度。 ### Height ```vb Property Get Height() As Single Property Let Height(ByVal Value As Single) ``` 高度。 ### Visible ```vb Property Get Visible() As Boolean Property Let Visible(ByVal Value As Boolean) ``` 是否可见。 ### ToolTipText ```vb Property Get ToolTipText() As String Property Let ToolTipText(ByVal Value As String) ``` 工具提示文本。 ### HelpContextID ```vb Property Get HelpContextID() As Long Property Let HelpContextID(ByVal Value As Long) ``` 帮助上下文 ID。 ### WhatsThisHelpID ```vb Property Get WhatsThisHelpID() As Long Property Let WhatsThisHelpID(ByVal Value As Long) ``` "这是什么"帮助 ID。 ### DragIcon ```vb Property Get DragIcon() As IPictureDisp Property Let DragIcon(ByVal Value As IPictureDisp) Property Set DragIcon(ByVal Value As IPictureDisp) ``` 拖拽图标。 ### DragMode ```vb Property Get DragMode() As Integer Property Let DragMode(ByVal Value As Integer) ``` 拖拽模式。 ## 方法 ### ShowOpen ```vb Public Sub ShowOpen() ``` 显示打开文件对话框。 ### ShowSave ```vb Public Sub ShowSave() ``` 显示保存文件对话框。 ### CanSave ```vb Public Function CanSave() As Boolean ``` 判断是否可以保存当前媒体。 ### Eject ```vb Public Sub Eject() ``` 弹出当前媒体。 ### CanEject ```vb Public Function CanEject() As Boolean ``` 判断设备是否支持弹出操作。 ### PlayFrom ```vb Public Sub PlayFrom(ByVal StartPosition As Long) ``` 从指定位置开始播放。 ### PlayTo ```vb Public Sub PlayTo(ByVal EndPosition As Long) ``` 播放到指定位置后停止。 ### PlayReverse ```vb Public Sub PlayReverse() ``` 反向播放。 ### CanPlay ```vb Public Function CanPlay() As Boolean ``` 判断设备是否支持播放。 ### CanRecord ```vb Public Function CanRecord() As Boolean ``` 判断设备是否支持录制。 ### CanConfig ```vb Public Function CanConfig() As Boolean ``` 判断设备是否支持配置。 ### CanWindow ```vb Public Function CanWindow() As Boolean ``` 判断设备是否支持窗口显示。 ### Drag ```vb Public Sub Drag([ByRef Action As Variant]) ``` 开始、结束或取消拖放操作。 ### SetFocus ```vb Public Sub SetFocus() ``` 将焦点移至控件。 ### ZOrder ```vb Public Sub ZOrder([ByRef Position As Variant]) ``` 设置控件的 Z 顺序。 ### OLEDrag ```vb Public Sub OLEDrag() ``` 启动 OLE 拖放操作。 ### Refresh ```vb Public Sub Refresh() ``` 强制重绘控件。 ## 事件 ### ModeChange ```vb Public Event ModeChange() ``` 设备模式发生改变时触发。 ### PositionChange ```vb Public Event PositionChange() ``` 当前位置发生改变时触发。 ### MediaChange ```vb Public Event MediaChange() ``` 当前媒体发生改变时触发。 ### Error ```vb Public Event Error() ``` 发生 MCI 错误时触发。 ### Notify ```vb Public Event Notify() ``` MCI 操作完成通知。 ### Signal ```vb Public Event Signal() ``` 收到信号时触发。 ### Click ```vb Public Event Click() ``` 单击控件时触发。 ### DblClick ```vb Public Event DblClick() ``` 双击控件时触发。 ### MouseDown ```vb Public Event MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` 按下鼠标按钮时触发。 ### MouseUp ```vb Public Event MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` 释放鼠标按钮时触发。 ### MouseMove ```vb Public Event MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` 移动鼠标时触发。 ### MouseEnter ```vb Public Event MouseEnter() ``` 鼠标进入控件时触发。 ### MouseLeave ```vb Public Event MouseLeave() ``` 鼠标离开控件时触发。 ### OLEDragDrop ```vb Public Event OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single) ``` OLE 拖放完成时触发。 ### OLEDragOver ```vb Public Event OLEDragOver(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single, State As Integer) ``` OLE 拖放经过控件时触发。 ### OLEGiveFeedback ```vb Public Event OLEGiveFeedback(Effect As Long, DefaultCursors As Boolean) ``` OLE 拖放需要更改光标时触发。 ### OLEStartDrag ```vb Public Event OLEStartDrag(Data As DataObject, AllowedEffects As Long) ``` OLE 拖放开始时触发。 ### OLECompleteDrag ```vb Public Event OLECompleteDrag(Effect As Long) ``` OLE 拖放完成时触发。 ### OLESetData ```vb Public Event OLESetData(Data As DataObject, DataFormat As Integer) ``` OLE 放置目标请求数据时触发。 ## 代码示例 ```vb ' 打开并播放 AVI 文件 MCIWnd1.FileName = "C:\video.avi" MCIWnd1.Playbar = True MCIWnd1.Command = "play" ' 录制音频 MCIWnd1.NewDevice = "waveaudio" MCIWnd1.Command = "open new" MCIWnd1.Record = True MCIWnd1.Command = "record" ``` --- --- url: /en/packages/vbccr/system/mciwnd.md description: >- MCIWnd Control - VBCCR Development Manual, Complete API Reference Based on Source Code --- # MCIWnd Control Wraps the MCIWnd window class, providing multimedia device control and audio/video playback functionality. ## Enumerations ### MciFormatConstants | Constant | Value | Description | |------|-----|------| | MciFormatMpeg | 0 | MPEG format | | MciFormatAvi | 1 | AVI format | | MciFormatMidi | 2 | MIDI format | | MciFormatWave | 3 | Wave format | | MciFormatOle | 4 | OLE storage | | MciFormatOleStream | 5 | OLE stream | | MciFormatRiff | 6 | RIFF format | | MciFormatExif | 7 | Exif format | | MciFormatJpeg | 8 | JPEG format | | MciFormatPng | 9 | PNG format | | MciFormatGif | 10 | GIF format | ### MciModeConstants | Constant | Value | Description | |------|-----|------| | MciModeNotOpen | 524 | Device not open | | MciModeStop | 525 | Device stopped | | MciModePlay | 526 | Device playing | | MciModeRecord | 527 | Device recording | | MciModeSeek | 528 | Device seeking | | MciModePause | 529 | Device paused | | MciModeReady | 530 | Device ready | ### MciNotifyConstants | Constant | Value | Description | |------|-----|------| | MciNotifyAborted | \&H4 | Operation aborted | | MciNotifySuperseded | \&H8 | Operation superseded | | MciNotifySuccessful | \&H1 | Operation completed successfully | | MciNotifyFailure | \&H2 | Operation failed | ### MciCaptionConstants | Constant | Value | Description | |------|-----|------| | MciCaptionOff | 0 | No caption displayed | | MciCaptionFileName | 1 | Display file name | | MciCaptionDevice | 2 | Display device name | | MciCaptionMode | 3 | Display current mode | | MciCaptionPosition | 4 | Display current position | | MciCaptionLength | 5 | Display media length | | MciCaptionError | 6 | Display error information | | MciCaptionInfo | 7 | Display all information | ### CCBorderStyleConstants See Common Enumerations. ### CCMousePointerConstants See Common Enumerations. ## Properties ### Command ```vb Property Let Command(ByVal Value As String) ``` Sends a command string to the MCI device. ### CommandReturn ```vb Property Get CommandReturn() As String ``` Returns the result of the last MCI command. Read-only. ### FileName ```vb Property Get FileName() As String Property Let FileName(ByVal Value As String) ``` Media file name to open or load. ### DeviceAlias ```vb Property Get DeviceAlias() As String ``` Returns the device alias. Read-only. ### DeviceID ```vb Property Get DeviceID() As Long ``` Returns the device ID. Read-only. ### Device ```vb Property Get Device() As String ``` Returns the current device type. Read-only. ### NewDevice ```vb Property Let NewDevice(ByVal Value As String) ``` Sets the new device type to open. Write-only. ### Error ```vb Property Get Error() As Long ``` Returns the most recent MCI error code. Read-only. ### ErrorString ```vb Property Get ErrorString() As String ``` Returns the most recent MCI error description string. Read-only. ### TimeFormat ```vb Property Get TimeFormat() As MciFormatConstants Property Let TimeFormat(ByVal Value As MciFormatConstants) ``` Time format. ### Mode ```vb Property Get Mode() As MciModeConstants ``` Returns the current device mode. Read-only. ### ModeString ```vb Property Get ModeString() As String ``` Returns the string description of the current device mode. Read-only. ### Position ```vb Property Get Position() As Long ``` Returns the current position. Read-only. ### PositionString ```vb Property Get PositionString() As String ``` Returns the string representation of the current position. Read-only. ### StartPosition ```vb Property Get StartPosition() As Long ``` Returns the start position. Read-only. ### Length ```vb Property Get Length() As Long ``` Returns the total media length. Read-only. ### EndPosition ```vb Property Get EndPosition() As Long ``` Returns the end position. Read-only. ### Volume ```vb Property Get Volume() As Long Property Let Volume(ByVal Value As Long) ``` Volume level. ### Speed ```vb Property Get Speed() As Long Property Let Speed(ByVal Value As Long) ``` Playback speed. ### Repeat ```vb Property Get Repeat() As Boolean Property Let Repeat(ByVal Value As Boolean) ``` Whether to loop playback. ### ErrorDlg ```vb Property Get ErrorDlg() As Boolean Property Let ErrorDlg(ByVal Value As Boolean) ``` Whether to display error dialogs. ### Record ```vb Property Get Record() As Boolean Property Let Record(ByVal Value As Boolean) ``` Whether in recording mode. ### Playbar ```vb Property Get Playbar() As Boolean Property Let Playbar(ByVal Value As Boolean) ``` Whether to display the playbar. ### Menu ```vb Property Get Menu() As Boolean Property Let Menu(ByVal Value As Boolean) ``` Whether to display the menu. ### AllowOpen ```vb Property Get AllowOpen() As Boolean Property Let AllowOpen(ByVal Value As Boolean) ``` Whether to allow opening files through the user interface. ### AutoSizeWindow ```vb Property Get AutoSizeWindow() As Boolean Property Let AutoSizeWindow(ByVal Value As Boolean) ``` Whether to automatically resize the window to fit the media. ### AutoSizeMovie ```vb Property Get AutoSizeMovie() As Boolean Property Let AutoSizeMovie(ByVal Value As Boolean) ``` Whether to automatically resize the media to fit the window. ### TimerFreq ```vb Property Get TimerFreq() As Long Property Let TimerFreq(ByVal Value As Long) ``` Timer frequency. ### Zoom ```vb Property Get Zoom() As Long Property Let Zoom(ByVal Value As Long) ``` Zoom ratio. ### Caption ```vb Property Get Caption() As MciCaptionConstants Property Let Caption(ByVal Value As MciCaptionConstants) ``` Caption display mode. ### BackColor ```vb Property Get BackColor() As OLE_COLOR Property Let BackColor(ByVal Value As OLE_COLOR) ``` Background color. ### BorderStyle ```vb Property Get BorderStyle() As CCBorderStyleConstants Property Let BorderStyle(ByVal Value As CCBorderStyleConstants) ``` Border style. See Common Enumerations. ### VisualStyles ```vb Property Get VisualStyles() As Boolean Property Let VisualStyles(ByVal Value As Boolean) ``` Whether visual styles are enabled. ### hWnd ```vb Property Get hWnd() As LongPtr ``` Window handle of the MCIWnd control. ### hWndUserControl ```vb Property Get hWndUserControl() As LongPtr ``` Window handle of the user control. ### Font ```vb Property Get Font() As StdFont Property Let Font(ByVal NewFont As StdFont) Property Set Font(ByVal NewFont As StdFont) ``` Font. ### Enabled ```vb Property Get Enabled() As Boolean Property Let Enabled(ByVal Value As Boolean) ``` Whether the control is enabled. ### MousePointer ```vb Property Get MousePointer() As CCMousePointerConstants Property Let MousePointer(ByVal Value As CCMousePointerConstants) ``` Mouse pointer style. See Common Enumerations. ### MouseIcon ```vb Property Get MouseIcon() As IPictureDisp Property Let MouseIcon(ByVal Value As IPictureDisp) Property Set MouseIcon(ByVal Value As IPictureDisp) ``` Custom mouse icon. ### MouseTrack ```vb Property Get MouseTrack() As Boolean Property Let MouseTrack(ByVal Value As Boolean) ``` Whether mouse enter/leave tracking is enabled. ### RightToLeft ```vb Property Get RightToLeft() As Boolean Property Let RightToLeft(ByVal Value As Boolean) ``` Right-to-left display direction. ### RightToLeftMode ```vb Property Get RightToLeftMode() As CCRightToLeftModeConstants Property Let RightToLeftMode(ByVal Value As CCRightToLeftModeConstants) ``` Right-to-left mode. See Common Enumerations. ### Name ```vb Property Get Name() As String ``` Control name. Read-only. ### Tag ```vb Property Get Tag() As String Property Let Tag(ByVal Value As String) ``` Custom data. ### Parent ```vb Property Get Parent() As Object ``` Parent object. Read-only. ### Container ```vb Property Get Container() As Object Property Set Container(ByVal Value As Object) ``` Container object. ### Left ```vb Property Get Left() As Single Property Let Left(ByVal Value As Single) ``` Left margin. ### Top ```vb Property Get Top() As Single Property Let Top(ByVal Value As Single) ``` Top margin. ### Width ```vb Property Get Width() As Single Property Let Width(ByVal Value As Single) ``` Width. ### Height ```vb Property Get Height() As Single Property Let Height(ByVal Value As Single) ``` Height. ### Visible ```vb Property Get Visible() As Boolean Property Let Visible(ByVal Value As Boolean) ``` Whether the control is visible. ### ToolTipText ```vb Property Get ToolTipText() As String Property Let ToolTipText(ByVal Value As String) ``` Tooltip text. ### HelpContextID ```vb Property Get HelpContextID() As Long Property Let HelpContextID(ByVal Value As Long) ``` Help context ID. ### WhatsThisHelpID ```vb Property Get WhatsThisHelpID() As Long Property Let WhatsThisHelpID(ByVal Value As Long) ``` "What's This" Help ID. ### DragIcon ```vb Property Get DragIcon() As IPictureDisp Property Let DragIcon(ByVal Value As IPictureDisp) Property Set DragIcon(ByVal Value As IPictureDisp) ``` Drag icon. ### DragMode ```vb Property Get DragMode() As Integer Property Let DragMode(ByVal Value As Integer) ``` Drag mode. ## Methods ### ShowOpen ```vb Public Sub ShowOpen() ``` Displays the Open File dialog. ### ShowSave ```vb Public Sub ShowSave() ``` Displays the Save File dialog. ### CanSave ```vb Public Function CanSave() As Boolean ``` Determines whether the current media can be saved. ### Eject ```vb Public Sub Eject() ``` Ejects the current media. ### CanEject ```vb Public Function CanEject() As Boolean ``` Determines whether the device supports the eject operation. ### PlayFrom ```vb Public Sub PlayFrom(ByVal StartPosition As Long) ``` Starts playback from the specified position. ### PlayTo ```vb Public Sub PlayTo(ByVal EndPosition As Long) ``` Plays to the specified position and stops. ### PlayReverse ```vb Public Sub PlayReverse() ``` Plays in reverse. ### CanPlay ```vb Public Function CanPlay() As Boolean ``` Determines whether the device supports playback. ### CanRecord ```vb Public Function CanRecord() As Boolean ``` Determines whether the device supports recording. ### CanConfig ```vb Public Function CanConfig() As Boolean ``` Determines whether the device supports configuration. ### CanWindow ```vb Public Function CanWindow() As Boolean ``` Determines whether the device supports window display. ### Drag ```vb Public Sub Drag([ByRef Action As Variant]) ``` Starts, ends, or cancels a drag operation. ### SetFocus ```vb Public Sub SetFocus() ``` Moves focus to the control. ### ZOrder ```vb Public Sub ZOrder([ByRef Position As Variant]) ``` Sets the Z-order of the control. ### OLEDrag ```vb Public Sub OLEDrag() ``` Initiates an OLE drag-and-drop operation. ### Refresh ```vb Public Sub Refresh() ``` Forces a repaint of the control. ## Events ### ModeChange ```vb Public Event ModeChange() ``` Fired when the device mode changes. ### PositionChange ```vb Public Event PositionChange() ``` Fired when the current position changes. ### MediaChange ```vb Public Event MediaChange() ``` Fired when the current media changes. ### Error ```vb Public Event Error() ``` Fired when an MCI error occurs. ### Notify ```vb Public Event Notify() ``` MCI operation completion notification. ### Signal ```vb Public Event Signal() ``` Fired when a signal is received. ### Click ```vb Public Event Click() ``` Fired when the control is clicked. ### DblClick ```vb Public Event DblClick() ``` Fired when the control is double-clicked. ### MouseDown ```vb Public Event MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` Fired when a mouse button is pressed. ### MouseUp ```vb Public Event MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` Fired when a mouse button is released. ### MouseMove ```vb Public Event MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` Fired when the mouse is moved. ### MouseEnter ```vb Public Event MouseEnter() ``` Fired when the mouse enters the control. ### MouseLeave ```vb Public Event MouseLeave() ``` Fired when the mouse leaves the control. ### OLEDragDrop ```vb Public Event OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single) ``` Fired when an OLE drag-and-drop operation is completed. ### OLEDragOver ```vb Public Event OLEDragOver(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single, State As Integer) ``` Fired when an OLE drag-and-drop operation passes over the control. ### OLEGiveFeedback ```vb Public Event OLEGiveFeedback(Effect As Long, DefaultCursors As Boolean) ``` Fired when the cursor needs to be changed during an OLE drag-and-drop operation. ### OLEStartDrag ```vb Public Event OLEStartDrag(Data As DataObject, AllowedEffects As Long) ``` Fired when an OLE drag-and-drop operation starts. ### OLECompleteDrag ```vb Public Event OLECompleteDrag(Effect As Long) ``` Fired when an OLE drag-and-drop operation is completed. ### OLESetData ```vb Public Event OLESetData(Data As DataObject, DataFormat As Integer) ``` Fired when the OLE drop target requests data. ## Code Examples ```vb ' Open and play an AVI file MCIWnd1.FileName = "C:\video.avi" MCIWnd1.Playbar = True MCIWnd1.Command = "play" ' Record audio MCIWnd1.NewDevice = "waveaudio" MCIWnd1.Command = "open new" MCIWnd1.Record = True MCIWnd1.Command = "record" ``` --- --- url: /en/vbman/tls/certmemory.md --- # Memory Certificate Collection Mode (TlsCertMemory) ## Overview Memory certificate collection mode is the most flexible TLS configuration method. Certificate data does not come from disk files or Windows Certificate Store, but is dynamically constructed by the program at runtime and stored in a VB6 `Collection` object, directly passed to the TLS engine. ## Function Signature ```vb Public Function TlsCertMemory( _ ByVal Certificates As Collection, _ ByVal PrivateKey As Collection, _ Optional ByVal AlpnProtocols As String = "...") As ``` ### Parameters | Parameter | Type | Required | Description | |-----------|------|----------|-------------| | `Certificates` | Collection | Yes | Certificate chain collection, each element is a PEM format certificate text | | `PrivateKey` | Collection | Yes | Private key collection, each element is a PEM format private key text | | `AlpnProtocols` | String | No | ALPN protocol negotiation. Default values vary by component | | Component | AlpnProtocols Default | |-----------|----------------------| | cHttpServer | `"http/1.1"` | | cWinsock | `"http/1.1"` | | cWebSocketServer | `""` (Empty) | ## Collection Data Format ### Certificates Collection Each element is a PEM encoded certificate text string: ```vb Dim certs As New Collection certs.Add "-----BEGIN CERTIFICATE-----" & vbCrLf & _ "MIIFazCCBFOgAwIBAgISA2Q3p..." & vbCrLf & _ "-----END CERTIFICATE-----" ' Intermediate certificate (if any) certs.Add "-----BEGIN CERTIFICATE-----" & vbCrLf & _ "MIIFazCCBFOgAwIBAgISA3B4q..." & vbCrLf & _ "-----END CERTIFICATE-----" ``` **Order Requirement:** First element must be the server certificate (leaf certificate), followed by intermediate certificates. ### PrivateKey Collection Each element is a PEM encoded private key text string: ```vb Dim pkeys As New Collection pkeys.Add "-----BEGIN PRIVATE KEY-----" & vbCrLf & _ "MIIEvgIBADANBgkqhkiG9w0BAQ..." & vbCrLf & _ "-----END PRIVATE KEY-----" ``` **Supported Private Key Formats:** * `-----BEGIN PRIVATE KEY-----` (PKCS#8 unencrypted) * `-----BEGIN RSA PRIVATE KEY-----` (PKCS#1 RSA) * `-----BEGIN EC PRIVATE KEY-----` (EC) * `-----BEGIN ENCRYPTED PRIVATE KEY-----` (PKCS#8 encrypted) ## Typical Application Scenarios ### 1. Certificate Embedded in Executable Compile certificates as resources into EXE/DLL, extract to Collection at runtime, no need to distribute separate .pfx files. ```vb ' Load certificates from resource file Dim certs As New Collection Dim pkeys As New Collection certs.Add LoadResData(101, "CERT") ' Custom resource type pkeys.Add LoadResData(102, "KEY") Server.TlsCertMemory(certs, pkeys).Start 443 ``` **Advantages:** * Simple deployment, only one EXE file needed * Certificates not exposed on disk (somewhat increased security) * No dependency on external file paths **Limitations:** * Certificate updates require recompilation * EXE size increases ### 2. ACME / Let's Encrypt Automatic Issuance Program automatically applies for certificates at runtime through ACME protocol, loads directly to memory without writing to disk. ```vb ' ACME issuance process (pseudocode) Dim certs As New Collection Dim pkeys As New Collection ' 1. Create account AcmeClient.Register "admin@example.com" ' 2. Verify domain ownership (HTTP-01 or DNS-01) AcmeClient.VerifyDomain "www.example.com" ' 3. Issue certificate Dim pemCert As String Dim pemKey As String pemCert = AcmeClient.IssueCertificate("www.example.com", pemKey) ' 4. Load to Collection certs.Add pemCert pkeys.Add pemKey ' 5. Start HTTPS Server.TlsCertMemory(certs, pkeys).Start 443 ``` **Advantages:** * Fully automatic, no manual intervention needed * Certificates never touch disk, reduced leak risk * Can implement scheduled automatic renewal ### 3. Dynamic SNI Routing Based on the domain name requested by the client (SNI), dynamically load corresponding certificates from database or configuration center. ```vb ' Concept example: Multi-domain HTTPS server ' Note: Current cTlsSocket initializes certificates at Listen phase, single-port multi-certificate not supported ' Multi-domain scenarios recommend using wildcard certificates or creating separate cHttpServer instances per domain Dim certs As New Collection Dim pkeys As New Collection ' Load domain-specific certificate from config database Dim rs As Recordset Set rs = DB.Execute("SELECT cert_pem, key_pem FROM certs WHERE domain='www.example.com'") certs.Add rs!cert_pem pkeys.Add rs!key_pem Server.TlsCertMemory(certs, pkeys).Start 443 ``` ### 4. Testing Scenarios Program self-signs temporary certificates for development and testing. ```vb ' Use OpenSSL command line to pre-generate test certificates, or use COM components to generate at runtime Dim certs As New Collection Dim pkeys As New Collection ' Assume TestCertGenerator is a custom certificate generation class Dim gen As New TestCertGenerator gen.CommonName = "localhost" gen.ValidDays = 1 certs.Add gen.GenerateCertificate() pkeys.Add gen.GeneratePrivateKey() Server.TlsCertMemory(certs, pkeys).Start 443 ``` ### 5. Load from File to Memory Read file contents into Collection, implement lazy loading or cache control. ```vb Private Function LoadPemToCollections( _ ByVal CertPaths As String, _ ByVal KeyPath As String) As Boolean Dim certs As New Collection Dim pkeys As New Collection ' Load certificates (supports | separated multiple files) Dim arrCerts() As String arrCerts = Split(CertPaths, "|") Dim i As Long For i = 0 To UBound(arrCerts) certs.Add ReadTextFile(Trim(arrCerts(i))) Next ' Load private key pkeys.Add ReadTextFile(KeyPath) ' Use Server.TlsCertMemory certs, pkeys LoadPemToCollections = True End Function Private Function ReadTextFile(ByVal Path As String) As String Dim f As Integer f = FreeFile Open Path For Input As #f ReadTextFile = Input$(LOF(f), f) Close #f End Function ``` ## Usage Examples by Component ### cHttpServer (HTTPS) ```vb Dim certs As New Collection Dim pkeys As New Collection ' Load from database certs.Add DB_GetCertPem("www.example.com") pkeys.Add DB_GetKeyPem("www.example.com") Server.TlsCertMemory(certs, pkeys).WebRoot("C:\www").Start 443 ``` ### cWinsock (TLS TCP Server) ```vb Dim certs As New Collection Dim pkeys As New Collection certs.Add LoadFromResource(101) pkeys.Add LoadFromResource(102) Dim svr As New cWinsock svr.TlsCertMemory(certs, pkeys).Listen 443 ``` ### cWebSocketServer (wss://) ```vb Dim certs As New Collection Dim pkeys As New Collection certs.Add GetCertFromConfig() pkeys.Add GetKeyFromConfig() Dim wsSvr As New cWebSocketServer wsSvr.TlsCertMemory(certs, pkeys).Listen 443 ``` ## PEM Text Format in Memory Each element in the Collection must be a complete PEM block, including start and end markers: ``` ✅ Correct: Complete PEM block -----BEGIN CERTIFICATE----- MIIFazCCBFOgAwIBAgISA2Q3p... (Base64 content, may contain newlines) -----END CERTIFICATE----- ❌ Incorrect: Only Base64 content, no PEM markers MIIFazCCBFOgAwIBAgISA2Q3p... ❌ Incorrect: DER binary data (byte array) ``` **Newlines:** Newlines in PEM text can be `vbCr`, `vbLf`, or `vbCrLf`, underlying OpenSSL can recognize all. ## Underlying Processing Flow ```vb ' cTlsSocket.InitServerTls internal If pvCollectionCount(Certificates) > 0 And pvCollectionCount(PrivateKey) > 0 Then Set cCerts = Certificates Set cPrivKey = PrivateKey GoTo StartTls End If ``` ``` TlsCertMemory(certs, pkeys) │ └─ InitServerTls(Certificates:=certs, PrivateKey:=pkeys) │ ├─ Check Certificates.Count > 0 And PrivateKey.Count > 0 │ └─ TlsInitServer(ctx, hostname, cCerts, cPrivKey, alpn, features) │ ├─ Iterate Certificates collection │ └─ PEM_read_bio_X509() → Parse certificates one by one │ ├─ Iterate PrivateKey collection │ └─ PEM_read_bio_PrivateKey() → Parse private key │ └─ SSL_CTX_use_certificate() + SSL_CTX_use_PrivateKey() ``` ## Security Considerations ### 1. Private Key Protection in Memory Private keys are stored as plaintext PEM text in Collection, readable by debuggers in process memory. **Recommendations:** * Clear Collection and string variables as soon as possible after use * Avoid outputting private key content in logs * Consider using Windows DPAPI to encrypt stored private key text ```vb ' Clear after use Set certs = Nothing Set pkeys = Nothing ``` ### 2. Certificate Source Verification When loading certificates from external sources (database, API, configuration center), verify data integrity and source. **Recommendations:** * Use TLS connections to obtain certificate data * Perform signature verification on configuration data * Restrict database access permissions ### 3. Memory Limits Large numbers of certificates or oversized certificate chains will consume more memory. **Recommendations:** * Only load necessary certificate chains * Avoid storing redundant intermediate certificates in Collection * Release Collection that is no longer needed in time ## Comparison with Other Modes | Feature | TlsCertFile | TlsCertSubject | TlsCertMemory | |---------|-------------|----------------|---------------| | Certificate Source | Disk files | Windows Certificate Store | Memory Collection | | Deployment Convenience | File distribution | System import | Embed/Dynamic load | | Certificate Update | Replace file | Renew to store | Reload | | Private Key Protection | File system permissions | OS protection | Process memory | | Runtime Generation | Not supported | Not supported | **Supported** | | ACME Auto Issuance | Needs disk write | Needs import | **Native support** | | Resource Embedding | Not supported | Not supported | **Supported** | | Deployment Complexity | Low | Medium | High | | Use Case | Production deployment | Enterprise shared | Dynamic/Embedded | ## Certificate Source Priority In `cTlsSocket.InitServerTls`, detection priority of three certificate sources: 1. **Memory Collection** (`Certificates` + `PrivateKey`) — Highest priority 2. **Certificate File** (`CertFile`) 3. **Windows Certificate Store** (`CertSubject`) — Lowest priority If multiple sources are passed simultaneously, only the highest priority one takes effect. ## FAQ ### 1. PEM Format Error ``` LastError: Certificate file does not exist or format error ``` **Solution:** Ensure each element in Collection is a complete PEM block, containing `-----BEGIN...-----` and `-----END...-----` markers. ### 2. Certificate and Private Key Mismatch ``` TLS handshake failed ``` **Solution:** Ensure certificate and private key are paired. Can verify with OpenSSL: ```bash openssl x509 -noout -modulus -in cert.pem | openssl md5 openssl rsa -noout -modulus -in key.pem | openssl md5 # Two MD5 values should be identical ``` ### 3. Certificate Order Error ``` Client reports incomplete certificate chain ``` **Solution:** First element in Certificates collection must be server certificate (leaf certificate), followed by intermediate certificates. ### 4. Empty Collection ``` InitServerTls skips memory certificate, attempts other sources ``` **Solution:** Ensure `Certificates.Count > 0` and `PrivateKey.Count > 0`, otherwise underlying layer will skip memory mode. ## Related Documentation * [TLS Certificate Configuration Overview](./overview.md) * [Certificate File Mode](./certfile.md) * [Windows Certificate Store Mode](./certsubject.md) * [cHttpServer TLS Support](../httpserver/tls.md) * [cWinsock TLS Support](../winsock/tls.md) * [cWebSocket TLS Support](../websocket/tls.md) *** **Last Updated**: 2026-06-09 --- --- url: /en/vbman/httpserver/middleware.md --- # Middleware System Guide ## Overview Middleware is an interceptor in HttpServer's request/response processing pipeline, allowing custom logic to execute before requests reach controllers and after responses are sent to clients. ``` Request Flow: ┌─────────────┐ ┌─────────────┐ ┌─────────────┐ ┌─────────────┐ │ Request │ -> │ Pre │ -> │ Controller │ -> │ Post │ -> Response │ Arrives │ │ Middleware │ │ Handler │ │ Middleware │ └─────────────┘ └─────────────┘ └─────────────┘ └─────────────┘ ``` ## Middleware Types | Type | Class | Execution Timing | | --------------- | ------------------------ | --------------------------- | | Pre-Middleware | `cHttpServerRouteBefore` | Before route matching | | Post-Middleware | `cHttpServerRouterAfter` | After controller processing | ## Pre-Middleware (RouteBefore) ### Basic Structure ```vb ' cAuthMiddleware.cls Option Explicit Public Sub Entry(ctx As cHttpServerContext) ' Middleware logic ' Terminate subsequent processing ' ctx.fIsAbort = True ' Skip other middleware ' ctx.fIsSkipNextMiddleWare = True End Sub ``` ### Common Middleware Examples #### 1. Login Verification Middleware ```vb ' cAuthCheckMiddleware.cls Option Explicit Public Sub Entry(ctx As cHttpServerContext) ' Exclude login endpoints If ctx.Request.PathInfo = "/login" Then Exit Sub If ctx.Request.PathInfo = "/register" Then Exit Sub ' Check session If Not ctx.Session.Exists("user_id") Then ctx.Response.State401 "Please login first" ctx.fIsAbort = True ' Terminate subsequent processing End If End Sub ``` #### 2. IP Blacklist Middleware ```vb ' cIPBlacklistMiddleware.cls Option Explicit Dim Blacklist As Dictionary Private Sub Class_Initialize() Set Blacklist = New Dictionary Blacklist("192.168.1.100") = True Blacklist("10.0.0.50") = True End Sub Public Sub Entry(ctx As cHttpServerContext) Dim clientIP As String clientIP = ctx.ClientInfo.IP If Blacklist.Exists(clientIP) Then ctx.Response.State403 "Your IP has been blocked" ctx.fIsAbort = True End If End Sub ``` #### 3. Request Logging Middleware ```vb ' cRequestLogMiddleware.cls Option Explicit Public Sub Entry(ctx As cHttpServerContext) Dim log As String log = Now & " " & _ ctx.ClientInfo.IP & " " & _ ctx.Request.MethodName & " " & _ ctx.Request.PathInfo ' Write to log file Call WriteLog(log) ' Record start time in context (for calculating response time) ctx.fStartTime = Timer End Sub Private Sub WriteLog(msg As String) Dim f As Integer f = FreeFile Open "C:\Logs\access.log" For Append As #f Print #f, msg Close #f End Sub ``` #### 4. CORS Preflight Handling ```vb ' cCorsMiddleware.cls Option Explicit Public Sub Entry(ctx As cHttpServerContext) ' Handle OPTIONS preflight request If ctx.Request.Method = ReqOptions Then ctx.Response.Header("Access-Control-Allow-Origin") = "*" ctx.Response.Header("Access-Control-Allow-Methods") = "GET, POST, PUT, DELETE, OPTIONS" ctx.Response.Header("Access-Control-Allow-Headers") = "Content-Type, Authorization" ctx.Response.Text "" ctx.fIsAbort = True End If End Sub ``` #### 5. Rate Limiting ```vb ' cRateLimitMiddleware.cls Option Explicit Dim RequestCounts As Dictionary Dim LastReset As Date Private Sub Class_Initialize() Set RequestCounts = New Dictionary LastReset = Now End Sub Public Sub Entry(ctx As cHttpServerContext) ' Reset count every minute If DateDiff("n", LastReset, Now) >= 1 Then Set RequestCounts = New Dictionary LastReset = Now End If Dim clientIP As String clientIP = ctx.ClientInfo.IP ' Count requests If Not RequestCounts.Exists(clientIP) Then RequestCounts(clientIP) = 0 End If RequestCounts(clientIP) = RequestCounts(clientIP) + 1 ' Limit to 100 per minute If RequestCounts(clientIP) > 100 Then ctx.Response.State429 "Too many requests, please try again later" ctx.fIsAbort = True End If End Sub ``` ### Middleware Registration and Priority ```vb Private Sub Form_Load() Set Server = New cHttpServer ' Register middleware (in priority order) Call Server.RouteBefore.Add("cors", New cCorsMiddleware) ' First to execute Call Server.RouteBefore.Add("ratelimit", New cRateLimitMiddleware) ' Second to execute Call Server.RouteBefore.Add("ipblacklist", New cIPBlacklistMiddleware) ' Third to execute Call Server.RouteBefore.Add("requestlog", New cRequestLogMiddleware) ' Fourth to execute Call Server.RouteBefore.Add("authcheck", New cAuthCheckMiddleware) ' Fifth to execute ' Register controllers Call Server.Router.Reg("Api", New cApiController) Call Server.Router.Add("/api/data", "Api@Data") Call Server.Start(8080) End Sub ``` ### Context Control Flags | Flag | Description | | --------------------------- | -------------------------------------------------- | | `ctx.fIsAbort` | Set to True to terminate entire request processing | | `ctx.fIsSkipNextMiddleWare` | Set to True to skip subsequent middleware | ## Post-Middleware (RouteAfter) Post-middleware is used for processing after response is sent (current version is a reserved interface). ```vb ' cResponseLogMiddleware.cls Option Explicit Public Sub Entry(ctx As cHttpServerContext) ' Calculate response time If ctx.fStartTime > 0 Then Dim elapsed As Double elapsed = Timer - ctx.fStartTime ' Log slow requests If elapsed > 1 Then Call WriteSlowLog(ctx.Request.PathInfo & " took " & elapsed & " seconds") End If End If End Sub ``` ## Context Extension Custom properties can be added to context for sharing between middleware and controllers: ```vb ' cHttpServerContext extension module ' Set in middleware Public Sub AuthMiddleware(ctx As cHttpServerContext) If IsValidToken Then ctx.fUserId = GetUserIdFromToken() ctx.fUserRole = GetUserRole() End If End Sub ' Use in controller Public Sub GetData(ctx As cHttpServerContext) ' Get info set by middleware Dim userId As String userId = ctx.fUserId ' Return different data based on role If ctx.fUserRole = "admin" Then ' Return all data Else ' Return partial data End If End Sub ``` ## Middleware Chain Execution Order ``` Request: GET /api/users 1. cCorsMiddleware -> Passed 2. cRateLimitMiddleware -> Passed 3. cIPBlacklistMiddleware -> Passed 4. cRequestLogMiddleware -> Passed 5. cAuthCheckMiddleware -> Check session └─> Not logged in -> ctx.fIsAbort = True Request terminated, returns 401 ``` *** **Last Updated**: 2026-05-17 --- --- url: /zh/vbman/modbus/advanced.md --- # Modbus 进阶应用 本文档介绍 Modbus 类库的高级功能、最佳实践和常见应用场景。 *** ## ? 目录 * [高级主题](#高级主题) * [性能优化](#性能优化) * [错误处理](#错误处理) * [多从站管理](#多从站管理) * [数据缓存策略](#数据缓存策略) * [日志与调试](#日志与调试) * [安全考虑](#安全考虑) * [实际应用场景](#实际应用场景) * [常见问题](#常见问题) *** ## 高级主题 ### 1. 主从站合一模式 某些应用场景需要同一设备既作为主站又作为从站: ```vb Option Explicit Private WithEvents mbMaster As cModbusMaster Private WithEvents mbSlave As cModbusSlave Private Sub Form_Load() Set mbMaster = New cModbusMaster Set mbSlave = New cModbusSlave ' 初始化主站 - 向上位机请求数据 mbMaster.ProtocolType = MB_MASTER_PROTOCOL_TCP mbMaster.TCPHost = "192.168.1.100" mbMaster.TCPPort = 502 mbMaster.SlaveID = 1 ' 初始化从站 - 向下位机提供数据 mbSlave.ProtocolType = MB_SLAVE_PROTOCOL_TCP mbSlave.SlaveID = 2 mbSlave.BindAddress = "0.0.0.0" ' 监听所有接口 mbSlave.Start 1502 End Sub ' 从主站接收数据后,更新从站提供给下位机 Private Sub tmrSync_Timer() On Error Resume Next ' 从上位机读取 Dim iRegs() As Integer iRegs = mbMaster.ReadHoldingRegisters(0, 10) ' 写入本地从站,供下位机读取 If UBound(iRegs) >= 0 Then Dim i As Long For i = 0 To UBound(iRegs) mbSlave.SetHoldingRegister i, iRegs(i) Next i End If End Sub ``` *** ### 2. 事务管理 实现带重试的事务机制: ```vb Option Explicit Private WithEvents mbMaster As cModbusMaster Private Const MAX_RETRIES As Long = 3 Private Const RETRY_DELAY_MS As Long = 1000 Private Function ReadWithRetry(StartAddr As Long, Quantity As Long) As Integer() Dim iRetry As Long Dim bSuccess As Boolean Dim iRegs() As Integer For iRetry = 1 To MAX_RETRIES On Error Resume Next If mbMaster.State = MB_MASTER_STATE_DISCONNECTED Then mbMaster.Connect End If iRegs = mbMaster.ReadHoldingRegisters(StartAddr, Quantity) If UBound(iRegs) >= 0 Then bSuccess = True Exit For End If ' 失败后等待 If iRetry < MAX_RETRIES Then Sleep RETRY_DELAY_MS End If Next iRetry If bSuccess Then ReadWithRetry = iRegs Else ' 所有重试都失败 RaiseError "ReadWithRetry failed after " & MAX_RETRIES & " attempts" End If End Function ``` *** ### 3. 异步操作模式 使用 Timer 实现非阻塞的异步操作: ```vb Option Explicit Private WithEvents mbMaster As cModbusMaster Private WithEvents tmrAsync As Timer Private m_lPendingAddr As Long Private m_lPendingCount As Long Private m_bAsyncBusy As Boolean Private Sub Form_Load() Set mbMaster = New cModbusMaster Set tmrAsync = New Timer tmrAsync.Interval = 100 ' 100ms 检查间隔 End Sub ' 发起异步读取请求 Public Sub AsyncReadHoldingRegisters(StartAddr As Long, Quantity As Long) If m_bAsyncBusy Then Debug.Print "Async operation in progress" Exit Sub End If m_bAsyncBusy = True m_lPendingAddr = StartAddr m_lPendingCount = Quantity tmrAsync.Enabled = True End Sub ' Timer 回调执行读取 Private Sub tmrAsync_Timer() On Error Resume Next tmrAsync.Enabled = False Dim iRegs() As Integer iRegs = mbMaster.ReadHoldingRegisters(m_lPendingAddr, m_lPendingCount) If UBound(iRegs) >= 0 Then ' 读取成功,触发回调 OnAsyncReadComplete m_lPendingAddr, m_lPendingCount, iRegs Else ' 读取失败 OnAsyncError "Read failed" End If m_bAsyncBusy = False End Sub ' 读取完成回调 Private Sub OnAsyncReadComplete(StartAddr As Long, Quantity As Long, ByRef Values() As Integer) ' 处理数据 ProcessData Values RaiseEvent AsyncReadComplete(StartAddr, Quantity, Values) End Sub ' 错误回调 Private Sub OnAsyncError(Description As String) Debug.Print "Async error: " & Description RaiseEvent AsyncError(Description) End Sub ``` *** ## 性能优化 ### 1. 批量读取优化 尽量使用单次批量读取,减少通信次数: ```vb ' 差的做法 - 多次读取 Private Sub BadReadApproach() Dim i As Long Dim iValue As Integer For i = 0 To 99 iValue = mbMaster.ReadHoldingRegisters(i, 1)(0) ' 处理数据 Next i End Sub ' 好的做法 - 批量读取 Private Sub GoodReadApproach() Dim iRegs() As Integer Dim i As Long ' 一次读取100个寄存器 iRegs = mbMaster.ReadHoldingRegisters(0, 100) For i = 0 To UBound(iRegs) ' 处理数据 Next i End Sub ``` *** ### 2. 读取频率控制 避免过于频繁的读取请求: ```vb Option Explicit Private WithEvents mbMaster As cModbusMaster Private WithEvents tmrPoll As Timer Private m_dLastReadTime As Double Private Const MIN_READ_INTERVAL_SEC As Double = 0.5 ' 最小间隔0.5秒 Private Sub tmrPoll_Timer() Dim dNow As Double dNow = Timer ' 检查是否到达最小间隔 If dNow - m_dLastReadTime < MIN_READ_INTERVAL_SEC Then Exit Sub End If ' 执行读取 Dim iRegs() As Integer iRegs = mbMaster.ReadHoldingRegisters(0, 10) m_dLastReadTime = dNow End Sub ``` *** ### 3. 数据预缓存 启动时预加载常用数据: ```vb Option Explicit Private WithEvents mbMaster As cModbusMaster Private m_iRegCache() As Integer Private Const CACHE_SIZE As Long = 100 Private Sub mbMaster_OnConnect() ' 连接成功后立即加载缓存 LoadCache End Sub Private Sub LoadCache() On Error Resume Next ReDim m_iRegCache(CACHE_SIZE - 1) As Integer Dim iRegs() As Integer iRegs = mbMaster.ReadHoldingRegisters(0, CACHE_SIZE) If UBound(iRegs) >= 0 Then Dim i As Long For i = 0 To UBound(iRegs) If i < CACHE_SIZE Then m_iRegCache(i) = iRegs(i) End If Next i Debug.Print "Cache loaded: " & (UBound(iRegs) + 1) & " registers" End If End Sub ' 从缓存快速读取 Public Function GetCachedRegister(Addr As Long) As Integer If Addr >= 0 And Addr < CACHE_SIZE Then GetCachedRegister = m_iRegCache(Addr) Else GetCachedRegister = -1 ' 缓存未命中 End If End Function ' 定期更新缓存 Private Sub tmrCacheUpdate_Timer() On Error Resume Next Dim iRegs() As Integer iRegs = mbMaster.ReadHoldingRegisters(0, CACHE_SIZE) If UBound(iRegs) >= 0 Then Dim i As Long For i = 0 To UBound(iRegs) If i < CACHE_SIZE Then m_iRegCache(i) = iRegs(i) End If Next i End If End Sub ``` *** ### 4. 连接池管理 对于多从站场景,实现连接池: ```vb Option Explicit Private Type ModbusDevice ID As Long Host As String Port As Long SlaveID As Byte LastUsed As Double Connected As Boolean End Type Private m_Devices() As ModbusDevice Private m_MaxDevices As Long Private m_ConnectionTimeout As Double ' 秒 Private Sub InitializeConnectionPool(MaxDevices As Long, TimeoutSeconds As Double) m_MaxDevices = MaxDevices m_ConnectionTimeout = TimeoutSeconds ReDim m_Devices(MaxDevices - 1) As ModbusDevice Dim i As Long For i = 0 To MaxDevices - 1 m_Devices(i).Connected = False m_Devices(i).LastUsed = Timer - m_ConnectionTimeout - 1 Next i End Sub ' 获取设备连接 Public Function GetDevice(DeviceID As Long) As cModbusMaster Dim mbDev As cModbusMaster Dim i As Long ' 查找设备 For i = 0 To m_MaxDevices - 1 If m_Devices(i).ID = DeviceID Then ' 更新使用时间 m_Devices(i).LastUsed = Timer Set mbDev = New cModbusMaster mbDev.ProtocolType = MB_MASTER_PROTOCOL_TCP mbDev.TCPHost = m_Devices(i).Host mbDev.TCPPort = m_Devices(i).Port mbDev.SlaveID = m_Devices(i).SlaveID Set GetDevice = mbDev Exit Function End If Next i Set GetDevice = Nothing End Function ' 清理过期连接 Public Sub CleanupConnections() Dim i As Long Dim dNow As Double dNow = Timer For i = 0 To m_MaxDevices - 1 If m_Devices(i).Connected Then ' 超过超时时间 If dNow - m_Devices(i).LastUsed > m_ConnectionTimeout Then ' 标记为断开 m_Devices(i).Connected = False Debug.Print "Device " & m_Devices(i).ID & " connection timed out" End If End If Next i End Sub ``` *** ## 错误处理 ### 1. 综合错误处理 ```vb Option Explicit Private WithEvents mbMaster As cModbusMaster ' 读取并处理错误 Public Function SafeReadRegisters(StartAddr As Long, Quantity As Long) As Integer() On Error GoTo ErrorHandler ' 检查连接状态 If mbMaster.State <> MB_MASTER_STATE_CONNECTED Then Err.Raise vbObjectError + 1, "SafeReadRegisters", "Not connected" End If ' 检查参数 If StartAddr < 0 Then Err.Raise vbObjectError + 2, "SafeReadRegisters", "Invalid start address" End If If Quantity < 1 Or Quantity > mbMaster.Defaults.MAX_REGISTERS Then Err.Raise vbObjectError + 3, "SafeReadRegisters", "Invalid quantity" End If ' 执行读取 Dim iRegs() As Integer iRegs = mbMaster.ReadHoldingRegisters(StartAddr, Quantity) SafeReadRegisters = iRegs Exit Function ErrorHandler: Dim sError As String sError = "Error " & Err.Number & ": " & Err.Description Debug.Print sError LogError sError ' 返回空数组 SafeReadRegisters = Array() End Function ' 错误日志 Private Sub LogError(sMessage As String) Dim iFile As Integer iFile = FreeFile Open App.Path & "\modbus_error.log" For Append As #iFile Print #iFile, Format$(Now, "yyyy-mm-dd hh:mm:ss") & " - " & sMessage Close #iFile End Sub ``` *** ### 2. 异常码处理 ```vb Option Explicit Private WithEvents mbMaster As cModbusMaster Private Sub mbMaster_OnError(ByVal Description As String) Select Case True Case InStr(Description, "Illegal Function") > 0 HandleIllegalFunction Case InStr(Description, "Illegal Data Address") > 0 HandleIllegalDataAddress Case InStr(Description, "Illegal Data Value") > 0 HandleIllegalDataValue Case InStr(Description, "Slave Device Failure") > 0 HandleSlaveDeviceFailure Case InStr(Description, "Slave Device Busy") > 0 HandleSlaveDeviceBusy Case InStr(Description, "Response timeout") > 0 HandleTimeout Case Else HandleGenericError Description End Select End Sub Private Sub HandleIllegalFunction() Debug.Print "功能码不支持" ' 可能需要使用不同的功能码 End Sub Private Sub HandleIllegalDataAddress() Debug.Print "地址超出范围" ' 检查地址是否在有效范围内 End Sub Private Sub HandleIllegalDataValue() Debug.Print "数据值非法" ' 检查写入的数据值 End Sub Private Sub HandleSlaveDeviceFailure() Debug.Print "从站设备故障" ' 可能需要报警或切换到备用设备 End Sub Private Sub HandleSlaveDeviceBusy() Debug.Print "从站忙" ' 等待后重试 Sleep 1000 End Sub Private Sub HandleTimeout() Debug.Print "响应超时" ' 检查网络或串口连接 ' 可能需要重连 End Sub Private Sub HandleGenericError(sDescription As String) Debug.Print "通用错误: " & sDescription End Sub ``` *** ## 多从站管理 ### 1. 设备配置管理 ```vb Option Explicit Private Type DeviceConfig DeviceID As Long Name As String ProtocolType As ModbusMasterProtocolType Host As String Port As Long SerialPort As String BaudRate As Long SlaveID As Byte PollInterval As Long ' 轮询间隔(毫秒) Enabled As Boolean End Type Private m_Devices() As DeviceConfig Private m_MasterConnections() As cModbusMaster ' 添加设备配置 Public Sub AddDevice(DevID As Long, sName As String, Protocol As ModbusProtocolType, _ sHost As String, lPort As Long, sSerialPort As String, _ lBaudRate As Long, bSlaveID As Byte, lPollInterval As Long) Dim iCount As Long iCount = UBound(m_Devices) + 1 ReDim Preserve m_Devices(iCount) As DeviceConfig ReDim Preserve m_MasterConnections(iCount) As cModbusMaster With m_Devices(iCount) .DeviceID = DevID .Name = sName .ProtocolType = Protocol .Host = sHost .Port = lPort .SerialPort = sSerialPort .BaudRate = lBaudRate .SlaveID = bSlaveID .PollInterval = lPollInterval .Enabled = True End With Set m_MasterConnections(iCount) = New cModbusMaster Debug.Print "Device added: " & sName & " (ID: " & DevID & ")" End Sub ' 连接所有设备 Public Sub ConnectAllDevices() Dim i As Long For i = 0 To UBound(m_Devices) If m_Devices(i).Enabled Then ConnectDevice i End If Next i End Sub ' 连接单个设备 Private Sub ConnectDevice(Index As Long) On Error Resume Next Dim mbDev As cModbusMaster Set mbDev = m_MasterConnections(Index) With m_Devices(Index) mbDev.ProtocolType = .ProtocolType mbDev.SlaveID = .SlaveID If .ProtocolType = MB_MASTER_PROTOCOL_TCP Then mbDev.TCPHost = .Host mbDev.TCPPort = .Port mbDev.Connect Else mbDev.SerialPort = .SerialPort mbDev.BaudRate = .BaudRate mbDev.DataBits = 8 mbDev.Parity = "N" mbDev.StopBits = 1 mbDev.Connect .SerialPort End If End With If Err.Number = 0 Then Debug.Print "Device " & m_Devices(Index).Name & " connected" Else Debug.Print "Device " & m_Devices(Index).Name & " connect failed: " & Err.Description End If End Sub ``` *** ### 2. 统一轮询管理 ```vb Option Explicit Private WithEvents tmrPoll As Timer Private m_CurrentDeviceIndex As Long Private Sub StartPolling() Set tmrPoll = New Timer tmrPoll.Interval = 100 ' 100ms 轮询间隔 m_CurrentDeviceIndex = 0 tmrPoll.Enabled = True End Sub Private Sub tmrPoll_Timer() tmrPoll.Enabled = False ' 轮询当前设备 PollDevice m_CurrentDeviceIndex ' 移动到下一个设备 m_CurrentDeviceIndex = m_CurrentDeviceIndex + 1 If m_CurrentDeviceIndex > UBound(m_Devices) Then m_CurrentDeviceIndex = 0 End If tmrPoll.Enabled = True End Sub Private Sub PollDevice(Index As Long) On Error Resume Next Dim mbDev As cModbusMaster Set mbDev = m_MasterConnections(Index) ' 检查设备是否启用 If Not m_Devices(Index).Enabled Then Exit Sub End If ' 检查连接状态 If mbDev.State <> MB_MASTER_STATE_CONNECTED Then ConnectDevice Index Exit Sub End If ' 读取设备数据 Dim iRegs() As Integer iRegs = mbDev.ReadHoldingRegisters(0, 10) If UBound(iRegs) >= 0 Then ' 处理数据 ProcessDeviceData m_Devices(Index).DeviceID, iRegs ' 更新最后通信时间 m_Devices(Index).LastUsed = Timer End If End Sub Private Sub ProcessDeviceData(DeviceID As Long, ByRef Values() As Integer) ' 根据设备ID处理数据 Select Case DeviceID Case 1 ProcessDevice1Data Values Case 2 ProcessDevice2Data Values ' ... End Select End Sub ``` *** ## 数据缓存策略 ### 1. 多级缓存 ```vb Option Explicit Private Enum CacheLevel CACHE_LEVEL_NONE = 0 CACHE_LEVEL_L1 = 1 ' 内存缓存 CACHE_LEVEL_L2 = 2 ' 文件缓存 CACHE_LEVEL_L3 = 3 ' 数据库缓存 End Enum Private m_L1Cache() As Integer ' 内存缓存 Private m_L1CacheValid() As Boolean ' 缓存有效性标记 Private m_CacheLevel As CacheLevel ' 初始化缓存 Public Sub InitializeCache(Size As Long, Level As CacheLevel) ReDim m_L1Cache(Size - 1) As Integer ReDim m_L1CacheValid(Size - 1) As Boolean m_CacheLevel = Level Dim i As Long For i = 0 To Size - 1 m_L1CacheValid(i) = False Next i End Sub ' 读取寄存器(带缓存) Public Function ReadWithCache(Addr As Long) As Integer ' 先检查L1缓存 If Addr >= 0 And Addr <= UBound(m_L1Cache) Then If m_L1CacheValid(Addr) And m_CacheLevel >= CACHE_LEVEL_L1 Then ReadWithCache = m_L1Cache(Addr) Debug.Print "Cache L1 hit: Reg[" & Addr & "] = " & m_L1Cache(Addr) Exit Function End If End If ' L1缓存未命中,从设备读取 Dim iRegs() As Integer iRegs = mbMaster.ReadHoldingRegisters(Addr, 1) If UBound(iRegs) >= 0 Then ' 更新L1缓存 If Addr >= 0 And Addr <= UBound(m_L1Cache) Then m_L1Cache(Addr) = iRegs(0) m_L1CacheValid(Addr) = True End If ReadWithCache = iRegs(0) Debug.Print "Cache miss: Reg[" & Addr & "] = " & iRegs(0) End If End Function ' 无效化缓存 Public Sub InvalidateCache(Addr As Long) On Error Resume Next If Addr >= 0 And Addr <= UBound(m_L1Cache) Then m_L1CacheValid(Addr) = False End If End Sub ' 无效化所有缓存 Public Sub InvalidateAllCache() Dim i As Long For i = 0 To UBound(m_L1Cache) m_L1CacheValid(i) = False Next i Debug.Print "All cache invalidated" End Sub ``` *** ### 2. 写入同步策略 ```vb Option Explicit Private WithEvents mbMaster As cModbusMaster Private WithEvents mbSlave As cModbusSlave ' 主站读取后同步到从站 Private Sub SyncMasterToSlave() On Error Resume Next ' 从上位机读取 Dim iMasterRegs() As Integer iMasterRegs = mbMaster.ReadHoldingRegisters(0, 10) If UBound(iMasterRegs) >= 0 Then ' 比较数据是否变化 Dim bChanged As Boolean bChanged = CheckDataChanged(iMasterRegs) ' 如果有变化,同步到从站 If bChanged Then Dim i As Long For i = 0 To UBound(iMasterRegs) mbSlave.SetHoldingRegister i, iMasterRegs(i) Next i Debug.Print "Synced " & (UBound(iMasterRegs) + 1) & " registers" End If End If End Sub ' 检查数据是否变化 Private Function CheckDataChanged(ByRef NewData() As Integer) As Boolean Static iLastData() As Integer Static bInitialized As Boolean If Not bInitialized Then ' 首次初始化 iLastData = NewData bInitialized = True CheckDataChanged = True Exit Function End If Dim i As Long For i = 0 To UBound(NewData) If iLastData(i) <> NewData(i) Then iLastData(i) = NewData(i) CheckDataChanged = True Exit Function End If Next i CheckDataChanged = False End Function ``` *** ## 日志与调试 ### 1. 详细日志记录 ```vb Option Explicit Private Enum LogLevel LOG_LEVEL_DEBUG = 0 LOG_LEVEL_INFO = 1 LOG_LEVEL_WARNING = 2 LOG_LEVEL_ERROR = 3 LOG_LEVEL_CRITICAL = 4 End Enum Private m_LogLevel As LogLevel Private m_LogFile As String ' 初始化日志 Public Sub InitLog(sFilePath As String, Level As LogLevel) m_LogFile = sFilePath m_LogLevel = Level ' 创建日志目录 Dim sDir As String sDir = Left$(sFilePath, InStrRev(sFilePath, "\") - 1) On Error Resume Next MkDir sDir On Error GoTo 0 End Sub ' 写入日志 Public Sub WriteLog(Level As LogLevel, sMessage As String) ' 只记录指定级别及以上的日志 If Level < m_LogLevel Then Exit Sub Dim sLevel As String Select Case Level Case LOG_LEVEL_DEBUG: sLevel = "DEBUG" Case LOG_LEVEL_INFO: sLevel = "INFO " Case LOG_LEVEL_WARNING: sLevel = "WARN " Case LOG_LEVEL_ERROR: sLevel = "ERROR" Case LOG_LEVEL_CRITICAL: sLevel = "CRIT " End Select Dim sLogLine As String sLogLine = Format$(Now, "yyyy-mm-dd hh:mm:ss") & " [" & sLevel & "] " & sMessage Debug.Print sLogLine On Error Resume Next Dim iFile As Integer iFile = FreeFile Open m_LogFile For Append As #iFile Print #iFile, sLogLine Close #iFile On Error GoTo 0 End Sub ' 封装的日志函数 Public Sub LogDebug(sMessage As String) WriteLog LOG_LEVEL_DEBUG, sMessage End Sub Public Sub LogInfo(sMessage As String) WriteLog LOG_LEVEL_INFO, sMessage End Sub Public Sub LogWarning(sMessage As String) WriteLog LOG_LEVEL_WARNING, sMessage End Sub Public Sub LogError(sMessage As String) WriteLog LOG_LEVEL_ERROR, sMessage End Sub Public Sub LogCritical(sMessage As String) WriteLog LOG_LEVEL_CRITICAL, sMessage End Sub ``` *** ### 2. 数据包调试 ```vb Option Explicit Private WithEvents mbMaster As cModbusMaster ' 数据包调试开关 Private m_bDebugPackets As Boolean Public Sub EnablePacketDebug(bEnable As Boolean) m_bDebugPackets = bEnable End Sub ' 调试事件处理 Private Sub mbMaster_OnDataReceived(Data() As Byte) If Not m_bDebugPackets Then Exit Sub Dim sHex As String Dim i As Long For i = 0 To UBound(Data) sHex = sHex & Format$(Data(i), "00") & " " Next i Debug.Print "RX [" & Format$(Now, "hh:mm:ss") & "] " & sHex LogInfo "RX: " & sHex End Sub ' 发送数据包调试 Private Sub DebugSendPacket(ByRef Data() As Byte) If Not m_bDebugPackets Then Exit Sub Dim sHex As String Dim i As Long For i = 0 To UBound(Data) sHex = sHex & Format$(Data(i), "00") & " " Next i Debug.Print "TX [" & Format$(Now, "hh:mm:ss") & "] " & sHex LogInfo "TX: " & sHex End Sub ' 解析Modbus数据包 Public Sub ParseModbusPacket(ByRef Data() As Byte) If UBound(Data) < 2 Then Exit Sub Dim bFC As Byte bFC = Data(1) Debug.Print "=== Modbus Packet ===" Debug.Print "Slave ID: " & Data(0) Debug.Print "Function Code: 0x" & Hex$(bFC) & " (" & GetFunctionName(bFC) & ")" Select Case bFC Case &H1 ' Read Coils If UBound(Data) >= 3 Then Debug.Print "Byte Count: " & Data(2) End If Case &H3 ' Read Holding Registers If UBound(Data) >= 3 Then Dim iByteCount As Long iByteCount = Data(2) Debug.Print "Byte Count: " & iByteCount Dim i As Long For i = 0 To (iByteCount \ 2) - 1 Dim iReg As Integer iReg = Data(3 + i * 2) * 256 + Data(4 + i * 2) Debug.Print " Reg[" & i & "] = " & iReg & " (0x" & Hex$(iReg) & ")" Next i End If End Select Debug.Print "=====================" End Sub Private Function GetFunctionName(bFC As Byte) As String Select Case bFC Case &H1: GetFunctionName = "Read Coils" Case &H2: GetFunctionName = "Read Discrete Inputs" Case &H3: GetFunctionName = "Read Holding Registers" Case &H4: GetFunctionName = "Read Input Registers" Case &H5: GetFunctionName = "Write Single Coil" Case &H6: GetFunctionName = "Write Single Register" Case &HF: GetFunctionName = "Write Multiple Coils" Case &H10: GetFunctionName = "Write Multiple Registers" Case Else: GetFunctionName = "Unknown" End Select End Function ``` *** ## 安全考虑 ### 1. 连接认证 ```vb Option Explicit Private Type AuthConfig Enabled As Boolean Username As String Password As String Token As String TokenExpiry As Date End Type Private m_Auth As AuthConfig ' 初始化认证 Public Sub SetAuthentication(bEnabled As Boolean, sUser As String, sPass As String) m_Auth.Enabled = bEnabled m_Auth.Username = sUser m_Auth.Password = sPass m_Auth.Token = "" m_Auth.TokenExpiry = #1/1/1900# End Sub ' 检查认证 Public Function CheckAuthentication() As Boolean If Not m_Auth.Enabled Then CheckAuthentication = True ' 未启用认证,直接通过 Exit Function End If ' 检查Token是否过期 If m_Auth.Token <> "" And Now < m_Auth.TokenExpiry Then CheckAuthentication = True Exit Function End If ' 执行认证 CheckAuthentication = Authenticate() End Function ' 执行认证 Private Function Authenticate() As Boolean ' 这里实现实际的认证逻辑 ' 可以是通过Modbus发送认证请求 ' 或者通过其他渠道认证 ' 示例: 通过Modbus特定寄存器认证 Dim bSuccess As Boolean On Error Resume Next ' 发送认证信息 Dim iUserHash As Integer Dim iPassHash As Integer iUserHash = SimpleHash(m_Auth.Username) iPassHash = SimpleHash(m_Auth.Password) ' 写入认证寄存器 mbMaster.WriteSingleRegister 998, iUserHash mbMaster.WriteSingleRegister 999, iPassHash ' 读取认证结果 Dim iResult() As Integer iResult = mbMaster.ReadHoldingRegisters(1000, 1) If UBound(iResult) >= 0 Then If iResult(0) = 1 Then ' 认证成功 m_Auth.Token = GenerateToken() m_Auth.TokenExpiry = DateAdd("h", 1, Now) ' 1小时过期 Authenticate = True Debug.Print "Authentication successful" Exit Function End If End If Authenticate = False Debug.Print "Authentication failed" End Function ' 简单哈希(仅示例,实际应用应使用更安全的哈希) Private Function SimpleHash(sInput As String) As Integer Dim i As Long Dim lHash As Long For i = 1 To Len(sInput) lHash = lHash + Asc(Mid$(sInput, i, 1)) * (i Mod 7 + 1) Next i SimpleHash = lHash And &HFFFF End Function ' 生成Token(仅示例) Private Function GenerateToken() As String GenerateToken = "TOKEN_" & Format$(Now, "yyyymmddhhmmss") End Function ``` *** ### 2. 数据加密(示例) ```vb Option Explicit Private m_bEncryptData As Boolean Private m_EncryptionKey As String ' 启用数据加密 Public Sub EnableEncryption(bEnable As Boolean, sKey As String) m_bEncryptData = bEnable m_EncryptionKey = sKey End Sub ' 加密数据(简单XOR加密,仅示例) Public Function EncryptData(ByRef Data() As Byte) As Byte() If Not m_bEncryptData Then EncryptData = Data Exit Function End If Dim baEncrypted() As Byte ReDim baEncrypted(UBound(Data)) As Byte Dim i As Long Dim lKeyLen As Long lKeyLen = Len(m_EncryptionKey) For i = 0 To UBound(Data) Dim bKeyByte As Byte bKeyByte = Asc(Mid$(m_EncryptionKey, (i Mod lKeyLen) + 1, 1)) baEncrypted(i) = Data(i) Xor bKeyByte Next i EncryptData = baEncrypted End Function ' 解密数据 Public Function DecryptData(ByRef Data() As Byte) As Byte() ' XOR加密是对称的,解密和加密相同 DecryptData = EncryptData(Data) End Function ``` *** ## 实际应用场景 ### 1. 工业数据采集 ```vb Option Explicit Private WithEvents mbMaster As cModbusMaster Private WithEvents tmrCollect As Timer ' 数据采集配置 Private Type DataPoint RegisterAddr As Long Name As String Unit As String MinValue As Single MaxValue As Single AlarmHigh As Single AlarmLow As Single LastValue As Single LastUpdate As Date End Type Private m_DataPoints() As DataPoint ' 初始化数据点 Public Sub InitializeDataPoints() ReDim m_DataPoints(9) As DataPoint ' 温度 m_DataPoints(0).RegisterAddr = 0 m_DataPoints(0).Name = "温度" m_DataPoints(0).Unit = "°C" m_DataPoints(0).MinValue = -50 m_DataPoints(0).MaxValue = 150 m_DataPoints(0).AlarmHigh = 120 m_DataPoints(0).AlarmLow = -20 ' 压力 m_DataPoints(1).RegisterAddr = 1 m_DataPoints(1).Name = "压力" m_DataPoints(1).Unit = "kPa" m_DataPoints(1).MinValue = 0 m_DataPoints(1).MaxValue = 10000 m_DataPoints(1).AlarmHigh = 8000 m_DataPoints(1).AlarmLow = 0 ' 流量 m_DataPoints(2).RegisterAddr = 2 m_DataPoints(2).Name = "流量" m_DataPoints(2).Unit = "L/min" m_DataPoints(2).MinValue = 0 m_DataPoints(2).MaxValue = 1000 m_DataPoints(2).AlarmHigh = 900 m_DataPoints(2).AlarmLow = 0 ' ... 更多数据点 End Sub ' 数据采集循环 Private Sub tmrCollect_Timer() On Error Resume Next Dim i As Long Dim iRegs() As Integer ' 批量读取所有寄存器 iRegs = mbMaster.ReadHoldingRegisters(0, 10) If UBound(iRegs) >= 0 Then For i = 0 To UBound(m_DataPoints) If i <= UBound(iRegs) Then Dim fValue As Single ' 转换原始值 fValue = ConvertRawValue(iRegs(i), m_DataPoints(i)) ' 更新数据点 m_DataPoints(i).LastValue = fValue m_DataPoints(i).LastUpdate = Now ' 检查报警 CheckAlarm i, fValue ' 记录数据 LogDataPoint i, fValue ' 更新UI显示 UpdateDataPointUI i, fValue End If Next i End If End Sub ' 转换原始值 Private Function ConvertRawValue(iRaw As Integer, pt As DataPoint) As Single ' 根据单位转换原始值 Select Case pt.Unit Case "°C" ' 温度: 直接使用 ConvertRawValue = CSng(iRaw) Case "kPa" ' 压力: 原始值 * 10 ConvertRawValue = CSng(iRaw) * 10 Case "L/min" ' 流量: 原始值 * 0.1 ConvertRawValue = CSng(iRaw) * 0.1 Case Else ConvertRawValue = CSng(iRaw) End Select End Function ' 检查报警 Private Sub CheckAlarm(Index As Long, fValue As Single) With m_DataPoints(Index) If fValue >= .AlarmHigh Then TriggerAlarm .Name, "高报警", fValue, .AlarmHigh ElseIf fValue <= .AlarmLow Then TriggerAlarm .Name, "低报警", fValue, .AlarmLow End If End With End Sub ' 触发报警 Private Sub TriggerAlarm(sPointName As String, sAlarmType As String, fValue As Single, fThreshold As Single) Dim sMessage As String sMessage = sPointName & " " & sAlarmType & ": " & Format$(fValue, "0.00") & _ " (阈值: " & Format$(fThreshold, "0.00") & ")" Debug.Print "[ALARM] " & Format$(Now, "hh:mm:ss") & " - " & sMessage ' 发送邮件通知 ' SendAlarmEmail sMessage ' 记录报警日志 ' LogAlarm sMessage ' 更新报警UI ' UpdateAlarmUI sPointName, sAlarmType, sMessage End Sub ' 记录数据点 Private Sub LogDataPoint(Index As Long, fValue As Single) With m_DataPoints(Index) ' 保存到数据库或文件 Dim sLine As String sLine = Format$(Now, "yyyy-mm-dd hh:mm:ss") & "," & _ .Name & "," & _ Format$(fValue, "0.00") & "," & _ .Unit ' WriteToFile sLine End With End Sub ``` *** ### 2. 设备控制 ```vb Option Explicit Private WithEvents mbMaster As cModbusMaster ' 设备控制命令 Public Enum DeviceCommand CMD_START = 1 CMD_STOP = 2 CMD_RESET = 3 CMD_EMERGENCY_STOP = 99 End Enum ' 控制线圈映射 Private Type CoilMapping Command As DeviceCommand Address As Long Value As Boolean End Type Private m_CoilMappings() As CoilMapping ' 初始化控制映射 Public Sub InitializeControlMappings() ReDim m_CoilMappings(3) As CoilMapping m_CoilMappings(0).Command = CMD_START m_CoilMappings(0).Address = 0 m_CoilMappings(0).Value = True m_CoilMappings(1).Command = CMD_STOP m_CoilMappings(1).Address = 1 m_CoilMappings(1).Value = True m_CoilMappings(2).Command = CMD_RESET m_CoilMappings(2).Address = 2 m_CoilMappings(2).Value = True m_CoilMappings(3).Command = CMD_EMERGENCY_STOP m_CoilMappings(3).Address = 10 m_CoilMappings(3).Value = True End Sub ' 执行设备控制命令 Public Function ExecuteCommand(Cmd As DeviceCommand) As Boolean On Error GoTo ErrorHandler Dim i As Long Dim bFound As Boolean ' 查找命令映射 For i = 0 To UBound(m_CoilMappings) If m_CoilMappings(i).Command = Cmd Then bFound = True Exit For End If Next i If Not bFound Then Debug.Print "Command not found: " & Cmd ExecuteCommand = False Exit Function End If ' 写入控制线圈 Dim bSuccess As Boolean bSuccess = mbMaster.WriteSingleCoil(m_CoilMappings(i).Address, m_CoilMappings(i).Value) If bSuccess Then Debug.Print "Command executed: " & GetCommandName(Cmd) ExecuteCommand = True Else Debug.Print "Command failed: " & GetCommandName(Cmd) ExecuteCommand = False End If Exit Function ErrorHandler: Debug.Print "ExecuteCommand error: " & Err.Description ExecuteCommand = False End Function ' 获取命令名称 Private Function GetCommandName(Cmd As DeviceCommand) As String Select Case Cmd Case CMD_START: GetCommandName = "启动" Case CMD_STOP: GetCommandName = "停止" Case CMD_RESET: GetCommandName = "复位" Case CMD_EMERGENCY_STOP: GetCommandName = "紧急停止" Case Else: GetCommandName = "未知" End Select End Function ' 安全控制:带确认的控制 Public Function SafeExecuteCommand(Cmd As DeviceCommand, bRequireConfirm As Boolean) As Boolean ' 如果需要确认 If bRequireConfirm Then Dim iResponse As Integer iResponse = MsgBox("确定要执行命令: " & GetCommandName(Cmd) & "?", _ vbQuestion + vbYesNo + vbDefaultButton2, _ "确认操作") If iResponse <> vbYes Then Debug.Print "Command cancelled by user" SafeExecuteCommand = False Exit Function End If End If ' 执行命令 Dim bResult As Boolean bResult = ExecuteCommand(Cmd) ' 记录操作日志 LogCommand Cmd, bResult SafeExecuteCommand = bResult End Function ' 记录命令日志 Private Sub LogCommand(Cmd As DeviceCommand, bSuccess As Boolean) Dim sStatus As String sStatus = IIf(bSuccess, "成功", "失败") Dim sLine As String sLine = Format$(Now, "yyyy-mm-dd hh:mm:ss") & "," & _ GetCommandName(Cmd) & "," & _ sStatus ' 写入日志文件 On Error Resume Next Dim iFile As Integer iFile = FreeFile Open App.Path & "\command_log.csv" For Append As #iFile Print #iFile, sLine Close #iFile On Error GoTo 0 End Sub ``` *** ### 3. 数据网关 ```vb Option Explicit Private WithEvents mbMaster As cModbusMaster ' 连接上位机 Private WithEvents mbSlave As cModbusSlave ' 连接下位机 ' 数据映射配置 Private Type DataMapping MasterAddr As Long ' 上位机地址 SlaveAddr As Long ' 下位机地址 Direction As Integer ' 0=Master到Slave, 1=Slave到Master ScaleFactor As Single ' 缩放因子 Offset As Single ' 偏移量 Enabled As Boolean End Type Private m_Mappings() As DataMapping ' 初始化数据映射 Public Sub InitializeDataMappings() ReDim m_Mappings(4) As DataMapping ' 映射1: 下位机温度 -> 上位机寄存器 m_Mappings(0).MasterAddr = 0 m_Mappings(0).SlaveAddr = 100 m_Mappings(0).Direction = 1 ' Slave到Master m_Mappings(0).ScaleFactor = 1.0 m_Mappings(0).Offset = 0 m_Mappings(0).Enabled = True ' 映射2: 上位机设定值 -> 下位机寄存器 m_Mappings(1).MasterAddr = 10 m_Mappings(1).SlaveAddr = 200 m_Mappings(1).Direction = 0 ' Master到Slave m_Mappings(1).ScaleFactor = 10.0 m_Mappings(1).Offset = 0 m_Mappings(1).Enabled = True ' ... 更多映射 End Sub ' 网关同步 Public Sub SyncGateway() On Error Resume Next Dim i As Long For i = 0 To UBound(m_Mappings) If Not m_Mappings(i).Enabled Then GoTo NextMapping Select Case m_Mappings(i).Direction Case 0 ' Master到Slave SyncMasterToSlave i Case 1 ' Slave到Master SyncSlaveToMaster i End Select NextMapping: Next i End Sub ' 同步Master到Slave Private Sub SyncMasterToSlave(Index As Long) Dim iMasterReg As Integer iMasterReg = mbMaster.ReadHoldingRegisters(m_Mappings(Index).MasterAddr, 1)(0) Dim fScaled As Single fScaled = (CSng(iMasterReg) * m_Mappings(Index).ScaleFactor) + m_Mappings(Index).Offset ' 写入Slave mbSlave.SetHoldingRegister m_Mappings(Index).SlaveAddr, CInt(fScaled) Debug.Print "Sync M[" & m_Mappings(Index).MasterAddr & "] -> S[" & _ m_Mappings(Index).SlaveAddr & "]: " & fScaled End Sub ' 同步Slave到Master Private Sub SyncSlaveToMaster(Index As Long) Dim iSlaveReg As Integer iSlaveReg = mbSlave.GetHoldingRegister(m_Mappings(Index).SlaveAddr) Dim fScaled As Single fScaled = (CSng(iSlaveReg) * m_Mappings(Index).ScaleFactor) + m_Mappings(Index).Offset ' 写入Master mbMaster.WriteSingleRegister m_Mappings(Index).MasterAddr, CInt(fScaled) Debug.Print "Sync S[" & m_Mappings(Index).SlaveAddr & "] -> M[" & _ m_Mappings(Index).MasterAddr & "]: " & fScaled End Sub ``` *** ## 常见问题 ### Q1: 如何处理大数据量? **方案**: 1. 分批读取,每次不超过最大寄存器数(125) 2. 使用定时器分时段读取 3. 实现数据缓存机制 ```vb ' 分批读取大数据量 Public Sub ReadLargeData(StartAddr As Long, TotalCount As Long) Dim lOffset As Long Dim lRemaining As Long Dim lBatchSize As Long Dim iBatch As Long lBatchSize = mbMaster.Defaults.MAX_REGISTERS lOffset = 0 lRemaining = TotalCount Do While lRemaining > 0 Dim lThisBatch As Long lThisBatch = IIf(lRemaining > lBatchSize, lBatchSize, lRemaining) Dim iRegs() As Integer iRegs = mbMaster.ReadHoldingRegisters(StartAddr + lOffset, lThisBatch) ' 处理数据 ProcessBatch iRegs, lOffset lOffset = lOffset + lThisBatch lRemaining = lRemaining - lThisBatch iBatch = iBatch + 1 Debug.Print "Batch " & iBatch & " completed" ' 避免过快请求 Sleep 10 Loop End Sub ``` *** ### Q2: 如何实现热备份? **方案**: 1. 同时连接主从两台设备 2. 主设备正常时读取主设备 3. 主设备故障时自动切换到备用设备 ```vb Option Explicit Private WithEvents mbMasterPrimary As cModbusMaster Private WithEvents mbMasterBackup As cModbusMaster Private m_UsePrimary As Boolean ' 切换到备用设备 Private Sub SwitchToBackup() On Error Resume Next mbMasterPrimary.Disconnect Dim iRegs() As Integer iRegs = mbMasterBackup.ReadHoldingRegisters(0, 1) If UBound(iRegs) >= 0 Then m_UsePrimary = False Debug.Print "Switched to backup device" RaiseEvent DeviceSwitched("Backup") Else Debug.Print "Backup device also failed" RaiseEvent AllDevicesFailed End If End Sub ' 尝试切换回主设备 Private Sub TrySwitchBack() On Error Resume Next mbMasterPrimary.Connect Dim iRegs() As Integer iRegs = mbMasterPrimary.ReadHoldingRegisters(0, 1) If UBound(iRegs) >= 0 Then m_UsePrimary = True Debug.Print "Switched back to primary device" RaiseEvent DeviceSwitched("Primary") End If End Sub ' 智能读取(自动选择设备) Public Function SmartRead(StartAddr As Long, Quantity As Long) As Integer() Dim iRegs() As Integer If m_UsePrimary Then ' 尝试从主设备读取 On Error Resume Next iRegs = mbMasterPrimary.ReadHoldingRegisters(StartAddr, Quantity) If UBound(iRegs) < 0 Then ' 主设备失败,切换到备用 SwitchToBackup If Not m_UsePrimary Then iRegs = mbMasterBackup.ReadHoldingRegisters(StartAddr, Quantity) End If End If Else ' 从备用设备读取 iRegs = mbMasterBackup.ReadHoldingRegisters(StartAddr, Quantity) ' 定期尝试切换回主设备 Static lSwitchCount As Long lSwitchCount = lSwitchCount + 1 If lSwitchCount > 10 Then TrySwitchBack lSwitchCount = 0 End If End If SmartRead = iRegs End Function ``` *** ### Q3: 如何实现断线重连? ```vb Option Explicit Private WithEvents mbMaster As cModbusMaster Private WithEvents tmrReconnect As Timer Private m_bAutoReconnect As Boolean Private m_lReconnectInterval As Long ' 毫秒 ' 启用自动重连 Public Sub EnableAutoReconnect(bEnable As Boolean, lInterval As Long) m_bAutoReconnect = bEnable m_lReconnectInterval = lInterval Set tmrReconnect = New Timer tmrReconnect.Interval = lInterval End Sub Private Sub mbMaster_OnDisconnect() If m_bAutoReconnect Then Debug.Print "Disconnected, will reconnect in " & (m_lReconnectInterval \ 1000) & "s" tmrReconnect.Enabled = True End If End Sub Private Sub tmrReconnect_Timer() tmrReconnect.Enabled = False On Error Resume Next mbMaster.Connect If Err.Number = 0 And mbMaster.State = MB_MASTER_STATE_CONNECTED Then Debug.Print "Reconnected successfully" Else ' 重连失败,继续尝试 tmrReconnect.Enabled = True End If End Sub ``` *** ## 下一步 * 查看 [master.md](./master.md) 了解主站详细 API * 查看 [slave.md](./slave.md) 了解从站详细 API * 查看 [quickstart.md](./quickstart.md) 快速入门 * 查看 [overview.md](./overview.md) 类库总览 *** **最后更新**: 2026-01-16 ### 更新日志 #### 2026-01-16 (v1.1.0) * 更新设备配置结构体，使用 `ModbusMasterProtocolType` * 添加 `BindAddress` 配置示例（从站） * 更新枚举引用（适配 v1.1.0 命名规范） --- --- url: /zh/vbman/modbus/overview.md --- # Modbus 类库开发文档 > ? **Modbus 类库** - 基于 cWinsock 封装的 VB6 Modbus 实现库，由 woeoio@qq.com 使用 claude ai 辅助开发 ## ? 目录 * [概述](#概述) * [核心亮点](#核心亮点) * [架构设计](#架构设计) * [文档索引](#文档索引) *** ## 概述 Modbus 类库是一个为 VB6 设计的轻量级 Modbus 通信库，完全符合 Modbus 协议规范（RTU 和 TCP）。它基于 cWinsock 类实现，提供了简洁易用的 API 和完整的功能支持。 ### ? 主要特性 * ? **纯类实现** - 无需控件，直接使用对象编程 * ? **分离式设计** - 主站（Master）和从站（Slave）独立类库，职责清晰 * ? **完整协议支持** - 支持 Modbus RTU 和 TCP 两种模式 * ? **完整功能码** - 支持所有标准 Modbus 功能码（0x01-0x10, 0x16, 0x17） * ? **高效缓冲区** - 使用 cByteBuffer 预分配字节缓冲区，减少内存分配操作 * ?? **自动处理** - 自动处理 MBAP 头（TCP）和 CRC 校验（RTU） * ? **数据存储** - 从站内置数据存储区，支持动态扩展 * ? **事件驱动** - 完整的事件机制，轻松处理连接、数据和错误 *** ## 核心亮点 ### 1?? 清晰的职责分离 ? 类库采用模块化设计，主站和从站完全独立： ```vb ' cModbusMaster - Modbus 主站（客户端） Set mbMaster = New cModbusMaster mbMaster.ProtocolType = MB_MASTER_PROTOCOL_TCP mbMaster.TCPHost = "192.168.1.100" mbMaster.TCPPort = 502 mbMaster.Connect ' cModbusSlave - Modbus 从站（服务器） Set mbSlave = New cModbusSlave mbSlave.ProtocolType = MB_SLAVE_PROTOCOL_TCP mbSlave.SlaveID = 1 mbSlave.BindAddress = "0.0.0.0" ' 监听所有接口（默认） mbSlave.Start 502 ' cByteBuffer - 高效字节缓冲区（内部使用） ' cWinsock - 底层 Socket 封装 ``` *** ### 2?? 双协议支持 ? 类库同时支持 Modbus RTU 和 TCP 两种模式： #### TCP 模式 ```vb mbMaster.ProtocolType = MB_MASTER_PROTOCOL_TCP mbMaster.TCPHost = "192.168.1.100" mbMaster.TCPPort = 502 mbMaster.Connect ``` #### RTU 模式 ```vb mbMaster.ProtocolType = MB_MASTER_PROTOCOL_RTU mbMaster.SerialPort = "COM1" mbMaster.BaudRate = 9600 mbMaster.DataBits = 8 mbMaster.Parity = "N" mbMaster.StopBits = 1 mbMaster.Connect "COM1" ``` *** ### 3?? 完整的功能码支持 ? 支持所有标准 Modbus 功能码： | 功能码 | 名称 | 说明 | | ------ | ----------------------------- | -------------- | | 0x01 | Read Coils | 读取线圈 | | 0x02 | Read Discrete Inputs | 读取离散输入 | | 0x03 | Read Holding Registers | 读取保持寄存器 | | 0x04 | Read Input Registers | 读取输入寄存器 | | 0x05 | Write Single Coil | 写入单个线圈 | | 0x06 | Write Single Register | 写入单个寄存器 | | 0x0F | Write Multiple Coils | 写入多个线圈 | | 0x10 | Write Multiple Registers | 写入多个寄存器 | | 0x16 | Mask Write Register | 掩码写寄存器 | | 0x17 | Read/Write Multiple Registers | 读写多个寄存器 | *** ### 4?? 从站数据存储 ? 从站类内置数据存储区，支持动态扩展： ```vb ' 设置线圈 mbSlave.SetCoil 0, True mbSlave.SetCoil 1, False ' 设置寄存器 mbSlave.SetHoldingRegister 0, 1234 mbSlave.SetHoldingRegister 1, 5678 ' 读取数据 Dim bCoil As Boolean bCoil = mbSlave.GetCoil(0) Dim iReg As Integer iReg = mbSlave.GetHoldingRegister(0) ``` *** ### 5?? 自动协议处理 ?? #### TCP 模式 - MBAP 头自动处理 ```vb ' 主站自动添加 MBAP 头 ' 从站自动解析 MBAP 头 ' 无需手动处理 Transaction ID、Protocol ID、Length、Unit ID ``` #### RTU 模式 - CRC 校验自动处理 ```vb ' 主站自动计算并添加 CRC16 ' 从站自动验证 CRC16 ' 无需手动处理校验 ``` *** ### 6?? 事件驱动模型 ? #### 主站事件 ```vb Event OnConnect() ' 连接成功 Event OnDisconnect() ' 连接断开 Event OnError(ByVal Description As String) ' 发生错误 Event OnDataReceived(Data() As Byte) ' 收到数据 ``` #### 从站事件 ```vb Event OnStarted() ' 服务器启动 Event OnStopped() ' 服务器停止 Event OnClientConnect(ByVal ClientID As String, ByVal RemoteAddress As String) ' 客户端连接 Event OnClientDisconnect(ByVal ClientID As String, ByVal Reason As String) ' 客户端断开 Event OnReadRequest(ByVal ClientID As String, ByVal FunctionCode As ModbusSlaveFunctionCode, ...) ' 读取请求 Event OnWriteRequest(ByVal ClientID As String, ByVal FunctionCode As ModbusSlaveFunctionCode, ...) ' 写入请求 Event OnError(ByVal Description As String) ' 发生错误 Event OnDataReceived(ByVal ClientID As String, Data() As Byte) ' 收到数据 ``` *** ### 7?? 异常码支持 ?? 完整的 Modbus 异常码支持： | 异常码 | 名称 | 说明 | | ------ | ---------------------------- | ---------------- | | 0x01 | Illegal Function | 非法功能码 | | 0x02 | Illegal Data Address | 非法数据地址 | | 0x03 | Illegal Data Value | 非法数据值 | | 0x04 | Slave Device Failure | 从站设备故障 | | 0x05 | Acknowledge | 确认 | | 0x06 | Slave Device Busy | 从站设备忙 | | 0x08 | Memory Parity Error | 内存奇偶校验错误 | | 0x0A | Gateway Path Unavailable | 网关路径不可用 | | 0x0B | Gateway Target Device Failed | 网关目标设备失败 | *** ## 架构设计 ### 类层次结构 ``` Modbus 类库 ├── cModbusMaster (主站/客户端) │ ├── m_Socket: cWinsock (TCP 连接 Socket) │ ├── m_hSerialPort: Long (RTU 串口句柄) │ ├── m_RTUBuffer: cByteBuffer (RTU 接收缓冲区) │ └── 请求构建/响应解析 │ ├── cModbusSlave (从站/服务器) │ ├── m_ListenSocket: cWinsock (TCP 监听 Socket) │ ├── m_Clients: Collection (TCP 客户端集合) │ ├── m_hSerialPort: Long (RTU 串口句柄) │ ├── m_RTUBuffer: cByteBuffer (RTU 接收缓冲区) │ ├── m_Coils: Boolean() (线圈数组) │ ├── m_DiscreteInputs: Boolean() (离散输入数组) │ ├── m_HoldingRegisters: Integer() (保持寄存器数组) │ └── m_InputRegisters: Integer() (输入寄存器数组) │ ├── cByteBuffer (字节缓冲区) │ └── 预分配、自动增长、Peek/Consume/Extract │ └── cWinsock (底层 Socket 封装) └── TCP 连接和数据收发 ``` *** ### 主站对象关系图 ``` cModbusMaster (主站) ├── TCP 模式 │ ├── Socket (连接 Socket: cWinsock) │ └── TransactionID (事务 ID) │ └── RTU 模式 ├── SerialPort (串口句柄) ├── RecvBuffer (cByteBuffer) └── SerialConfig (波特率、数据位、校验位、停止位) ``` *** ### 从站对象关系图 ``` cModbusSlave (从站) ├── TCP 模式 │ ├── ListenSocket (监听 Socket: cWinsock) │ ├── Clients 集合 │ │ ├── 客户端 1 (cWinsock) │ │ ├── 客户端 2 (cWinsock) │ │ └── ... │ └── 数据存储 │ ├── Coils (Boolean 数组) │ ├── DiscreteInputs (Boolean 数组) │ ├── HoldingRegisters (Integer 数组) │ └── InputRegisters (Integer 数组) │ └── RTU 模式 ├── SerialPort (串口句柄) ├── RecvBuffer (cByteBuffer) └── 数据存储 ├── Coils (Boolean 数组) ├── DiscreteInputs (Boolean 数组) ├── HoldingRegisters (Integer 数组) └── InputRegisters (Integer 数组) ``` *** ### 通信流程 #### 主站读取流程 ``` 1. 调用读取函数（如 ReadHoldingRegisters） ↓ 2. 构建请求帧 - RTU: SlaveID + FC + Addr(2) + Quantity(2) + CRC(2) - TCP: MBAP(7) + FC + Addr(2) + Quantity(2) ↓ 3. 发送请求 - RTU: 通过串口发送 - TCP: 通过 Socket 发送 ↓ 4. 等待响应（带超时） ↓ 5. 接收响应数据 - RTU: 验证 CRC - TCP: 验证 Transaction ID ↓ 6. 解析响应 - 检查异常码 - 提取数据 ↓ 7. 返回结果给调用者 ``` #### 从站处理流程 ``` 1. 启动服务器（监听 TCP 或打开串口） ↓ 2. 等待请求 ↓ 3. 接收到请求 - TCP: 客户端发送数据 - RTU: 串口接收数据 ↓ 4. 解析请求帧 - RTU: 验证 CRC - TCP: 解析 MBAP 头 ↓ 5. 检查 Slave ID - 是否发给我 ↓ 6. 根据功能码执行操作 - 读取数据：从内部存储区读取 - 写入数据：更新内部存储区 ↓ 7. 构建响应帧 - RTU: PDU + CRC(2) - TCP: MBAP(7) + PDU ↓ 8. 发送响应 - RTU: 通过串口发送 - TCP: 通过 Socket 发送 ``` *** ## 文档索引 | 文档 | 描述 | | ----------------------------- | ------------------------------------------- | | [总览文档](./overview.md) | Modbus 类库的整体介绍和设计理念（当前文档） | | [主站类详细文档](./master.md) | cModbusMaster 类的详细说明 | | [从站类详细文档](./slave.md) | cModbusSlave 类的详细说明 | | [快速开始](./quickstart.md) | 快速入门示例 | | [进阶应用](./advanced.md) | 高级功能和最佳实践 | *** ## 依赖关系 | 组件 | 描述 | | ------------------------------------------------------------ | ------------------------------------------------------- | | **cWinsock.cls** | 位于 `add/` 目录下的底层 Socket 封装，提供 TCP 连接功能 | | **cByteBuffer.cls** | 位于 `src/` 目录下的字节缓冲区类，用于高效处理字节数据 | | **cModbusMaster.cls** | 位于 `src/Modbus/` 目录下的 Modbus 主站类 | | **cModbusSlave.cls** | 位于 `src/Modbus/` 目录下的 Modbus 从站类 | | **ModbusMasterFunctionCode** / **ModbusSlaveFunctionCode** | 功能码枚举（v1.1.0+） | | **ModbusMasterExceptionCode** / **ModbusSlaveExceptionCode** | 异常码枚举（v1.1.0+） | | **ModbusMasterState** / **ModbusSlaveState** | 状态枚举（v1.1.0+） | | **ModbusMasterProtocolType** / **ModbusSlaveProtocolType** | 协议类型枚举（v1.1.0+） | | **ModbusMasterDefaults** / **ModbusSlaveDefaults** | 默认配置结构体（v1.1.0+） | *** ## 兼容性 * **VB6/VBA** - 完全兼容 * **Windows** - Windows XP 及以上版本 * **Modbus 协议** - Modbus RTU 和 TCP（完全兼容） * **串口** - 标准 COM 端口（RTU 模式） * **网络** - 标准 TCP/IP（TCP 模式） *** ## 许可证 基于 VbAsyncSocket (wqweto@gmail.com) 开发 *** ## 作者 **Modbus 类库**: woeoio@qq.com\ **基础 Socket 库**: woeoio@qq.com\ **原始 Socket 库**: wqweto@gmail.com *** ## 版本信息 * **文档版本**: 1.1.0 * **最后更新**: 2026-01-16 ### v1.1.0 重要更新 #### 1. 枚举命名规范化 为避免主从站类之间的枚举名称冲突，所有枚举类型已添加 `Master` 或 `Slave` 后缀： **主站枚举**: * `ModbusMasterFunctionCode` - 主站功能码 * `ModbusMasterExceptionCode` - 主站异常码 * `ModbusMasterState` - 主站状态 * `ModbusMasterProtocolType` - 主站协议类型 * `ModbusMasterDefaults` - 主站默认配置 **从站枚举**: * `ModbusSlaveFunctionCode` - 从站功能码 * `ModbusSlaveExceptionCode` - 从站异常码 * `ModbusSlaveState` - 从站状态 * `ModbusSlaveProtocolType` - 从站协议类型 * `ModbusSlaveDefaults` - 从站默认配置 #### 2. 新增 BindAddress 功能（从站） 从站类新增 `BindAddress` 属性，支持配置 TCP 监听地址： ```vb ' 仅监听本地连接（更安全） mbSlave.BindAddress = "127.0.0.1" mbSlave.Start 502 ' 监听所有网络接口（默认） mbSlave.BindAddress = "0.0.0.0" mbSlave.Start 502 ' 在 Start 方法中指定 mbSlave.Start 502, "192.168.1.100" ``` #### 3. 方法命名优化 `cModbusSlave.Stop()` 方法更名为 `StopMe()`，避免与 VB 关键字冲突。 **最后更新**: 2026-01-16 --- --- url: /zh/vbman/modbus/README.md --- # Modbus 文档目录 本目录包含 Modbus 类库的完整文档。 ## 文档列表 ### 1. [总览文档 (overview.md)](./overview.md) Modbus 类库的整体介绍和设计理念，包括： * 概述和主要特性 * 核心亮点（职责分离、双协议支持、完整功能码等） * 架构设计（类层次结构、对象关系图、通信流程） * 文档索引 * 依赖关系 * 兼容性说明 **适合人群**: 所有用户，特别是初次接触 Modbus 类库的开发者 *** ### 2. [主站类详细文档 (master.md)](./master.md) cModbusMaster 类的详细说明，包括： * 类概述 * 事件列表（OnConnect、OnDisconnect、OnError、OnDataReceived） * 属性参考（ProtocolType、State、SlaveID、RTU/TCP 配置等） * 方法参考（Connect、Disconnect、读写操作） * 事件详解 * 完整示例（基本主站、带重连的主站、数据采集） **适合人群**: 需要作为 Modbus 主站（客户端）的开发者 *** ### 3. [从站类详细文档 (slave.md)](./slave.md) cModbusSlave 类的详细说明，包括： * 类概述 * 事件列表（OnStarted、OnStopped、OnClientConnect、OnReadRequest 等） * 属性参考（ProtocolType、State、SlaveID、数据存储等） * 方法参考（Start、Stop、数据读写、数据管理等） * 事件详解 * 完整示例（基本从站、动态数据更新、多客户端处理） **适合人群**: 需要作为 Modbus 从站（服务器）的开发者 *** ### 4. [快速开始 (quickstart.md)](./quickstart.md) 快速入门指南，帮助用户快速上手 Modbus 类库： * 前置准备（必需文件、项目配置） * 主站快速入门（TCP 模式） * 从站快速入门（TCP 模式） * 主从通信示例 * RTU 模式快速开始 * 完整功能示例 * 常见问题解答 **适合人群**: 初学者、快速原型开发 *** ### 5. [进阶应用 (advanced.md)](./advanced.md) 高级功能和最佳实践，涵盖复杂应用场景： * 高级主题（主从站合一模式、事务管理、异步操作模式） * 性能优化（批量读取、频率控制、预缓存、连接池管理） * 错误处理（综合错误处理、异常码处理） * 多从站管理（设备配置管理、统一轮询管理） * 数据缓存策略（多级缓存、写入同步） * 日志与调试（详细日志记录、数据包调试） * 安全考虑（连接认证、数据加密） * 实际应用场景（工业数据采集、设备控制、数据网关） * 常见问题（大数据量处理、热备份、断线重连） **适合人群**: 有经验的开发者、需要实现复杂功能的用户 *** ## 阅读建议 ### 初次使用者 建议按以下顺序阅读： 1. [总览文档](./overview.md) - 了解整体架构和设计理念 2. [快速开始](./quickstart.md) - 快速上手，创建第一个应用 3. 根据需求选择： * 需要作为主站 → [主站类详细文档](./master.md) * 需要作为从站 → [从站类详细文档](./slave.md) ### 有经验的开发者 可以直接查阅相关文档： * 主站开发 → [master.md](./master.md) * 从站开发 → [slave.md](./slave.md) * 性能优化 → [advanced.md](./advanced.md) 性能优化章节 * 高级功能 → [advanced.md](./advanced.md) 相关章节 ### 快速参考 * 属性和方法 → 查看 [master.md](./master.md) 和 \[slave.md) 的属性/方法参考部分 * 示例代码 → 各文档的"完整示例"章节 * 常见问题 → [quickstart.md](./quickstart.md) 和 [advanced.md](./advanced.md) 的常见问题章节 *** ## 代码示例位置 除了文档中的示例代码外，还提供了完整的演示程序： ### 演示程序目录 * 位置: `src/Demos/Modbus/` * 包含: * `Master/` - 主站演示程序 * `Slave/` - 从站演示程序 * `DEMO_README.md` - 演示程序使用说明 ### 快速测试指南 * 位置: `src/Demos/Modbus/快速测试指南.md` * 内容: TCP 和 RTU 模式的详细测试步骤 *** ## 技术支持 如有问题或建议，请参考： * 演示程序: `src/Demos/Modbus/` * 示例代码: `src/Demos/Modbus/src/` * 类源代码: `src/Modbus/` *** ## 版本信息 * **文档版本**: 1.1.0 * **最后更新**: 2026-01-16 * **作者**: woeoio@qq.com * **基础库作者**: wqweto@gmail.com ### 版本更新日志 #### v1.1.0 (2026-01-16) * ? 新增 `BindAddress` 属性支持（从站）- 可配置监听地址（127.0.0.1、0.0.0.0 或指定 IP） * ? 更新枚举命名规范 - 添加 Master/Slave 后缀区分（如 `ModbusMasterFunctionCode`/`ModbusSlaveFunctionCode`） * ? 优化方法命名 - `Stop()` 更名为 `StopMe()` 避免与 VB 关键字冲突 * ? 更新结构体命名 - `ModbusDefaults` 分为 `ModbusMasterDefaults` 和 `ModbusSlaveDefaults` * ? 更新所有示例代码和文档以反映上述变更 #### v1.0.0 (2026-01-16) * 初始版本发布 * 支持 Modbus RTU 和 TCP 双协议 * 完整功能码支持（0x01-0x10, 0x16, 0x17） * 事件驱动模型 * 内置数据存储区 *** **提示**: 建议从 [总览文档](./overview.md) 开始阅读，了解类库的整体设计理念和使用方法。 --- --- url: /en/packages/vbccr/datetime/monthview.md description: >- MonthView Control - VBCCR Development Manual, complete API reference based on source code --- # MonthView Control Wraps the SysMonthCal32 system month calendar control for date selection and calendar display, supporting advanced features such as multi-date selection and multi-month views. ## Enumerations ### MvwViewConstants | Constant | Value | Description | |----------|-------|-------------| | MvwViewMonth | 0 | Month view | | MvwViewYear | 1 | Year view | | MvwViewDecade | 2 | Decade view | | MvwViewCentury | 3 | Century view | ### MvwHitResultConstants | Constant | Value | Description | |----------|-------|-------------| | MvwHitResultNowhere | 0 | No hit | | MvwHitResultTitleBg | 1 | Title background | | MvwHitResultTitleMonth | 2 | Title month | | MvwHitResultTitleYear | 3 | Title year | | MvwHitResultTitlePrevMonth | 4 | Previous month button | | MvwHitResultTitleNextMonth | 5 | Next month button | | MvwHitResultCalendarBg | 6 | Calendar background | | MvwHitResultCalendarDate | 7 | Calendar date | | MvwHitResultCalendarDateMin | 8 | Calendar minimum date | | MvwHitResultCalendarDateMax | 9 | Calendar maximum date | | MvwHitResultCalendarWeekNumber | 10 | Week number | | MvwHitResultCalendarPrevMonth | 11 | Previous month's date | | MvwHitResultCalendarNextMonth | 12 | Next month's date | | MvwHitResultTodayLink | 13 | "Today" link | ### CCMousePointerConstants See common enumerations. ## Properties ### Value ```vb Property Get Value() As Date Property Let Value(ByVal Value As Date) ``` Currently selected date. ### MinDate ```vb Property Get MinDate() As Date Property Let MinDate(ByVal Value As Date) ``` Minimum selectable date. ### MaxDate ```vb Property Get MaxDate() As Date Property Let MaxDate(ByVal Value As Date) ``` Maximum selectable date. ### Year ```vb Property Get Year() As Integer Property Let Year(ByVal Value As Integer) ``` Current year. ### Month ```vb Property Get Month() As Integer Property Let Month(ByVal Value As Integer) ``` Current month (1-12). ### Week ```vb Property Get Week() As Integer Property Let Week(ByVal Value As Integer) ``` Current week number. ### Day ```vb Property Get Day() As Integer Property Let Day(ByVal Value As Integer) ``` Current day (1-31). ### DayCount ```vb Property Get DayCount() As Long ``` Number of days in the currently visible month. Read-only. ### CalendarCount ```vb Property Get CalendarCount() As Long ``` Number of months currently displayed. Read-only. ### ShowToday ```vb Property Get ShowToday() As Boolean Property Let ShowToday(ByVal Value As Boolean) ``` Whether to display the "today" date. ### ShowTodayCircle ```vb Property Get ShowTodayCircle() As Boolean Property Let ShowTodayCircle(ByVal Value As Boolean) ``` Whether to circle today's date. ### ShowWeekNumbers ```vb Property Get ShowWeekNumbers() As Boolean Property Let ShowWeekNumbers(ByVal Value As Boolean) ``` Whether to display week numbers. ### ShowTrailingDates ```vb Property Get ShowTrailingDates() As Boolean Property Let ShowTrailingDates(ByVal Value As Boolean) ``` Whether to display trailing dates from the previous/next month. ### ScrollRate ```vb Property Get ScrollRate() As Long Property Let ScrollRate(ByVal Value As Long) ``` Scroll rate. ### StartOfWeek ```vb Property Get StartOfWeek() As Integer Property Let StartOfWeek(ByVal Value As Integer) ``` First day of the week (0=Sunday, 1=Monday...6=Saturday). ### MultiSelect ```vb Property Get MultiSelect() As Boolean Property Let MultiSelect(ByVal Value As Boolean) ``` Whether to allow multi-date selection. ### DayState ```vb Property Get DayState() As String Property Let DayState(ByVal Value As String) ``` Day state bitmap string that controls bold display of dates. ### MaxSelCount ```vb Property Get MaxSelCount() As Long Property Let MaxSelCount(ByVal Value As Long) ``` Maximum selectable days in multi-select mode. ### MonthColumns ```vb Property Get MonthColumns() As Long Property Let MonthColumns(ByVal Value As Long) ``` Number of months displayed horizontally. ### MonthRows ```vb Property Get MonthRows() As Long Property Let MonthRows(ByVal Value As Long) ``` Number of months displayed vertically. ### View ```vb Property Get View() As MvwViewConstants Property Let View(ByVal Value As MvwViewConstants) ``` Calendar view mode. ### UseShortestDayNames ```vb Property Get UseShortestDayNames() As Boolean Property Let UseShortestDayNames(ByVal Value As Boolean) ``` Whether to use the shortest day-of-week names. ### BackColor ```vb Property Get BackColor() As OLE_COLOR Property Let BackColor(ByVal Value As OLE_COLOR) ``` Background color. ### ForeColor ```vb Property Get ForeColor() As OLE_COLOR Property Let ForeColor(ByVal Value As OLE_COLOR) ``` Foreground color. ### TitleBackColor ```vb Property Get TitleBackColor() As OLE_COLOR Property Let TitleBackColor(ByVal Value As OLE_COLOR) ``` Title background color. ### TitleForeColor ```vb Property Get TitleForeColor() As OLE_COLOR Property Let TitleForeColor(ByVal Value As OLE_COLOR) ``` Title foreground color. ### TrailingForeColor ```vb Property Get TrailingForeColor() As OLE_COLOR Property Let TrailingForeColor(ByVal Value As OLE_COLOR) ``` Foreground color for trailing dates. ### SelStart ```vb Property Get SelStart() As Date Property Let SelStart(ByVal Value As Date) ``` Start date of the selection range. ### SelEnd ```vb Property Get SelEnd() As Date Property Let SelEnd(ByVal Value As Date) ``` End date of the selection range. ### Today ```vb Property Get Today() As Date ``` Returns today's date. Read-only. ### SystemStartOfWeek ```vb Property Get SystemStartOfWeek() As Integer ``` Returns the system setting for the first day of the week. Read-only. ### DayOfWeek ```vb Property Get DayOfWeek() As Integer ``` Returns the day of the week corresponding to Value. Read-only. ### VisualStyles ```vb Property Get VisualStyles() As Boolean Property Let VisualStyles(ByVal Value As Boolean) ``` Whether to enable visual styles. ### hWnd ```vb Property Get hWnd() As LongPtr ``` Window handle of the month view control. ### hWndUserControl ```vb Property Get hWndUserControl() As LongPtr ``` Window handle of the user control. ### Font ```vb Property Get Font() As StdFont Property Let Font(ByVal NewFont As StdFont) Property Set Font(ByVal NewFont As StdFont) ``` Font. ### Enabled ```vb Property Get Enabled() As Boolean Property Let Enabled(ByVal Value As Boolean) ``` Whether the control is enabled. ### MousePointer ```vb Property Get MousePointer() As CCMousePointerConstants Property Let MousePointer(ByVal Value As CCMousePointerConstants) ``` Mouse pointer style. See common enumerations. ### MouseIcon ```vb Property Get MouseIcon() As IPictureDisp Property Let MouseIcon(ByVal Value As IPictureDisp) Property Set MouseIcon(ByVal Value As IPictureDisp) ``` Custom mouse icon. ### MouseTrack ```vb Property Get MouseTrack() As Boolean Property Let MouseTrack(ByVal Value As Boolean) ``` Whether to enable mouse enter/leave tracking. ### RightToLeft ```vb Property Get RightToLeft() As Boolean Property Let RightToLeft(ByVal Value As Boolean) ``` Right-to-left display direction. ### RightToLeftMode ```vb Property Get RightToLeftMode() As CCRightToLeftModeConstants Property Let RightToLeftMode(ByVal Value As CCRightToLeftModeConstants) ``` Right-to-left mode. See common enumerations. ### Name ```vb Property Get Name() As String ``` Control name. Read-only. ### Tag ```vb Property Get Tag() As String Property Let Tag(ByVal Value As String) ``` Custom data. ### Parent ```vb Property Get Parent() As Object ``` Parent object. Read-only. ### Container ```vb Property Get Container() As Object Property Set Container(ByVal Value As Object) ``` Container object. ### Left ```vb Property Get Left() As Single Property Let Left(ByVal Value As Single) ``` Left position. ### Top ```vb Property Get Top() As Single Property Let Top(ByVal Value As Single) ``` Top position. ### Width ```vb Property Get Width() As Single Property Let Width(ByVal Value As Single) ``` Width. ### Height ```vb Property Get Height() As Single Property Let Height(ByVal Value As Single) ``` Height. ### Visible ```vb Property Get Visible() As Boolean Property Let Visible(ByVal Value As Boolean) ``` Whether the control is visible. ### ToolTipText ```vb Property Get ToolTipText() As String Property Let ToolTipText(ByVal Value As String) ``` Tooltip text. ### HelpContextID ```vb Property Get HelpContextID() As Long Property Let HelpContextID(ByVal Value As Long) ``` Help context ID. ### WhatsThisHelpID ```vb Property Get WhatsThisHelpID() As Long Property Let WhatsThisHelpID(ByVal Value As Long) ``` "What's This" help ID. ### DragIcon ```vb Property Get DragIcon() As IPictureDisp Property Let DragIcon(ByVal Value As IPictureDisp) Property Set DragIcon(ByVal Value As IPictureDisp) ``` Drag icon. ### DragMode ```vb Property Get DragMode() As Integer Property Let DragMode(ByVal Value As Integer) ``` Drag mode. ## Methods ### SetSelRange ```vb Public Sub SetSelRange(ByVal StartDate As Date, ByVal EndDate As Date) ``` Sets the date selection range. ### ComputeControlSize ```vb Public Sub ComputeControlSize() ``` Recalculates the control size based on current settings. ### GetMonthRange ```vb Public Function GetMonthRange() As String ``` Retrieves the currently displayed month range. ### HitTest ```vb Public Function HitTest(ByVal X As Single, ByVal Y As Single) As MvwHitResultConstants ``` Tests the hit area at the specified coordinates. ### Drag ```vb Public Sub Drag([ByRef Action As Variant]) ``` Starts, ends, or cancels a drag operation. ### SetFocus ```vb Public Sub SetFocus() ``` Moves focus to the control. ### ZOrder ```vb Public Sub ZOrder([ByRef Position As Variant]) ``` Sets the Z-order of the control. ### OLEDrag ```vb Public Sub OLEDrag() ``` Initiates an OLE drag-and-drop operation. ### Refresh ```vb Public Sub Refresh() ``` Forces the control to repaint. ## Events ### GetDayBold ```vb Public Event GetDayBold(ByRef DayState As String) ``` Fired when bold state for dates is needed. ### SelChange ```vb Public Event SelChange(ByVal StartDate As Date, ByVal EndDate As Date) ``` Fired when the selection range changes. ### DateClick ```vb Public Event DateClick(ByVal DateClicked As Date) ``` Fired when a date is clicked. ### ViewChange ```vb Public Event ViewChange() ``` Fired when the view mode changes. ### ContextMenu ```vb Public Event ContextMenu(ByRef Handled As Boolean, ByVal X As Single, ByVal Y As Single) ``` Fired when right-clicking or pressing Shift+F10. ### Click ```vb Public Event Click() ``` Fired when the control is clicked. ### DblClick ```vb Public Event DblClick() ``` Fired when the control is double-clicked. ### MouseDown ```vb Public Event MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` Fired when a mouse button is pressed. ### MouseUp ```vb Public Event MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` Fired when a mouse button is released. ### MouseMove ```vb Public Event MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` Fired when the mouse is moved. ### MouseEnter ```vb Public Event MouseEnter() ``` Fired when the mouse enters the control. ### MouseLeave ```vb Public Event MouseLeave() ``` Fired when the mouse leaves the control. ### KeyDown ```vb Public Event KeyDown(KeyCode As Integer, Shift As Integer) ``` Fired when a key is pressed. ### KeyUp ```vb Public Event KeyUp(KeyCode As Integer, Shift As Integer) ``` Fired when a key is released. ### KeyPress ```vb Public Event KeyPress(KeyChar As Integer) ``` Fired when a key character is input. ### OLEDragDrop ```vb Public Event OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single) ``` Fired when an OLE drag-and-drop operation is completed. ### OLEDragOver ```vb Public Event OLEDragOver(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single, State As Integer) ``` Fired when an OLE drag-and-drop operation passes over the control. ### OLEGiveFeedback ```vb Public Event OLEGiveFeedback(Effect As Long, DefaultCursors As Boolean) ``` Fired when the OLE drag-and-drop operation needs to change the cursor. ### OLEStartDrag ```vb Public Event OLEStartDrag(Data As DataObject, AllowedEffects As Long) ``` Fired when an OLE drag-and-drop operation starts. ### OLECompleteDrag ```vb Public Event OLECompleteDrag(Effect As Long) ``` Fired when an OLE drag-and-drop operation completes. ### OLESetData ```vb Public Event OLESetData(Data As DataObject, DataFormat As Integer) ``` Fired when the OLE drop target requests data. ## Code Examples ```vb ' Basic date selection MonthView1.Value = Date ' Limit selectable date range MonthView1.MinDate = #1/1/2025# MonthView1.MaxDate = #12/31/2025# ' Multi-date selection MonthView1.MultiSelect = True MonthView1.MaxSelCount = 7 Call MonthView1.SetSelRange(#1/1/2025#, #1/7/2025#) ' Multi-month display MonthView1.MonthColumns = 2 MonthView1.MonthRows = 1 ``` --- --- url: /zh/vbman/websocket/utils.md --- # mWebSocketUtils 工具模块参考 ## 📋 模块概述 `mWebSocketUtils` 是 WebSocket 类库的公共工具模块，提供以下功能： * UTF-8 编码/解码 * Base64 编码 * SHA1 哈希计算 * WebSocket Key 生成和验证 * HTTP 头解析 * 关闭码描述获取 *** ## 📊 公共枚举 ### WsOpCode - WebSocket 操作码 ```vb Public Enum WsOpCode WS_OPCODE_CONTINUATION = 0 ' 分片帧的后续帧 WS_OPCODE_TEXT = 1 ' 文本数据帧 WS_OPCODE_BINARY = 2 ' 二进制数据帧 WS_OPCODE_CLOSE = 8 ' 关闭连接帧 WS_OPCODE_PING = 9 ' Ping 帧 WS_OPCODE_PONG = 10 ' Pong 帧 End Enum ``` *** ### WsCloseCode - WebSocket 关闭状态码 ```vb Public Enum WsCloseCode WS_CLOSE_NORMAL = 1000 ' 正常关闭 WS_CLOSE_GOING_AWAY = 1001 ' 端点离开 WS_CLOSE_PROTOCOL_ERROR = 1002 ' 协议错误 WS_CLOSE_UNSUPPORTED_DATA = 1003 ' 不支持的数据类型 WS_CLOSE_NO_STATUS = 1005 ' 无状态（本地） WS_CLOSE_ABNORMAL = 1006 ' 异常关闭（本地） WS_CLOSE_INVALID_DATA = 1007 ' 无效数据 WS_CLOSE_POLICY_VIOLATION = 1008 ' 策略违规 WS_CLOSE_MESSAGE_TOO_BIG = 1009 ' 消息过大 WS_CLOSE_MANDATORY_EXT = 1010 ' 必需的扩展 WS_CLOSE_INTERNAL_ERROR = 1011 ' 内部错误 WS_CLOSE_SERVICE_RESTART = 1012 ' 服务重启 WS_CLOSE_TRY_AGAIN = 1013 ' 稍后重试 End Enum ``` *** ### WsState - WebSocket 连接状态 ```vb Public Enum WsState WS_STATE_CLOSED = 0 ' 已关闭 WS_STATE_CONNECTING = 1 ' 正在连接 WS_STATE_OPEN = 2 ' 已打开 WS_STATE_CLOSING = 3 ' 正在关闭 End Enum ``` *** ## 🔧 UTF-8 函数 ### StringToUTF8 - 字符串转 UTF-8 **语法**: ```vb Public Function StringToUTF8(ByVal Text As String) As Byte() ``` **参数**: | 参数 | 类型 | 说明 | |------|------|------| | `Text` | String | 要转换的字符串 | **返回值**: UTF-8 编码的字节数组 **示例**: ```vb ' 简单转换 Dim baUTF8() As Byte baUTF8 = StringToUTF8("Hello WebSocket!") ' 中文转换 baUTF8 = StringToUTF8("你好世界") ' 空字符串 baUTF8 = StringToUTF8("") ' 返回空数组 ' 用于 WebSocket 发送 Dim sMessage As String sMessage = "测试消息" m_Client.SendText sMessage ' 内部会调用 StringToUTF8 ``` *** ### UTF8ToString - UTF-8 转字符串 **语法**: ```vb Public Function UTF8ToString(ByRef Utf8Data() As Byte) As String ``` **参数**: | 参数 | 类型 | 说明 | |------|------|------| | `Utf8Data()` | Byte() | UTF-8 编码的字节数组 | **返回值**: 解码后的字符串 **示例**: ```vb ' 解码 UTF-8 数据 Dim baData() As Byte baData = LoadFile("utf8.txt") Dim sText As String sText = UTF8ToString(baData) Debug.Print sText ' WebSocket 消息解码 Private Sub m_Client_OnTextMessage(ByVal Message As String) ' Message 已经是解码后的字符串 Debug.Print Message End Sub ' 手动解码 Dim sDecoded As String sDecoded = UTF8ToString(baPayload) ``` *** ## 📦 Base64 函数 ### Base64Encode - Base64 编码 **语法**: ```vb Public Function Base64Encode(ByRef Data() As Byte) As Byte() ``` **参数**: | 参数 | 类型 | 说明 | |------|------|------| | `Data()` | Byte() | 要编码的字节数组 | **返回值**: Base64 编码的字符串 **说明**: * 使用标准 Base64 字符集（A-Z, a-z, 0-9, +, /） * 使用 `=` 作为填充符 * 用于 WebSocket 握手的 Key 和 Accept 编码 **示例**: ```vb ' 编码随机数据 Dim baData(15) As Byte Randomize Timer For i = 0 To 15 baData(i) = CByte(Int(Rnd * 256)) Next i Dim sBase64 As String sBase64 = Base64Encode(baData) Debug.Print "Base64: " & sBase64 ' 生成 WebSocket Key Dim sKey As String sKey = GenerateWebSocketKey() Debug.Print "WebSocket Key: " & sKey ``` *** ## 🔐 SHA1 函数 ### SHA1Hash - 计算 SHA1 哈希 **语法**: ```vb Public Function SHA1Hash(ByRef Data() As Byte) As Byte() ``` **参数**: | 参数 | 类型 | 说明 | |------|------|------| | `Data()` | Byte() | 要哈希的数据 | **返回值**: 20 字节的 SHA1 哈希值 **说明**: * 使用 Windows CryptoAPI * 返回原始 20 字节哈希值 **示例**: ```vb ' 计算 SHA1 哈希 Dim baData() As Byte baData = StringToUTF8("Hello World") Dim baHash() As Byte baHash = SHA1Hash(baData) Dim sHashHex As String sHashHex = BytesToHex(baHash) Debug.Print "SHA1: " & sHashHex ' 用于 WebSocket Accept Key 计算 Dim sCombined As String sCombined = sClientKey & WS_MAGIC_GUID Dim baCombined() As Byte baCombined = StrConv(sCombined, vbFromUnicode) Dim baHash() As Byte baHash = SHA1Hash(baCombined) ``` *** ## 🔑 WebSocket Key 函数 ### GenerateWebSocketKey - 生成 WebSocket Key **语法**: ```vb Public Function GenerateWebSocketKey() As String ``` **返回值**: Base64 编码的随机 16 字节 Key **说明**: * 用于客户端握手 * 生成随机 16 字节 * Base64 编码后返回 **示例**: ```vb ' 客户端自动调用（内部使用） Dim sKey As String sKey = GenerateWebSocketKey() Debug.Print "WebSocket Key: " & sKey ' 输出示例: dGhlIHNhbXBsZSBub25jZQ== ``` *** ### ComputeAcceptKey - 计算 Accept Key **语法**: ```vb Public Function ComputeAcceptKey(ByVal ClientKey As String) As String ``` **参数**: | 参数 | 类型 | 说明 | |------|------|------| | `ClientKey` | String | 客户端发送的 WebSocket Key | **返回值**: 服务端应返回的 Accept Key **说明**: * 计算 `ClientKey + WS_MAGIC_GUID` 的 SHA1 哈希 * Base64 编码结果 * 用于服务端握手验证 **示例**: ```vb ' 服务端计算 Accept Key（内部使用） Dim sClientKey As String sClientKey = GetHeaderValue(sHandshake, "Sec-WebSocket-Key") Dim sAcceptKey As String sAcceptKey = ComputeAcceptKey(sClientKey) Debug.Print "Accept Key: " & sAcceptKey ' 输出 HTTP 响应头 Dim sResponse As String sResponse = "HTTP/1.1 101 Switching Protocols" & vbCrLf sResponse = sResponse & "Sec-WebSocket-Accept: " & sAcceptKey & vbCrLf sResponse = sResponse & vbCrLf ``` *** ### WS\_MAGIC\_GUID - WebSocket 魔数 **常量**: ```vb Public Const WS_MAGIC_GUID As String = "258EAFA5-E914-47DA-95CA-C5AB0DC85B11" ``` **说明**: WebSocket 握手使用的固定 GUID，用于计算 Accept Key。 *** ### WS\_VERSION - WebSocket 协议版本 **常量**: ```vb Public Const WS_VERSION As String = "13" ``` **说明**: WebSocket 协议版本号（RFC 6455）。 *** ## 📋 HTTP 头解析函数 ### GetHeaderValue - 获取 HTTP 头值 **语法**: ```vb Public Function GetHeaderValue(ByVal HttpText As String, ByVal HeaderName As String) As String ``` **参数**: | 参数 | 类型 | 说明 | |------|------|------| | `HttpText` | String | HTTP 请求/响应文本 | | `HeaderName` | String | 头名称（不区分大小写） | **返回值**: 头值，未找到返回空字符串 **示例**: ```vb ' 获取 Host 头 Dim sRequest As String sRequest = "GET /chat HTTP/1.1" & vbCrLf sRequest = sRequest & "Host: example.com:8080" & vbCrLf sRequest = sRequest & "Upgrade: websocket" & vbCrLf sRequest = sRequest & vbCrLf Dim sHost As String sHost = GetHeaderValue(sRequest, "Host") Debug.Print "Host: " & sHost ' 输出: example.com:8080 ' 获取 WebSocket Key Dim sKey As String sKey = GetHeaderValue(sRequest, "Sec-WebSocket-Key") ' 获取 Connection 头 Dim sConnection As String sConnection = GetHeaderValue(sRequest, "Connection") ``` *** ## 📝 关闭码描述函数 ### GetCloseCodeDescription - 获取关闭码描述 **语法**: ```vb Public Function GetCloseCodeDescription(ByVal Code As WsCloseCode) As String ``` **参数**: | 参数 | 类型 | 说明 | |------|------|------| | `Code` | WsCloseCode | 关闭状态码 | **返回值**: 关闭码的文本描述 **示例**: ```vb Dim sDesc As String sDesc = GetCloseCodeDescription(WS_CLOSE_NORMAL) Debug.Print sDesc ' 输出: Normal closure sDesc = GetCloseCodeDescription(WS_CLOSE_ABNORMAL) Debug.Print sDesc ' 输出: Abnormal closure sDesc = GetCloseCodeDescription(1000) Debug.Print sDesc ' 输出: Normal closure sDesc = GetCloseCodeDescription(9999) Debug.Print sDesc ' 输出: Unknown (9999) ' 在 OnClose 事件中使用 Private Sub m_Client_OnClose(ByVal Code As WsCloseCode, ByVal Reason As String) Debug.Print "关闭码: " & Code Debug.Print "描述: " & GetCloseCodeDescription(Code) If LenB(Reason) > 0 Then Debug.Print "原因: " & Reason End If End Sub ``` *** ## 🧹 清理函数 ### CleanupCryptoProvider - 清理 CryptoAPI 资源 **语法**: ```vb Public Sub CleanupCryptoProvider() ``` **说明**: * 释放 CryptoAPI 上下文 * 通常在程序结束时调用 **示例**: ```vb ' 程序退出时清理 Private Sub Form_Unload(Cancel As Integer) CleanupCryptoProvider End Sub ``` *** ## 📝 完整使用示例 ### WebSocket 握手流程 ```vb ' 客户端发送握手请求 Private Sub SendHandshake() Dim sKey As String sKey = GenerateWebSocketKey() Dim sHandshake As String sHandshake = "GET /chat HTTP/1.1" & vbCrLf sHandshake = sHandshake & "Host: example.com:8080" & vbCrLf sHandshake = sHandshake & "Upgrade: websocket" & vbCrLf sHandshake = sHandshake & "Connection: Upgrade" & vbCrLf sHandshake = sHandshake & "Sec-WebSocket-Key: " & sKey & vbCrLf sHandshake = sHandshake & "Sec-WebSocket-Version: " & WS_VERSION & vbCrLf sHandshake = sHandshake & vbCrLf m_Socket.SendData sHandshake, ScpUtf8 End Sub ' 服务端处理握手请求 Private Function HandleHandshake(ByVal sRequest As String) As Boolean ' 获取客户端 Key Dim sKey As String sKey = GetHeaderValue(sRequest, "Sec-WebSocket-Key") If LenB(sKey) = 0 Then HandleHandshake = False Exit Function End If ' 计算 Accept Key Dim sAccept As String sAccept = ComputeAcceptKey(sKey) ' 发送响应 Dim sResponse As String sResponse = "HTTP/1.1 101 Switching Protocols" & vbCrLf sResponse = sResponse & "Upgrade: websocket" & vbCrLf sResponse = sResponse & "Connection: Upgrade" & vbCrLf sResponse = sResponse & "Sec-WebSocket-Accept: " & sAccept & vbCrLf sResponse = sResponse & vbCrLf m_Socket.SendData sResponse, ScpUtf8 HandleHandshake = True End Function ' 客户端验证握手响应 Private Function ValidateResponse(ByVal sResponse As String) As Boolean ' 检查状态码 If InStr(sResponse, "101") = 0 Then ValidateResponse = False Exit Function End If ' 获取 Accept Key Dim sAccept As String sAccept = GetHeaderValue(sResponse, "Sec-WebSocket-Accept") ' 计算预期值 Dim sExpected As String sExpected = ComputeAcceptKey(m_sClientKey) ' 验证 ValidateResponse = (sAccept = sExpected) End Function ``` ### 文本消息处理 ```vb ' 发送文本消息 Public Sub SendTextMessage(ByVal sText As String) Dim baPayload() As Byte baPayload = StringToUTF8(sText) Dim oFrame As New cWebSocketFrame Dim baFrame() As Byte baFrame = oFrame.BuildFrame(baPayload, WS_OPCODE_TEXT, True, True) m_Socket.SendData baFrame End Sub ' 接收文本消息 Private Sub ProcessTextFrame(ByVal baPayload() As Byte) Dim sText As String sText = UTF8ToString(baPayload) Debug.Print "收到文本: " & sText ' 处理消息... End Sub ``` ### 自定义数据处理 ```vb ' 序列化对象为 UTF-8 JSON Public Function SerializeJSON(ByVal oObject As Object) As Byte() Dim sJSON As String sJSON = ToJSONString(oObject) Dim baData() As Byte baData = StringToUTF8(sJSON) SerializeJSON = baData End Function ' 反序列化 UTF-8 JSON 为对象 Public Function DeserializeJSON(ByVal baData() As Byte) As Object Dim sJSON As String sJSON = UTF8ToString(baData) Set DeserializeJSON = FromJSONString(sJSON) End Function ``` *** ## ⚠️ 注意事项 1. **CryptoAPI 初始化** - SHA1Hash 会自动初始化 CryptoAPI 2. **资源清理** - 程序结束时调用 CleanupCryptoProvider 3. **编码一致性** - 发送和接收都使用 UTF-8 编码 4. **头名称不区分大小写** - GetHeaderValue 会忽略大小写 *** **最后更新**: 2026-01-10 --- --- url: /en/vbman/websocket/utils.md --- # mWebSocketUtils Utility Module Reference ## 📋 Module Overview `mWebSocketUtils` is the public utility module for the WebSocket class library, providing the following functionality: * UTF-8 encoding/decoding * Base64 encoding * SHA1 hash calculation * WebSocket Key generation and verification * HTTP header parsing * Close code description retrieval *** ## 📊 Public Enums ### WsOpCode - WebSocket Operation Codes ```vb Public Enum WsOpCode WS_OPCODE_CONTINUATION = 0 ' Continuation frames for fragmented messages WS_OPCODE_TEXT = 1 ' Text data frame WS_OPCODE_BINARY = 2 ' Binary data frame WS_OPCODE_CLOSE = 8 ' Connection close frame WS_OPCODE_PING = 9 ' Ping frame WS_OPCODE_PONG = 10 ' Pong frame End Enum ``` *** ### WsCloseCode - WebSocket Close Status Codes ```vb Public Enum WsCloseCode WS_CLOSE_NORMAL = 1000 ' Normal closure WS_CLOSE_GOING_AWAY = 1001 ' Endpoint going away WS_CLOSE_PROTOCOL_ERROR = 1002 ' Protocol error WS_CLOSE_UNSUPPORTED_DATA = 1003 ' Unsupported data type WS_CLOSE_NO_STATUS = 1005 ' No status (local) WS_CLOSE_ABNORMAL = 1006 ' Abnormal closure (local) WS_CLOSE_INVALID_DATA = 1007 ' Invalid data WS_CLOSE_POLICY_VIOLATION = 1008 ' Policy violation WS_CLOSE_MESSAGE_TOO_BIG = 1009 ' Message too large WS_CLOSE_MANDATORY_EXT = 1010 ' Mandatory extension WS_CLOSE_INTERNAL_ERROR = 1011 ' Internal error WS_CLOSE_SERVICE_RESTART = 1012 ' Service restart WS_CLOSE_TRY_AGAIN = 1013 ' Try again later End Enum ``` *** ### WsState - WebSocket Connection State ```vb Public Enum WsState WS_STATE_CLOSED = 0 ' Closed WS_STATE_CONNECTING = 1 ' Connecting WS_STATE_OPEN = 2 ' Open WS_STATE_CLOSING = 3 ' Closing End Enum ``` *** ## 🔧 UTF-8 Functions ### StringToUTF8 - String to UTF-8 **Syntax**: ```vb Public Function StringToUTF8(ByVal Text As String) As Byte() ``` **Parameters**: | Parameter | Type | Description | |-----------|------|-------------| | `Text` | String | String to convert | **Return Value**: UTF-8 encoded byte array **Example**: ```vb ' Simple conversion Dim baUTF8() As Byte baUTF8 = StringToUTF8("Hello WebSocket!") ' Chinese conversion baUTF8 = StringToUTF8("你好世界") ' Empty string baUTF8 = StringToUTF8("") ' Returns empty array ' For WebSocket sending Dim sMessage As String sMessage = "测试消息" m_Client.SendText sMessage ' Internally calls StringToUTF8 ``` *** ### UTF8ToString - UTF-8 to String **Syntax**: ```vb Public Function UTF8ToString(ByRef Utf8Data() As Byte) As String ``` **Parameters**: | Parameter | Type | Description | |-----------|------|-------------| | `Utf8Data()` | Byte() | UTF-8 encoded byte array | **Return Value**: Decoded string **Example**: ```vb ' Decode UTF-8 data Dim baData() As Byte baData = LoadFile("utf8.txt") Dim sText As String sText = UTF8ToString(baData) Debug.Print sText ' WebSocket message decoding Private Sub m_Client_OnTextMessage(ByVal Message As String) ' Message is already decoded string Debug.Print Message End Sub ' Manual decoding Dim sDecoded As String sDecoded = UTF8ToString(baPayload) ``` *** ## 📦 Base64 Functions ### Base64Encode - Base64 Encoding **Syntax**: ```vb Public Function Base64Encode(ByRef Data() As Byte) As String ``` **Parameters**: | Parameter | Type | Description | |-----------|------|-------------| | `Data()` | Byte() | Byte array to encode | **Return Value**: Base64 encoded string **Description**: * Uses standard Base64 character set (A-Z, a-z, 0-9, +, /) * Uses `=` as padding character * Used for WebSocket handshake Key and Accept encoding **Example**: ```vb ' Encode random data Dim baData(15) As Byte Randomize Timer For i = 0 To 15 baData(i) = CByte(Int(Rnd * 256)) Next i Dim sBase64 As String sBase64 = Base64Encode(baData) Debug.Print "Base64: " & sBase64 ' Generate WebSocket Key Dim sKey As String sKey = GenerateWebSocketKey() Debug.Print "WebSocket Key: " & sKey ``` *** ## 🔐 SHA1 Functions ### SHA1Hash - Calculate SHA1 Hash **Syntax**: ```vb Public Function SHA1Hash(ByRef Data() As Byte) As Byte() ``` **Parameters**: | Parameter | Type | Description | |-----------|------|-------------| | `Data()` | Byte() | Data to hash | **Return Value**: 20-byte SHA1 hash value **Description**: * Uses Windows CryptoAPI * Returns raw 20-byte hash value **Example**: ```vb ' Calculate SHA1 hash Dim baData() As Byte baData = StringToUTF8("Hello World") Dim baHash() As Byte baHash = SHA1Hash(baData) Dim sHashHex As String sHashHex = BytesToHex(baHash) Debug.Print "SHA1: " & sHashHex ' For WebSocket Accept Key calculation Dim sCombined As String sCombined = sClientKey & WS_MAGIC_GUID Dim baCombined() As Byte baCombined = StrConv(sCombined, vbFromUnicode) Dim baHash() As Byte baHash = SHA1Hash(baCombined) ``` *** ## 🔑 WebSocket Key Functions ### GenerateWebSocketKey - Generate WebSocket Key **Syntax**: ```vb Public Function GenerateWebSocketKey() As String ``` **Return Value**: Base64 encoded random 16-byte Key **Description**: * Used for client handshake * Generates random 16 bytes * Returns Base64 encoded result **Example**: ```vb ' Client auto calls (internal use) Dim sKey As String sKey = GenerateWebSocketKey() Debug.Print "WebSocket Key: " & sKey ' Output example: dGhlIHNhbXBsZSBub25jZQ== ``` *** ### ComputeAcceptKey - Compute Accept Key **Syntax**: ```vb Public Function ComputeAcceptKey(ByVal ClientKey As String) As String ``` **Parameters**: | Parameter | Type | Description | |-----------|------|-------------| | `ClientKey` | String | WebSocket Key sent by client | **Return Value**: Accept Key that server should return **Description**: * Calculates SHA1 hash of `ClientKey + WS_MAGIC_GUID` * Base64 encodes the result * Used for server handshake verification **Example**: ```vb ' Server calculates Accept Key (internal use) Dim sClientKey As String sClientKey = GetHeaderValue(sHandshake, "Sec-WebSocket-Key") Dim sAcceptKey As String sAcceptKey = ComputeAcceptKey(sClientKey) Debug.Print "Accept Key: " & sAcceptKey ' Output HTTP response header Dim sResponse As String sResponse = "HTTP/1.1 101 Switching Protocols" & vbCrLf sResponse = sResponse & "Sec-WebSocket-Accept: " & sAcceptKey & vbCrLf sResponse = sResponse & vbCrLf ``` *** ### WS\_MAGIC\_GUID - WebSocket Magic GUID **Constant**: ```vb Public Const WS_MAGIC_GUID As String = "258EAFA5-E914-47DA-95CA-C5AB0DC85B11" ``` **Description**: Fixed GUID used in WebSocket handshake for calculating Accept Key. *** ### WS\_VERSION - WebSocket Protocol Version **Constant**: ```vb Public Const WS_VERSION As String = "13" ``` **Description**: WebSocket protocol version number (RFC 6455). *** ## 📋 HTTP Header Parsing Functions ### GetHeaderValue - Get HTTP Header Value **Syntax**: ```vb Public Function GetHeaderValue(ByVal HttpText As String, ByVal HeaderName As String) As String ``` **Parameters**: | Parameter | Type | Description | |-----------|------|-------------| | `HttpText` | String | HTTP request/response text | | `HeaderName` | String | Header name (case-insensitive) | **Return Value**: Header value, returns empty string if not found **Example**: ```vb ' Get Host header Dim sRequest As String sRequest = "GET /chat HTTP/1.1" & vbCrLf sRequest = sRequest & "Host: example.com:8080" & vbCrLf sRequest = sRequest & "Upgrade: websocket" & vbCrLf sRequest = sRequest & vbCrLf Dim sHost As String sHost = GetHeaderValue(sRequest, "Host") Debug.Print "Host: " & sHost ' Output: example.com:8080 ' Get WebSocket Key Dim sKey As String sKey = GetHeaderValue(sRequest, "Sec-WebSocket-Key") ' Get Connection header Dim sConnection As String sConnection = GetHeaderValue(sRequest, "Connection") ``` *** ## 📝 Close Code Description Functions ### GetCloseCodeDescription - Get Close Code Description **Syntax**: ```vb Public Function GetCloseCodeDescription(ByVal Code As WsCloseCode) As String ``` **Parameters**: | Parameter | Type | Description | |-----------|------|-------------| | `Code` | WsCloseCode | Close status code | **Return Value**: Text description of the close code **Example**: ```vb Dim sDesc As String sDesc = GetCloseCodeDescription(WS_CLOSE_NORMAL) Debug.Print sDesc ' Output: Normal closure sDesc = GetCloseCodeDescription(WS_CLOSE_ABNORMAL) Debug.Print sDesc ' Output: Abnormal closure sDesc = GetCloseCodeDescription(1000) Debug.Print sDesc ' Output: Normal closure sDesc = GetCloseCodeDescription(9999) Debug.Print sDesc ' Output: Unknown (9999) ' Use in OnClose event Private Sub m_Client_OnClose(ByVal Code As WsCloseCode, ByVal Reason As String) Debug.Print "Close code: " & Code Debug.Print "Description: " & GetCloseCodeDescription(Code) If LenB(Reason) > 0 Then Debug.Print "Reason: " & Reason End If End Sub ``` *** ## 🧹 Cleanup Functions ### CleanupCryptoProvider - Cleanup CryptoAPI Resources **Syntax**: ```vb Public Sub CleanupCryptoProvider() ``` **Description**: * Releases CryptoAPI context * Usually called at program end **Example**: ```vb ' Cleanup on program exit Private Sub Form_Unload(Cancel As Integer) CleanupCryptoProvider End Sub ``` *** ## 📝 Complete Usage Examples ### WebSocket Handshake Flow ```vb ' Client sends handshake request Private Sub SendHandshake() Dim sKey As String sKey = GenerateWebSocketKey() Dim sHandshake As String sHandshake = "GET /chat HTTP/1.1" & vbCrLf sHandshake = sHandshake & "Host: example.com:8080" & vbCrLf sHandshake = sHandshake & "Upgrade: websocket" & vbCrLf sHandshake = sHandshake & "Connection: Upgrade" & vbCrLf sHandshake = sHandshake & "Sec-WebSocket-Key: " & sKey & vbCrLf sHandshake = sHandshake & "Sec-WebSocket-Version: " & WS_VERSION & vbCrLf sHandshake = sHandshake & vbCrLf m_Socket.SendData sHandshake, ScpUtf8 End Sub ' Server handles handshake request Private Function HandleHandshake(ByVal sRequest As String) As Boolean ' Get client Key Dim sKey As String sKey = GetHeaderValue(sRequest, "Sec-WebSocket-Key") If LenB(sKey) = 0 Then HandleHandshake = False Exit Function End If ' Calculate Accept Key Dim sAccept As String sAccept = ComputeAcceptKey(sKey) ' Send response Dim sResponse As String sResponse = "HTTP/1.1 101 Switching Protocols" & vbCrLf sResponse = sResponse & "Upgrade: websocket" & vbCrLf sResponse = sResponse & "Connection: Upgrade" & vbCrLf sResponse = sResponse & "Sec-WebSocket-Accept: " & sAccept & vbCrLf sResponse = sResponse & vbCrLf m_Socket.SendData sResponse, ScpUtf8 HandleHandshake = True End Function ' Client verifies handshake response Private Function ValidateResponse(ByVal sResponse As String) As Boolean ' Check status code If InStr(sResponse, "101") = 0 Then ValidateResponse = False Exit Function End If ' Get Accept Key Dim sAccept As String sAccept = GetHeaderValue(sResponse, "Sec-WebSocket-Accept") ' Calculate expected value Dim sExpected As String sExpected = ComputeAcceptKey(m_sClientKey) ' Verify ValidateResponse = (sAccept = sExpected) End Function ``` ### Text Message Processing ```vb ' Send text message Public Sub SendTextMessage(ByVal sText As String) Dim baPayload() As Byte baPayload = StringToUTF8(sText) Dim oFrame As New cWebSocketFrame Dim baFrame() As Byte baFrame = oFrame.BuildFrame(baPayload, WS_OPCODE_TEXT, True, True) m_Socket.SendData baFrame End Sub ' Receive text message Private Sub ProcessTextFrame(ByVal baPayload() As Byte) Dim sText As String sText = UTF8ToString(baPayload) Debug.Print "Received text: " & sText ' Process message... End Sub ``` ### Custom Data Processing ```vb ' Serialize object to UTF-8 JSON Public Function SerializeJSON(ByVal oObject As Object) As Byte() Dim sJSON As String sJSON = ToJSONString(oObject) Dim baData() As Byte baData = StringToUTF8(sJSON) SerializeJSON = baData End Function ' Deserialize UTF-8 JSON to object Public Function DeserializeJSON(ByVal baData() As Byte) As Object Dim sJSON As String sJSON = UTF8ToString(baData) Set DeserializeJSON = FromJSONString(sJSON) End Function ``` *** ## ⚠️ Notes 1. **CryptoAPI initialization** - SHA1Hash automatically initializes CryptoAPI 2. **Resource cleanup** - Call CleanupCryptoProvider at program end 3. **Encoding consistency** - Both send and receive use UTF-8 encoding 4. **Case-insensitive header names** - GetHeaderValue ignores case *** **Last Updated**: 2026-01-10 --- --- url: /en/packages/vbccr/buttons/optionbuttonw.md description: >- OptionButtonW Control - VBCCR Development Manual, complete API reference based on source code --- # OptionButtonW Control Wraps the Windows system Button control, running in radio button style, with support for graphical style, owner-draw, image list, and visual styles. ## Enumerations ### OptImageListAlignmentConstants | Constant | Value | Description | |----------|-------|-------------| | OptImageListAlignmentLeft | 0 | Left alignment | | OptImageListAlignmentRight | 1 | Right alignment | | OptImageListAlignmentTop | 2 | Top alignment | | OptImageListAlignmentBottom | 3 | Bottom alignment | | OptImageListAlignmentCenter | 4 | Center alignment | ### OptDrawModeConstants | Constant | Value | Description | |----------|-------|-------------| | OptDrawModeNormal | 0 | Standard mode, drawn by the system | | OptDrawModeOwnerDraw | 1 | Owner-draw mode, drawing handled by code | ### CCAppearanceConstants See Common Enumerations. ### CCLeftRightAlignmentConstants See Common Enumerations. ### CCVerticalAlignmentConstants See Common Enumerations. ### CCMousePointerConstants See Common Enumerations. ### CCRightToLeftModeConstants See Common Enumerations. ### OLEDropModeConstants See Common Enumerations. ## Properties ### Value ```vb Property Get Value() As OLE_OPTEXCLUSIVE Property Let Value(ByVal NewValue As OLE_OPTEXCLUSIVE) ``` Selected state of the option button. True means selected. ### Caption ```vb Property Get Caption() As String Property Let Caption(ByVal Value As String) ``` Text caption displayed on the control. ### Alignment ```vb Property Get Alignment() As CCLeftRightAlignmentConstants Property Let Alignment(ByVal Value As CCLeftRightAlignmentConstants) ``` Alignment of the option button caption (left or right). See Common Enumerations. ### TextAlignment ```vb Property Get TextAlignment() As VBRUN.AlignmentConstants Property Let TextAlignment(ByVal Value As VBRUN.AlignmentConstants) ``` Alignment of the caption text (left, center, or right). ### PushLike ```vb Property Get PushLike() As Boolean Property Let PushLike(ByVal Value As Boolean) ``` Whether to make the control look and behave like a push button. ### Picture ```vb Property Get Picture() As IPictureDisp Property Let Picture(ByVal Value As IPictureDisp) Property Set Picture(ByVal Value As IPictureDisp) ``` Picture displayed on the control. ### WordWrap ```vb Property Get WordWrap() As Boolean Property Let WordWrap(ByVal Value As Boolean) ``` Whether to allow the caption text to wrap to prevent overflow. ### Transparent ```vb Property Get Transparent() As Boolean Property Let Transparent(ByVal Value As Boolean) ``` Whether to simulate a transparent background using a copy of the underlying background. This property is ignored at design time. ### VerticalAlignment ```vb Property Get VerticalAlignment() As CCVerticalAlignmentConstants Property Let VerticalAlignment(ByVal Value As CCVerticalAlignmentConstants) ``` Vertical alignment. See Common Enumerations. ### Style ```vb Property Get Style() As VBRUN.ButtonConstants Property Let Style(ByVal Value As VBRUN.ButtonConstants) ``` Control appearance style, standard or graphical. When DrawMode is not Normal, Style must be Standard. ### DisabledPicture ```vb Property Get DisabledPicture() As IPictureDisp Property Let DisabledPicture(ByVal Value As IPictureDisp) Property Set DisabledPicture(ByVal Value As IPictureDisp) ``` Picture displayed when the button is disabled. Only applicable when Style is graphical. ### DownPicture ```vb Property Get DownPicture() As IPictureDisp Property Let DownPicture(ByVal Value As IPictureDisp) Property Set DownPicture(ByVal Value As IPictureDisp) ``` Picture displayed when the button is pressed. Only applicable when Style is graphical. ### UseMaskColor ```vb Property Get UseMaskColor() As Boolean Property Let UseMaskColor(ByVal Value As Boolean) ``` Whether to use the MaskColor property as a transparent color. Only applicable when Style is graphical. ### MaskColor ```vb Property Get MaskColor() As OLE_COLOR Property Let MaskColor(ByVal Value As OLE_COLOR) ``` Color used as the transparent (mask) color in pictures. Only applicable when Style is graphical. ### DrawMode ```vb Property Get DrawMode() As OptDrawModeConstants Property Let DrawMode(ByVal Value As OptDrawModeConstants) ``` Draw mode, standard or owner-draw. ### ImageList ```vb Property Get ImageList() As Variant Property Let ImageList(ByVal Value As Variant) Property Set ImageList(ByVal Value As Variant) ``` Associated image list control. The image list should contain a single image (for all states) or separate images for each state. Requires comctl32.dll 6.0 or later. ### ImageListAlignment ```vb Property Get ImageListAlignment() As OptImageListAlignmentConstants Property Let ImageListAlignment(ByVal Value As OptImageListAlignmentConstants) ``` Alignment of images from the image list. Requires comctl32.dll 6.0 or later. ### ImageListMargin ```vb Property Get ImageListMargin() As Single Property Let ImageListMargin(ByVal Value As Single) ``` Margin for images from the image list. Requires comctl32.dll 6.0 or later. ### Pushed ```vb Property Get Pushed() As Boolean Property Let Pushed(ByVal Value As Boolean) ``` Whether the option button is in a pressed state. ### Hot ```vb Property Get Hot() As Boolean Property Let Hot(ByVal Value As Boolean) ``` Whether the option button is in a hot state (mouse hover). Read-only; writing raises error 383. Requires comctl32.dll 6.0 or later. ### VisualStyles ```vb Property Get VisualStyles() As Boolean Property Let VisualStyles(ByVal Value As Boolean) ``` Whether to enable visual styles. Requires comctl32.dll 6.0 or later. ### Appearance ```vb Property Get Appearance() As CCAppearanceConstants Property Let Appearance(ByVal Value As CCAppearanceConstants) ``` Control appearance, flat or 3D effect. See Common Enumerations. ### BackColor ```vb Property Get BackColor() As OLE_COLOR Property Let BackColor(ByVal Value As OLE_COLOR) ``` Background color. ### ForeColor ```vb Property Get ForeColor() As OLE_COLOR Property Let ForeColor(ByVal Value As OLE_COLOR) ``` Foreground color. ### Enabled ```vb Property Get Enabled() As Boolean Property Let Enabled(ByVal Value As Boolean) ``` Whether the control is enabled. ### OLEDropMode ```vb Property Get OLEDropMode() As OLEDropModeConstants Property Let OLEDropMode(ByVal Value As OLEDropModeConstants) ``` OLE drag-drop target mode. See Common Enumerations. ### MousePointer ```vb Property Get MousePointer() As CCMousePointerConstants Property Let MousePointer(ByVal Value As CCMousePointerConstants) ``` Mouse pointer style. See Common Enumerations. ### MouseIcon ```vb Property Get MouseIcon() As IPictureDisp Property Let MouseIcon(ByVal Value As IPictureDisp) Property Set MouseIcon(ByVal Value As IPictureDisp) ``` Custom mouse icon. ### MouseTrack ```vb Property Get MouseTrack() As Boolean Property Let MouseTrack(ByVal Value As Boolean) ``` Whether to enable mouse enter/leave tracking. ### RightToLeft ```vb Property Get RightToLeft() As Boolean Property Let RightToLeft(ByVal Value As Boolean) ``` Right-to-left display direction. ### RightToLeftMode ```vb Property Get RightToLeftMode() As CCRightToLeftModeConstants Property Let RightToLeftMode(ByVal Value As CCRightToLeftModeConstants) ``` Right-to-left mode. See Common Enumerations. ### Font ```vb Property Get Font() As StdFont Property Let Font(ByVal NewFont As StdFont) Property Set Font(ByVal NewFont As StdFont) ``` Font. ### hWnd ```vb Property Get hWnd() As LongPtr ``` Window handle of the option button control. ### hWndUserControl ```vb Property Get hWndUserControl() As LongPtr ``` Window handle of the UserControl. ### Name ```vb Property Get Name() As String ``` Control name. Read-only. ### Tag ```vb Property Get Tag() As String Property Let Tag(ByVal Value As String) ``` Custom data. ### Parent ```vb Property Get Parent() As Object ``` Parent object. Read-only. ### Container ```vb Property Get Container() As Object Property Set Container(ByVal Value As Object) ``` Container object. ### Left ```vb Property Get Left() As Single Property Let Left(ByVal Value As Single) ``` Left position. ### Top ```vb Property Get Top() As Single Property Let Top(ByVal Value As Single) ``` Top position. ### Width ```vb Property Get Width() As Single Property Let Width(ByVal Value As Single) ``` Width. ### Height ```vb Property Get Height() As Single Property Let Height(ByVal Value As Single) ``` Height. ### Visible ```vb Property Get Visible() As Boolean Property Let Visible(ByVal Value As Boolean) ``` Whether the control is visible. ### ToolTipText ```vb Property Get ToolTipText() As String Property Let ToolTipText(ByVal Value As String) ``` Tooltip text. ### HelpContextID ```vb Property Get HelpContextID() As Long Property Let HelpContextID(ByVal Value As Long) ``` Help context ID. ### WhatsThisHelpID ```vb Property Get WhatsThisHelpID() As Long Property Let WhatsThisHelpID(ByVal Value As Long) ``` "What's This" help ID. ### DragIcon ```vb Property Get DragIcon() As IPictureDisp Property Let DragIcon(ByVal Value As IPictureDisp) Property Set DragIcon(ByVal Value As IPictureDisp) ``` Drag icon. ### DragMode ```vb Property Get DragMode() As Integer Property Let DragMode(ByVal Value As Integer) ``` Drag mode. ## Methods ### Drag ```vb Public Sub Drag([ByRef Action As Variant]) ``` Starts, ends, or cancels a drag operation. ### SetFocus ```vb Public Sub SetFocus() ``` Moves focus to the control. ### ZOrder ```vb Public Sub ZOrder([ByRef Position As Variant]) ``` Sets the Z-order of the control. ### OLEDrag ```vb Public Sub OLEDrag() ``` Initiates an OLE drag-drop operation. ### Refresh ```vb Public Sub Refresh() ``` Forces the control to repaint. ## Events ### Click ```vb Public Event Click() ``` Fired when a mouse button is pressed and released on the control. ### DblClick ```vb Public Event DblClick() ``` Fired when the mouse is double-clicked on the control. ### HotChanged ```vb Public Event HotChanged() ``` Fired when the hot state of the option button changes. Requires comctl32.dll 6.0 or later. ### OwnerDraw ```vb Public Event OwnerDraw(ByVal Action As Long, ByVal State As Long, ByVal hDC As Long, ByVal Left As Long, ByVal Top As Long, ByVal Right As Long, ByVal Bottom As Long) ``` Fired when a visual aspect of the owner-draw button needs to be drawn. ### PreviewKeyDown ```vb Public Event PreviewKeyDown(ByVal KeyCode As Integer, ByRef IsInputKey As Boolean) ``` Fired before the KeyDown event. ### PreviewKeyUp ```vb Public Event PreviewKeyUp(ByVal KeyCode As Integer, ByRef IsInputKey As Boolean) ``` Fired before the KeyUp event. ### KeyDown ```vb Public Event KeyDown(KeyCode As Integer, Shift As Integer) ``` Fired when a key is pressed. ### KeyUp ```vb Public Event KeyUp(KeyCode As Integer, Shift As Integer) ``` Fired when a key is released. ### KeyPress ```vb Public Event KeyPress(KeyChar As Integer) ``` Fired when a key character is input. ### MouseDown ```vb Public Event MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` Fired when a mouse button is pressed. ### MouseMove ```vb Public Event MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` Fired when the mouse is moved. ### MouseUp ```vb Public Event MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` Fired when a mouse button is released. ### MouseEnter ```vb Public Event MouseEnter() ``` Fired when the mouse enters the control. ### MouseLeave ```vb Public Event MouseLeave() ``` Fired when the mouse leaves the control. ### OLECompleteDrag ```vb Public Event OLECompleteDrag(Effect As Long) ``` Fired after an OLE drag-drop operation is completed or cancelled. ### OLEDragDrop ```vb Public Event OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single) ``` Fired when data is dropped on the control via an OLE drag-drop operation. ### OLEDragOver ```vb Public Event OLEDragOver(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single, State As Integer) ``` Fired when the mouse moves over the control during an OLE drag-drop operation. ### OLEGiveFeedback ```vb Public Event OLEGiveFeedback(Effect As Long, DefaultCursors As Boolean) ``` Fired when the mouse cursor needs to be changed during an OLE drag-drop operation. ### OLESetData ```vb Public Event OLESetData(Data As DataObject, DataFormat As Integer) ``` Fired when the drop target requests data not provided during OLEDragStart. ### OLEStartDrag ```vb Public Event OLEStartDrag(Data As DataObject, AllowedEffects As Long) ``` Fired when an OLE drag-drop operation starts. ## Code Examples ```vb ' Basic option button OptionButtonW1.Caption = "Option A" OptionButtonW1.Value = True ' Graphical style OptionButtonW1.Style = vbButtonGraphical Set OptionButtonW1.Picture = LoadPicture("C:\icon.bmp") Set OptionButtonW1.DownPicture = LoadPicture("C:\icon_down.bmp") ' Push-like option button OptionButtonW1.PushLike = True ' Using image list Set OptionButtonW1.ImageList = ImageList1 OptionButtonW1.ImageListAlignment = OptImageListAlignmentLeft OptionButtonW1.ImageListMargin = 4 ' Owner draw OptionButtonW1.DrawMode = OptDrawModeOwnerDraw ``` --- --- url: /en/vbman/winsock/packet-protocol.md --- # Packet Protocol and Heartbeat Mechanism > 📦💓 Built-in protocol to solve TCP sticky packet/fragmentation issues, and intelligent heartbeat to keep connections alive ## 📖 Table of Contents * [Overview](#overview) * [TCP Sticky Packet and Fragmentation Issues](#tcp-sticky-packet-and-fragmentation-issues) * [Packet Protocol](#packet-protocol) * [Security Limit Properties](#security-limit-properties) * [Event Model](#event-model) * [Intelligent Heartbeat Mechanism](#intelligent-heartbeat-mechanism) * [UDP Protocol Support](#udp-protocol-support) * [Complete Examples](#complete-examples) * [Best Practices](#best-practices) * [FAQ](#faq) *** ## Overview TCP is a stream protocol without message boundaries — data sent continuously by the sender may be received multiple times by the receiver (fragmentation), or multiple messages may be received at once as concatenated data (sticky packets). cWinsock's built-in packet protocol `cPacketProtocol` and intelligent heartbeat `cHeartbeat` automatically solve these problems: * **Packet Protocol**: Three built-in protocols, automatic packet/unpacket, ensuring each receive is a complete message * **Heartbeat Mechanism**: Embedded timer automatic drive, server timeout detection + client intelligent keepalive *** ## TCP Sticky Packet and Fragmentation Issues ### What are Sticky Packets/Fragmentation? | Phenomenon | Term | Description | |------------|------|-------------| | Data from one Send arrives in multiple Receives | **Fragmentation** | Sent 1000 bytes, first receive 300, then 700 | | Data from multiple Sends arrives in one Receive | **Sticky Packet** | Sent 3 messages continuously, received as concatenated data | | Both mixed | **Most Common** | Received data is both incomplete and mixed with next message's start | ### Visual Diagram ``` Application layer sends: [Msg1][Msg2][Msg3] ↓ TCP stream transmission (no boundaries) Receiver may receive: Case 1 (Fragmentation): [Msg1 part1] [Msg1 part2+Msg2 part1] [Msg2 part2+Msg3] Case 2 (Sticky Packet): [Msg1+Msg2] [Msg3] Case 3 (Mixed): [Msg1 part1] [Msg1 part2+Msg2] [Msg3 part1] [Msg3 part2] Ideal case (Rare): [Msg1] [Msg2] [Msg3] ``` ### cPacketProtocol's Solution Define clear boundaries in data, restoring boundary-less byte streams into bounded messages: ``` Raw TCP byte stream (no boundaries): [Msg1 part1][Msg1 part2+Msg2 part1][Msg2 part2] ↓ cPacketProtocol.Decode() Complete messages: [Msg1 Complete] → Trigger MessageArrival [Msg2 Complete] → Trigger MessageArrival ``` *** ## Packet Protocol ### Three Protocol Types Comparison | Protocol Type | Principle | Fragmentation Handling | Sticky Packet Handling | Pros/Cons | |---------------|-----------|------------------------|------------------------|-----------| | `ppLengthHeader` | Header indicates message body length | Cache if length insufficient, extract when data arrives | Cut one when length sufficient, continue parsing remainder | **Recommended**. Not dependent on data content, no message length limit | | `ppDelimiter` | Delimiter marks message end | Cache if delimiter not found | Cut one when delimiter found, continue searching | Simple, but delimiter cannot appear in message body | | `ppFixedLength` | Fixed message length | Cache if less than fixed length | Cut one when fixed length reached | Only for fixed-length message scenarios | ### Recommended: ppLengthHeader 4-byte little-endian length header protocol is the most universal choice: * Not dependent on special characters appearing in data content (delimiter protocol's weakness) * No single message length limit (fixed-length protocol's weakness) * Each message has its own length, receiver knows exactly how many bytes to read *** ### ppDelimiter - Delimiter Protocol Uses specified character/string as message boundary marker. **Use Case**: Text protocols, line-based command protocols (e.g., chat, HTTP headers) ```vb ' Configuration m_oServer.PacketProtocol = ppDelimiter m_oServer.Delimiter = vbCrLf ' Newline delimiter ' Send automatically appends delimiter Client.SendData "Hello" ' Actually sends: "Hello" + vbCrLf ' Receive automatically removes delimiter Private Sub m_oServer_MessageArrival(Client As cWinsock, ByVal bytesTotal As Long) Debug.Print "Complete message: " & Client.GetDataText() ' "Hello" End Sub ``` **Common Delimiters:** | Delimiter | Constant | Use Case | |-----------|----------|----------| | `\r\n` | `vbCrLf` | Line-based text protocol | | `\n` | `vbLf` | Unix-style line protocol | | `\0` | `vbNullChar` | C string style | | Custom string | `""` | Custom protocol | **Note:** Delimiter cannot appear in message body, otherwise messages will be incorrectly split. *** ### ppFixedLength - Fixed Length Protocol Each message has fixed length, suitable for structured data with known length. **Use Case**: Status packets, sensor data, fixed-format messages ```vb ' Configuration m_oServer.PacketProtocol = ppFixedLength m_oServer.FixedLength = 256 ' Each message fixed 256 bytes ' Send: Less than 256 bytes will be zero-padded, more than 256 bytes will error Client.SendData myData ``` **Note:** Data exceeding length will directly error (won't silently truncate). *** ### ppLengthHeader - Length Header Protocol (Recommended) Add length information in message header, most universal and recommended protocol. **Use Case**: Binary protocols, variable-length messages, any scenario needing reliable transmission ```vb ' Configuration m_oServer.PacketProtocol = ppLengthHeader m_oServer.HeaderBytes = 4 ' 4-byte length header (supports max ~4GB) m_oServer.HeaderEndian = eeLittleEndian ' Little-endian ' Send automatically adds length header Client.SendData "Hello" ' Actually sends: [4-byte length=5] + "Hello" ' Receive automatically strips length header Private Sub m_oServer_MessageArrival(Client As cWinsock, ByVal bytesTotal As Long) Dim baData() As Byte baData = Client.GetDataByteArray() ' 100% is one complete message End Sub ``` **HeaderBytes Options:** | Value | Type | Max Message Length | Description | |-------|------|-------------------|-------------| | 2 | Unsigned Integer | 65,535 bytes (~64KB) | Small message scenarios, saves bandwidth | | 4 | Unsigned Long | 2,147,483,647 bytes (~2GB) | General scenarios, recommended | **HeaderEndian Byte Order:** | Value | Description | Use Case | |-------|-------------|----------| | `eeLittleEndian` | Little-endian (default) | x86/x64 platform internal communication | | `eeBigEndian` | Big-endian (network byte order) | Communication with Java/C server | *** ## Security Limit Properties Prevent malicious packets from exhausting memory, added 2026-06-09: ### MaxPacketSize Single packet maximum size limit, prevents malicious oversized packet declarations from exhausting memory. ```vb Property Get MaxPacketSize() As Long Property Let MaxPacketSize(ByVal Value As Long) ``` * **Default**: 1MB (1048576 bytes) * **Function**: During length header protocol parsing, if declared message length exceeds this value, directly error and discard * **Applicable Protocol**: `ppLengthHeader` ```vb ' Adjust max packet limit m_oServer.MaxPacketSize = 524288 ' 512KB ' New clients automatically inherit this configuration ``` ### MaxBufferSize Buffer accumulation upper limit, prevents large numbers of incomplete packets slowly consuming memory. ```vb Property Get MaxBufferSize() As Long Property Let MaxBufferSize(ByVal Value As Long) ``` * **Default**: 4MB (4194304 bytes) * **Function**: Check before Decode merge buffer, error if exceeded * **Applicable Protocol**: All protocols ```vb ' Adjust buffer upper limit m_oServer.MaxBufferSize = 8388608 ' 8MB ``` ### Overflow Behavior | Overflow Type | Behavior | |---------------|----------| | Single packet exceeds `MaxPacketSize` | Throw explicit error message, discard buffer | | Accumulation exceeds `MaxBufferSize` | Throw explicit error message, discard buffer | | Data too long (FixedLength) | Throw error (won't silently truncate) | *** ## Event Model ### Protocol Mode vs No-Protocol Mode Difference | Mode | Trigger Event | Description | |------|---------------|-------------| | No Protocol (`ppNone`) | `DataArrival` | Raw byte stream, may be incomplete or sticky | | With Protocol | `MessageArrival` | Each time guaranteed to be one complete message | **Key Rule**: In protocol mode **only `MessageArrival` is triggered**, `DataArrival` is not triggered, avoiding duplicate reads of same data by two events. ### MessageArrival Event ```vb Private Sub object_MessageArrival(Client As cWinsock, ByVal bytesTotal As Long) ``` | Parameter | Type | Description | |-----------|------|-------------| | `Client` | cWinsock | Client object receiving message | | `bytesTotal` | Long | Complete message byte count | ### Usage Example ```vb ' Set length header protocol m_oServer.PacketProtocol = ppLengthHeader m_oServer.HeaderBytes = 4 m_oServer.HeaderEndian = eeLittleEndian ' Receive complete message Private Sub m_oServer_MessageArrival(Client As cWinsock, ByVal bytesTotal As Long) ' Buffer now contains complete message, 100% complete Dim sData As String sData = Client.GetDataText() Debug.Print "Complete message: " & sData End Sub ``` ### Difference from DataArrival | Event | Trigger Timing | Data Integrity | Use Case | |-------|----------------|----------------|----------| | `DataArrival` | Each time raw data received | May be fragmented or sticky data | No-protocol mode | | `MessageArrival` | After protocol parses complete message | Guaranteed to be one complete message | Protocol mode | *** ## Intelligent Heartbeat Mechanism cWinsock's built-in `cHeartbeat` heartbeat manager, embedded `cTimer` automatic drive, no external timer needed. ### Server: Timeout Detection Server periodically checks all clients' idle time, automatically disconnects zombie connections after timeout. ```vb ' Configuration m_oServer.AutoHeartbeat = True m_oServer.HeartbeatTimeout = 120 ' 2 minutes no activity then timeout ' Timeout event Private Sub m_oServer_ClientTimeout(Client As cWinsock) Debug.Print "Client " & Client.Tag & " timeout, automatically disconnected" End Sub ``` ### Client: Heartbeat Keepalive Client periodically sends heartbeat packets to keep connection alive. Has intelligent skip mechanism — skips heartbeat when data is being sent/received, saving bandwidth. ```vb ' Configuration m_oClient.AutoHeartbeat = True m_oClient.HeartbeatInterval = 50 ' 50 seconds no activity then send heartbeat ' Heartbeat event Private Sub m_oClient_HeartbeatSent(Client As cWinsock) Debug.Print "Heartbeat sent, idle: " & Client.IdleSeconds & " seconds" End Sub ``` ### Custom Heartbeat Packet ```vb ' Default heartbeat packet is single byte &H00, can be customized Dim baHB(0 To 3) As Byte baHB(0) = &H50 ' P baHB(1) = &H49 ' I baHB(2) = &H4E ' N baHB(3) = &H47 ' G m_oClient.HeartbeatData = baHB ``` ### Heartbeat and Protocol Consistency Heartbeat data is sent through protocol encoding, won't pollute protocol state machine. That is: * Heartbeat packets sent through `SendData`, go through protocol `Encode` * Receiver heartbeat data goes through protocol `Decode` * Heartbeat won't cause sticky packet/fragmentation state confusion ### Working Principle 1. Heartbeat manager embedded `cTimer`, triggers Tick every 10 seconds 2. **Server**: Checks all clients' `IdleSeconds`, triggers `ClientTimeout` and auto-disconnects if timeout 3. **Client**: If idle exceeds `HeartbeatInterval` sends heartbeat packet, intelligently skips when data is sent/received 4. Each send/receive automatically resets `LastActivityTime` ### Heartbeat Related Properties | Property | Type | Read/Write | Description | |----------|------|------------|-------------| | `AutoHeartbeat` | Boolean | RW | Enable/Disable automatic heartbeat | | `HeartbeatTimeout` | Long | RW | Server timeout seconds (default 120) | | `HeartbeatInterval` | Long | RW | Client heartbeat interval seconds (default 50) | | `HeartbeatData` | Byte() | RW | Heartbeat packet content (default single byte 0) | | `IdleSeconds` | Long | RO | Current idle seconds | *** ## UDP Protocol Support UDP clients also support packet protocols. UDP is a datagram protocol (naturally has boundaries), but protocol mode can still be used for: * Custom message format processing * Sharing protocol logic with TCP side * Utilizing security limit properties ```vb ' UDP server set protocol m_oUdp.PacketProtocol = ppLengthHeader m_oUdp.HeaderBytes = 4 m_oUdp.MaxPacketSize = 65536 ' UDP single packet usually doesn't exceed 64KB ' UDP virtual client automatically inherits protocol configuration Private Sub m_oUdp_MessageArrival(Client As cWinsock, ByVal bytesTotal As Long) Dim sData As String sData = Client.GetDataText() Debug.Print "UDP complete message: " & sData End Sub ``` *** ## Complete Examples ### TCP Server + Length Header Protocol + Heartbeat ```vb Private WithEvents m_oServer As cWinsock Private Sub Form_Load() Set m_oServer = New cWinsock ' Set packet protocol (Recommended: length header protocol) m_oServer.PacketProtocol = ppLengthHeader m_oServer.HeaderBytes = 4 m_oServer.HeaderEndian = eeLittleEndian m_oServer.MaxPacketSize = 1048576 ' 1MB m_oServer.MaxBufferSize = 4194304 ' 4MB ' Set heartbeat m_oServer.AutoHeartbeat = True m_oServer.HeartbeatTimeout = 120 ' 2 minutes timeout ' Start server m_oServer.Listen 8080 Debug.Print "Server started" End Sub Private Sub m_oServer_ConnectionRequest(Client As cWinsock, ByRef DisConnect As Boolean) Debug.Print "New client: " & Client.RemoteHostIP & ":" & Client.RemotePort ' New clients automatically inherit protocol and heartbeat configuration End Sub Private Sub m_oServer_MessageArrival(Client As cWinsock, ByVal bytesTotal As Long) ' 100% is complete message Dim sData As String sData = Client.GetDataText() Debug.Print "[" & Client.Tag & "] " & sData ' Echo Client.SendData "Echo: " & sData End Sub Private Sub m_oServer_ClientTimeout(Client As cWinsock) Debug.Print "Client timeout: " & Client.Tag End Sub Private Sub m_oServer_CloseEvent(Client As cWinsock) Debug.Print "Client disconnected: " & Client.Tag End Sub Private Sub Form_Unload(Cancel As Integer) On Error Resume Next m_oServer.Close_ End Sub ``` ### TCP Client + Length Header Protocol + Heartbeat ```vb Private WithEvents m_oClient As cWinsock Private Sub Form_Load() Set m_oClient = New cWinsock ' Set packet protocol (Must be consistent with server) m_oClient.PacketProtocol = ppLengthHeader m_oClient.HeaderBytes = 4 m_oClient.HeaderEndian = eeLittleEndian ' Set heartbeat m_oClient.AutoHeartbeat = True m_oClient.HeartbeatInterval = 50 ' 50 seconds interval ' Connect m_oClient.Connect "127.0.0.1", 8080 End Sub Private Sub m_oClient_Connect(Client As cWinsock) Debug.Print "Connected" Client.SendData "Hello, Server!" End Sub Private Sub m_oClient_MessageArrival(Client As cWinsock, ByVal bytesTotal As Long) Dim sData As String sData = Client.GetDataText() Debug.Print "Received: " & sData End Sub Private Sub m_oClient_HeartbeatSent(Client As cWinsock) Debug.Print "Heartbeat sent" End Sub Private Sub Form_Unload(Cancel As Integer) On Error Resume Next m_oClient.Close_ End Sub ``` ### Chat Server + Delimiter Protocol ```vb Private WithEvents m_oServer As cWinsock Private Sub Form_Load() Set m_oServer = New cWinsock ' Use newline as message delimiter m_oServer.PacketProtocol = ppDelimiter m_oServer.Delimiter = vbCrLf ' Heartbeat keepalive m_oServer.AutoHeartbeat = True m_oServer.HeartbeatTimeout = 180 m_oServer.Listen 9090 End Sub Private Sub m_oServer_MessageArrival(Client As cWinsock, ByVal bytesTotal As Long) Dim sMsg As String sMsg = Client.GetDataText() ' Broadcast to all clients Dim oClient As cWinsock For Each oClient In m_oServer.Clients If Not oClient Is Client Then oClient.SendData "[" & Client.Tag & "] " & sMsg End If Next End Sub ``` *** ## Best Practices ### 1. Choose Appropriate Protocol Type | Protocol Type | Use Case | Pros/Cons | |---------------|----------|-----------| | `ppLengthHeader` | Binary protocol, variable-length messages | Most universal, recommended | | `ppDelimiter` | Text protocol (chat, command-line style) | Simple and intuitive, but data cannot contain delimiter | | `ppFixedLength` | Fixed-format messages (status packets, sensor data) | Fastest parsing, but not flexible | ### 2. Use MessageArrival in Protocol Mode ```vb ' ✅ Correct: Use MessageArrival in protocol mode Private Sub m_oServer_MessageArrival(Client As cWinsock, ByVal bytesTotal As Long) Dim sData As String sData = Client.GetDataText() ' Guaranteed to be complete message End Sub ' ❌ Wrong: Use DataArrival in protocol mode ' DataArrival won't trigger in protocol mode ``` ### 3. Length Header Protocol Byte Order ```vb ' Use big-endian when communicating with C/Java server m_oServer.HeaderEndian = eeBigEndian ' Can use little-endian for pure VB6 internal communication (default) m_oServer.HeaderEndian = eeLittleEndian ``` ### 4. Configure Security Limits ```vb ' Adjust security limits based on business requirements m_oServer.MaxPacketSize = 524288 ' 512KB, max single packet m_oServer.MaxBufferSize = 8388608 ' 8MB, max buffer ``` ### 5. Configure Server Protocol Before Listen ```vb ' ✅ Correct: Set protocol before Listen m_oServer.PacketProtocol = ppLengthHeader m_oServer.HeaderBytes = 4 m_oServer.Listen 8080 ' New clients automatically inherit server configuration, create independent protocol instances ``` ### 6. Heartbeat Cooperates with Protocol Heartbeat packets go through protocol encoding, won't pollute protocol state machine, no need to manually filter heartbeats. *** ## FAQ ### ❓ Why use packet protocol? TCP is a stream protocol without message boundaries. Without using protocol, `DataArrival` may receive incomplete or sticky data, requiring manual stitching/splitting, prone to errors. After using packet protocol, `MessageArrival` triggers with one complete message each time, developer doesn't need to care about underlying byte stream merging/splitting. ### ❓ What's the difference between MaxPacketSize and MaxBufferSize? * `MaxPacketSize`: Maximum length of single message, for declared message body length in length header protocol * `MaxBufferSize`: Receive buffer accumulation upper limit, prevents large numbers of incomplete packets slowly consuming memory ### ❓ Will DataArrival still trigger in protocol mode? No. In protocol mode **only `MessageArrival` is triggered**, avoiding same data being read twice by two events. No-protocol mode still triggers `DataArrival`. ### ❓ Will heartbeat packets affect protocol parsing? No. Heartbeat data is sent and received through protocol encoding, won't pollute protocol state machine. ### ❓ Does UDP need packet protocol? UDP naturally has message boundaries, doesn't need packet protocol to solve sticky packet issues. But UDP clients also support protocol mode, can be used for unified message format, utilizing security limit properties, etc. ### ❓ How large a message can 2-byte length header transmit? 2-byte header can represent 0~65535 (max about 64KB). Exceeding 65535 bytes will error. Recommend using 4-byte header for large data. *** ## Related Documentation | Document | Description | |----------|-------------| | [Properties Reference](./properties.md) | Detailed description of protocol and heartbeat related properties | | [Events Reference](./events.md) | MessageArrival, ClientTimeout and other events | | [Methods Reference](./methods.md) | GetDataText, GetDataByteArray and other methods | | [TCP Programming](./tcp.md) | TCP client and server programming guide | | [Best Practices](./best-practices.md) | Solutions for common scenarios and performance optimization recommendations | *** **Last Updated**: 2026-06-09 --- --- url: /en/packages/vbccr/bars/pager.md description: >- Pager Control - VBCCR Developer Reference, complete API documentation based on source code --- # Pager Control Wraps the SysPager system pager control, used to create scrollable control areas by scrolling an associated buddy control via left/right or up/down buttons. ## Enumerations ### PgrOrientationConstants | Constant | Value | Description | |----------|-------|-------------| | PgrOrientationHorizontal | 0 | Horizontal orientation | | PgrOrientationVertical | 1 | Vertical orientation | ### PgrDirectionConstants | Constant | Value | Description | |----------|-------|-------------| | PgrDirectionLeft | 0 | Scroll left | | PgrDirectionRight | 1 | Scroll right | | PgrDirectionUp | 2 | Scroll up | | PgrDirectionDown | 3 | Scroll down | ### PgrButtonConstants | Constant | Value | Description | |----------|-------|-------------| | PgrButtonLeftTop | 0 | Left/top button | | PgrButtonRightBottom | 1 | Right/bottom button | ### PgrButtonStateConstants | Constant | Value | Description | |----------|-------|-------------| | PgrButtonStateNormal | 0 | Normal | | PgrButtonStateInvisible | 1 | Hidden | | PgrButtonStateGrayed | 2 | Grayed (disabled) | | PgrButtonStateInactive | 4 | Inactive | | PgrButtonStateHot | 8 | Hot | ### CCMousePointerConstants See common enumerations. ## Properties ### BuddyControl ```vb Property Get BuddyControl() As Variant Property Let BuddyControl(ByVal Value As Variant) ``` Associated buddy control. Can accept a control object, a control name, or an hWnd. ### Orientation ```vb Property Get Orientation() As PgrOrientationConstants Property Let Orientation(ByVal Value As PgrOrientationConstants) ``` Pager control orientation. ### BorderWidth ```vb Property Get BorderWidth() As Long Property Let BorderWidth(ByVal Value As Long) ``` Border width (pixels). ### AutoScroll ```vb Property Get AutoScroll() As Boolean Property Let AutoScroll(ByVal Value As Boolean) ``` Whether automatic scrolling is enabled. ### ButtonSize ```vb Property Get ButtonSize() As Long Property Let ButtonSize(ByVal Value As Long) ``` Button size (pixels). ### OLEDragDropScroll ```vb Property Get OLEDragDropScroll() As Boolean Property Let OLEDragDropScroll(ByVal Value As Boolean) ``` Whether automatic scrolling is enabled during OLE drag-and-drop. ### Value ```vb Property Get Value() As Single Property Let Value(ByVal Value As Single) ``` Current scroll position. ### VisualStyles ```vb Property Get VisualStyles() As Boolean Property Let VisualStyles(ByVal Value As Boolean) ``` Whether visual styles are enabled. ### hWnd ```vb Property Get hWnd() As LongPtr ``` Window handle of the pager control. ### hWndUserControl ```vb Property Get hWndUserControl() As LongPtr ``` Window handle of the user control. ### Font ```vb Property Get Font() As StdFont Property Let Font(ByVal NewFont As StdFont) Property Set Font(ByVal NewFont As StdFont) ``` Font. ### Enabled ```vb Property Get Enabled() As Boolean Property Let Enabled(ByVal Value As Boolean) ``` Whether the control is enabled. ### MousePointer ```vb Property Get MousePointer() As CCMousePointerConstants Property Let MousePointer(ByVal Value As CCMousePointerConstants) ``` Mouse pointer style. See common enumerations. ### MouseIcon ```vb Property Get MouseIcon() As IPictureDisp Property Let MouseIcon(ByVal Value As IPictureDisp) Property Set MouseIcon(ByVal Value As IPictureDisp) ``` Custom mouse icon. ### MouseTrack ```vb Property Get MouseTrack() As Boolean Property Let MouseTrack(ByVal Value As Boolean) ``` Whether mouse enter/leave tracking is enabled. ### RightToLeft ```vb Property Get RightToLeft() As Boolean Property Let RightToLeft(ByVal Value As Boolean) ``` Right-to-left display direction. ### RightToLeftMode ```vb Property Get RightToLeftMode() As CCRightToLeftModeConstants Property Let RightToLeftMode(ByVal Value As CCRightToLeftModeConstants) ``` Right-to-left mode. See common enumerations. ### Name ```vb Property Get Name() As String ``` Control name. Read-only. ### Tag ```vb Property Get Tag() As String Property Let Tag(ByVal Value As String) ``` Custom data. ### Parent ```vb Property Get Parent() As Object ``` Parent object. Read-only. ### Container ```vb Property Get Container() As Object Property Set Container(ByVal Value As Object) ``` Container object. ### Left ```vb Property Get Left() As Single Property Let Left(ByVal Value As Single) ``` Left edge distance. ### Top ```vb Property Get Top() As Single Property Let Top(ByVal Value As Single) ``` Top edge distance. ### Width ```vb Property Get Width() As Single Property Let Width(ByVal Value As Single) ``` Width. ### Height ```vb Property Get Height() As Single Property Let Height(ByVal Value As Single) ``` Height. ### Visible ```vb Property Get Visible() As Boolean Property Let Visible(ByVal Value As Boolean) ``` Whether visible. ### ToolTipText ```vb Property Get ToolTipText() As String Property Let ToolTipText(ByVal Value As String) ``` ToolTip text. ### HelpContextID ```vb Property Get HelpContextID() As Long Property Let HelpContextID(ByVal Value As Long) ``` Help context ID. ### WhatsThisHelpID ```vb Property Get WhatsThisHelpID() As Long Property Let WhatsThisHelpID(ByVal Value As Long) ``` "What's This" help ID. ### DragIcon ```vb Property Get DragIcon() As IPictureDisp Property Let DragIcon(ByVal Value As IPictureDisp) Property Set DragIcon(ByVal Value As IPictureDisp) ``` Drag icon. ### DragMode ```vb Property Get DragMode() As Integer Property Let DragMode(ByVal Value As Integer) ``` Drag mode. ## Methods ### ReCalcSize ```vb Public Sub ReCalcSize() ``` Recalculates the size of the pager control and the buddy control. ### GetButtonState ```vb Public Function GetButtonState(ByVal Button As PgrButtonConstants) As PgrButtonStateConstants ``` Returns the state of the specified button. ### Drag ```vb Public Sub Drag([ByRef Action As Variant]) ``` Starts, ends, or cancels a drag-and-drop operation. ### SetFocus ```vb Public Sub SetFocus() ``` Sets focus to the control. ### ZOrder ```vb Public Sub ZOrder([ByRef Position As Variant]) ``` Sets the control's Z-order. ### OLEDrag ```vb Public Sub OLEDrag() ``` Initiates an OLE drag-and-drop operation. ### Refresh ```vb Public Sub Refresh() ``` Forces a redraw of the control. ## Events ### Scroll ```vb Public Event Scroll() ``` Raised when the scroll position changes. ### CalcSize ```vb Public Event CalcSize() ``` Raised before the buddy control size needs to be recalculated. ### HotChanged ```vb Public Event HotChanged() ``` Raised when a button's hot state changes. ### Click ```vb Public Event Click() ``` Raised when the control is clicked. ### DblClick ```vb Public Event DblClick() ``` Raised when the control is double-clicked. ### MouseDown ```vb Public Event MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` Raised when a mouse button is pressed. ### MouseUp ```vb Public Event MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` Raised when a mouse button is released. ### MouseMove ```vb Public Event MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` Raised when the mouse is moved. ### MouseEnter ```vb Public Event MouseEnter() ``` Raised when the mouse enters the control. ### MouseLeave ```vb Public Event MouseLeave() ``` Raised when the mouse leaves the control. ### OLEDragDrop ```vb Public Event OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single) ``` Raised when an OLE drag-and-drop operation completes. ### OLEDragOver ```vb Public Event OLEDragOver(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single, State As Integer) ``` Raised when an OLE drag-and-drop operation passes over the control. ### OLEGiveFeedback ```vb Public Event OLEGiveFeedback(Effect As Long, DefaultCursors As Boolean) ``` Raised when an OLE drag-and-drop operation needs to change the cursor. ### OLEStartDrag ```vb Public Event OLEStartDrag(Data As DataObject, AllowedEffects As Long) ``` Raised when an OLE drag-and-drop operation starts. ### OLECompleteDrag ```vb Public Event OLECompleteDrag(Effect As Long) ``` Raised when an OLE drag-and-drop operation completes. ### OLESetData ```vb Public Event OLESetData(Data As DataObject, DataFormat As Integer) ``` Raised when an OLE drop target requests data. ## Code Examples ```vb ' Set up a horizontal pager control with a picture box as the buddy Pager1.Orientation = PgrOrientationHorizontal Set Pager1.BuddyControl = Picture1 Pager1.ButtonSize = 16 Call Pager1.ReCalcSize ``` --- --- url: /en/vbman/database/pagination.md --- # Pagination This document details the pagination feature of the cDataBase class, supporting SQL Server, MySQL, Access and other databases. *** ## Table of Contents * [Pagination Overview](#pagination-overview) * [Page Method](#page-method) * [Supported Databases](#supported-databases) * [Usage Examples](#usage-examples) * [Performance Optimization](#performance-optimization) * [Common Questions](#common-questions) *** ## Pagination Overview ### What is Pagination Pagination is the technique of dividing large amounts of data into multiple pages for display, with each page showing a fixed number of records. ### Advantages of Pagination * **Performance Optimization** - Only query needed data, reduce memory usage * **User Experience** - Fast loading, avoid long waits * **Resource Saving** - Reduce network transmission and database load ### Pagination Principle ``` Total records: 1000 Items per page: 10 Total pages: 100 Page 1: Records 1-10 (OFFSET 0, LIMIT 10) Page 2: Records 11-20 (OFFSET 10, LIMIT 10) Page 3: Records 21-30 (OFFSET 20, LIMIT 10) ... ``` *** ## Page Method ### Syntax ```vb Function Page(Optional num As Long = 1, Optional Limit As Long = 10) As cDataBase ``` ### Parameters | Parameter | Type | Description | | --------- | ---- | ----------- | | `num` | `Long` | Page number (optional, default 1) | | `Limit` | `Long` | Records per page (optional, default 10) | ### Return Value Returns `cDataBase` object, supports chained calls. ### Example ```vb ' Query page 1, 10 items per page db.Sql("SELECT * FROM users").Page(1, 10).Query ' Query page 2, 20 items per page db.Sql("SELECT * FROM users").Page(2, 20).Query ``` *** ## Supported Databases ### SQL Server (2012+) Uses `OFFSET ... ROWS FETCH NEXT ... ROWS ONLY` syntax. ```vb ' Original SQL db.Sql("SELECT * FROM users").Page(2, 10).Query ' Automatically converted to SELECT * FROM users ORDER BY (SELECT NULL) OFFSET 10 ROWS FETCH NEXT 10 ROWS ONLY ``` **Note**: SQL Server 2012 and above only supports `OFFSET FETCH`. ### MySQL Uses `LIMIT ... OFFSET ...` syntax. ```vb ' Original SQL db.Sql("SELECT * FROM users").Page(2, 10).Query ' Automatically converted to SELECT * FROM users LIMIT 10 OFFSET 10 ``` ### Access Uses `TOP` and subquery (simplified implementation). ```vb ' Original SQL db.Sql("SELECT * FROM users").Page(2, 10).Query ' Automatically converted to SELECT TOP 20 * FROM ( SELECT * FROM users ) AS T ``` **Note**: Access pagination is a simplified version and may not be perfectly accurate. *** ## Usage Examples ### Example 1: Basic Pagination ```vb ' Query page 1, 10 items per page If db.Sql("SELECT * FROM users").Page(1, 10).Fetch Then Dim i As Long For i = 1 To db.Rows.Count Debug.Print db.Rows(i)("name") Next End If ``` ### Example 2: Paginated with Sorting ```vb ' Descending order by age, paginated display If db.Sql("SELECT * FROM users ORDER BY age DESC").Page(2, 10).Fetch Then Dim i As Long For i = 1 To db.Rows.Count Debug.Print db.Rows(i)("name") & " - " & db.Rows(i)("age") Next End If ``` ### Example 3: Conditional Query Pagination ```vb ' Query users older than 18, paginated display If db.Sql("SELECT * FROM users WHERE age > 18").Page(1, 20).Fetch Then Dim i As Long For i = 1 To db.Rows.Count Debug.Print db.Rows(i)("name") Next End If ``` ### Example 4: Get Total Record Count ```vb ' Query total count Dim lTotal As Long lTotal = db.Count("users") ' Calculate total pages Dim lPageSize As Long lPageSize = 10 Dim lTotalPages As Long lTotalPages = Int((lTotal + lPageSize - 1) / lPageSize) ' Paginated query If db.Sql("SELECT * FROM users").Page(1, lPageSize).Fetch Then ' Display data End If ``` ### Example 5: Complete Pagination Function ```vb ' Pagination query function Function GetUsersPage(lPage As Long, lPageSize As Long) As Collection Set GetUsersPage = New Collection ' Query data If db.Sql("SELECT * FROM users ORDER BY id").Page(lPage, lPageSize).Fetch Then Set GetUsersPage = db.Rows End If End Function ' Usage Dim colUsers As Collection Set colUsers = GetUsersPage(1, 10) ``` ### Example 6: Pagination Navigation ```vb ' Pagination navigation class Private m_lCurrentPage As Long Private m_lPageSize As Long Private m_lTotalRecords As Long Private Sub LoadPage(lPage As Long) ' Validate page number If lPage < 1 Then lPage = 1 Dim lTotalPages As Long lTotalPages = Int((m_lTotalRecords + m_lPageSize - 1) / m_lPageSize) If lPage > lTotalPages Then lPage = lTotalPages m_lCurrentPage = lPage ' Query data If db.Sql("SELECT * FROM users ORDER BY id").Page(lPage, m_lPageSize).Fetch Then ' Display data DisplayUsers End If End Sub Private Sub cmdNextPage_Click() LoadPage m_lCurrentPage + 1 End Sub Private Sub cmdPrevPage_Click() LoadPage m_lCurrentPage - 1 End Sub ``` *** ## Performance Optimization ### 1. Use Indexed Fields for Sorting ```vb ' Recommended: Use indexed fields for sorting db.Sql("SELECT * FROM users ORDER BY id").Page(1, 10).Query ' Not recommended: Use non-indexed fields for sorting db.Sql("SELECT * FROM users ORDER BY name").Page(1, 10).Query ``` ### 2. Only Query Needed Fields ```vb ' Recommended: Only query needed fields db.Sql("SELECT id, name FROM users").Page(1, 10).Query ' Not recommended: Query all fields db.Sql("SELECT * FROM users").Page(1, 10).Query ``` ### 3. Use WHERE Conditions to Limit ```vb ' Recommended: Use WHERE conditions db.Sql("SELECT * FROM users WHERE status = 'active'").Page(1, 10).Query ' Not recommended: Query all data then paginate db.Sql("SELECT * FROM users").Page(1, 10).Query ``` ### 4. Set Reasonable Records Per Page ```vb ' Recommended: Reasonable records per page (10-50) db.Sql("SELECT * FROM users").Page(1, 20).Query ' Not recommended: Too many records per page db.Sql("SELECT * FROM users").Page(1, 1000).Query ``` *** ## Common Questions ### Q1: SQL Server Pagination Error **Error**: `Syntax error near 'OFFSET'` **Cause**: SQL Server version lower than 2012, does not support `OFFSET FETCH`. **Solution**: * Upgrade to SQL Server 2012 or higher * Or use `ROW_NUMBER()` for pagination (requires modifying library code) ### Q2: Access Pagination Inaccurate **Cause**: Access pagination is a simplified version using `TOP` query. **Solution**: * For Access, recommend using `ROW_NUMBER()` or manual pagination * Or upgrade to SQL Server/MySQL ### Q3: How to Get Total Record Count? ```vb ' Method 1: Use Count method Dim lTotal As Long lTotal = db.Count("users") ' Method 2: Use COUNT(*) query If db.Sql("SELECT COUNT(*) AS cnt FROM users").Fetch Then lTotal = db.Row("cnt") End If ``` ### Q4: How to Maintain Sorting After Pagination? ```vb ' Correct: Include ORDER BY in SQL db.Sql("SELECT * FROM users ORDER BY age DESC").Page(1, 10).Query ' Wrong: Sort after pagination (loses sorting) db.Sql("SELECT * FROM users").Page(1, 10).Query ' Then sort results (only sorts current page, not globally) ``` ### Q5: How to Navigate to Specific Page? ```vb Function GoToPage(lPage As Long, lPageSize As Long) As Boolean ' Validate page number If lPage < 1 Then lPage = 1 ' Query specified page If db.Sql("SELECT * FROM users ORDER BY id").Page(lPage, lPageSize).Fetch Then GoToPage = True Else GoToPage = False End If End Function ``` *** ## Best Practices ### 1. Always Use ORDER BY ```vb ' Recommended: Use ORDER BY to ensure order db.Sql("SELECT * FROM users ORDER BY id").Page(1, 10).Query ' Not recommended: Without ORDER BY (order is uncertain) db.Sql("SELECT * FROM users").Page(1, 10).Query ``` ### 2. Validate Page Number and Records Per Page ```vb ' Recommended: Validate parameters Function GetPage(lPage As Long, lPageSize As Long) As Collection If lPage < 1 Then lPage = 1 If lPageSize < 1 Then lPageSize = 10 If lPageSize > 100 Then lPageSize = 100 ' Limit max records per page If db.Sql("SELECT * FROM users ORDER BY id").Page(lPage, lPageSize).Fetch Then Set GetPage = db.Rows End If End Function ``` ### 3. Cache Total Record Count ```vb ' Recommended: Cache total record count to avoid frequent queries Private m_lCachedTotal As Long Private m_dtCacheTime As Date Function GetTotalRecords() As Long ' Cache for 5 minutes If DateDiff("s", m_dtCacheTime, Now) > 300 Or m_lCachedTotal = 0 Then m_lCachedTotal = db.Count("users") m_dtCacheTime = Now End If GetTotalRecords = m_lCachedTotal End Function ``` *** **Last Updated**: 2026-01-21 --- --- url: /en/vbman/httpserver/route-params.md --- # Parameter Routing & Path Segment Parsing ## Introduction Starting from v1.0.0.420, HttpServer introduces two important features: * **Parameter Routing** — Use `{param}` syntax in URL paths to define dynamic parameter segments, similar to modern frameworks like Laravel, Express, etc. * **PathInfoList** — Split URL paths by `/` into a collection object that supports access by index and by key Used together, they make it easy to build RESTful-style APIs. *** ## 1. Parameter Routing ### 1.1 Basic Usage When registering routes, use `{paramName}` to mark dynamic segments: ```vb ' Single parameter route Call Server.Router.Add("/api/user/{id}", "UserController@Show", OnlyGet) ' Multi-parameter route Call Server.Router.Add("/api/user/{userId}/post/{postId}", "PostController@Show", OnlyGet) ' Nested resource route Call Server.Router.Add("/api/group/{groupId}/user/{userId}", "GroupCtrl@Detail", OnlyGet) ``` ### 1.2 Getting Parameters in Controllers Access matched parameter values via the `ctx.Request.RouteParams` dictionary: ```vb ' Single parameter example: GET /api/user/123 Public Sub Show(ctx As cHttpServerContext) Dim userId As String userId = ctx.Request.RouteParams("id") ' Value is "123" ctx.Response.Json Array("userId" & userId) End Sub ' Multi-parameter example: GET /api/user/456/post/789 Public Sub ShowPost(ctx As cHttpServerContext) Dim userId As String, postId As String userId = ctx.Request.RouteParams("userId") ' Value is "456" postId = ctx.Request.RouteParams("postId") ' Value is "789" ctx.Response.Json Array(userId, postId) End Sub ``` ### 1.3 RouteParams Property ```vb Public RouteParams As New Dictionary ``` | Operation | Usage | Description | | ------------------ | -------------------------------------- | --------------------------------- | | Get parameter | `ctx.Request.RouteParams("id")` | Returns parameter value string | | Check existence | `ctx.Request.RouteParams.Exists("id")` | Returns Boolean | | Parameter count | `ctx.Request.RouteParams.Count` | 0 when no parameter route matched | | Iterate parameters | `For Each k In RouteParams.Keys` | Iterate all parameter names | > Note: If no parameter route is matched, `RouteParams` is an empty dictionary (Count = 0). ### 1.4 Matching Rules | Rule | Description | Example | | -------------------------- | --------------------------------------------------- | ----------------------------------------------------------------------------- | | Parameter segment `{name}` | Matches any non-empty string | `/api/user/{id}` matches `/api/user/123` | | Fixed segment | Must match exactly (case-insensitive) | In `/api/user/{id}`, `api` and `user` are fixed segments | | Same segment count | Path segment count must match pattern segment count | `/api/user/{id}` is 3 segments, won't match `/api/user/123/edit` (4 segments) | | Parameter non-empty | Parameter segment cannot match empty value | `/api/user/` does not match `/api/user/{id}` | **Matching Examples**: | Route Pattern | Request Path | Match Result | RouteParams | | ---------------------------------- | ------------------------ | ------------------------- | ------------------------------------ | | `/api/user/{id}` | `/api/user/123` | ✅ | `{"id": "123"}` | | `/api/user/{id}` | `/api/user/abc` | ✅ | `{"id": "abc"}` | | `/api/user/{id}` | `/api/user/` | ❌ Segment count mismatch | — | | `/api/user/{id}` | `/api/users/123` | ❌ Fixed segment mismatch | — | | `/api/user/{userId}/post/{postId}` | `/api/user/456/post/789` | ✅ | `{"userId": "456", "postId": "789"}` | ### 1.5 Matching Priority Route matching executes in the following priority order: 1. **Exact match** — O(1) dictionary lookup, highest performance. e.g., `/api/users` matches directly 2. **ANY exact match** — Look up in the ANY method dictionary 3. **Parameter route match** — Traverse route items containing `{param}`, match segment by segment > Exact routes always take priority over parameter routes; parameter wildcard won't cause false matches. ```vb ' Register both exact and parameter routes Call Server.Router.Add("/api/user/me", "User@Me", OnlyGet) ' Exact match first Call Server.Router.Add("/api/user/{id}", "User@Show", OnlyGet) ' Parameter route second ' GET /api/user/me → Matches exact route, calls User@Me ' GET /api/user/123 → Matches parameter route, RouteParams("id") = "123" ``` ### 1.6 Parameter Routing vs Query Parameters | Comparison | Parameter Routing | Query Parameters | | ------------------- | ------------------------------------------- | ------------------------------- | | URL format | `/api/user/123` | `/api/user?id=123` | | Access method | `ctx.Request.RouteParams("id")` | `ctx.Request.QueryString("id")` | | RESTful style | ✅ Conforms | ❌ Does not conform | | SEO friendly | ✅ More friendly | Average | | Optional parameters | Segment count must match | Naturally optional | | Use case | Resource identification, hierarchical paths | Filtering, pagination, sorting | Both can be combined: ```vb ' GET /api/user/123/posts?page=2&limit=10 Call Server.Router.Add("/api/user/{id}/posts", "Post@List", OnlyGet) Public Sub List(ctx As cHttpServerContext) Dim userId As String: userId = ctx.Request.RouteParams("id") Dim page As String: page = ctx.Request.QueryString("page") Dim limit As String: limit = ctx.Request.QueryString("limit") End Sub ``` ### 1.7 Complete RESTful API Example ```vb ' Register controller Call Server.Router.Reg("Product", New cProductController) ' List: GET /products Call Server.Router.Add("/products", "Product@List", OnlyGet) ' Detail: GET /products/123 Call Server.Router.Add("/products/{id}", "Product@Detail", OnlyGet) ' Create: POST /products Call Server.Router.Add("/products", "Product@Create", OnlyPost) ' Update: PUT /products/123 Call Server.Router.Add("/products/{id}", "Product@Update", OnlyPut) ' Delete: DELETE /products/123 Call Server.Router.Add("/products/{id}", "Product@Delete", OnlyDelete) ' Sub-resource: GET /products/123/reviews Call Server.Router.Add("/products/{id}/reviews", "Product@Reviews", OnlyGet) ' Sub-resource detail: GET /products/123/reviews/456 Call Server.Router.Add("/products/{productId}/reviews/{reviewId}", "Product@ReviewDetail", OnlyGet) ``` ### 1.8 Internal Implementation Parameter routing is implemented by the `cHttpServerRouteItem` class, with the core mechanism: 1. **On registration**: The `Init` method splits the route pattern into a path segment array and extracts `{param}` parameter names 2. **On matching**: The `Match` method compares segment by segment — fixed segments match exactly (case-insensitive), parameter segments match any non-empty value 3. **Parameter extraction**: After a successful match, parameter names and values are written to the `Request.RouteParams` dictionary ``` Route pattern: /api/user/{id}/post/{postId} ↓ Init() split Segment array: ["api", "user", "{id}", "post", "{postId}"] Parameter names: ["id", "postId"] Request path: /api/user/123/post/456 ↓ Match() segment-by-segment matching "api" = "api" ✅ Fixed segment match "user" = "user" ✅ Fixed segment match "{id}" = "123" ✅ Parameter segment → RouteParams("id") = "123" "post" = "post" ✅ Fixed segment match "{postId}" = "456" ✅ Parameter segment → RouteParams("postId") = "456" ``` *** ## 2. PathInfoList Path Segment Collection ### 2.1 Introduction `PathInfoList` is a `cCollection` type collection object that automatically splits the URL path by `/` during request parsing. Each segment is stored in the collection where **both key and value are the segment name**, supporting access by index and by key. ```vb Public PathInfoList As New cCollection ``` ### 2.2 Usage Examples ```vb ' Request: GET /api/user/list?page=1 ' ── Access by index (1-based) ── MsgBox ctx.Request.PathInfoList(1) ' → "api" MsgBox ctx.Request.PathInfoList(2) ' → "user" MsgBox ctx.Request.PathInfoList(3) ' → "list" ' ── Get path segment count ── MsgBox ctx.Request.PathInfoList.Count ' → 3 ' ── Access by key (key=value=segment name) ── MsgBox ctx.Request.PathInfoList("api") ' → "api" ' ── Check if path contains a segment ── If ctx.Request.PathInfoList.Exists("api") Then Debug.Print "Path contains 'api' segment" End If ' ── Iterate all path segments ── Dim i As Long For i = 1 To ctx.Request.PathInfoList.Count Debug.Print "Segment" & i & ": " & ctx.Request.PathInfoList(i) Next i ``` ### 2.3 PathInfoList for Common Paths | Request Path | PathInfoList.Count | PathInfoList(1) | PathInfoList(2) | PathInfoList(3) | | ---------------- | ------------------ | --------------- | --------------- | --------------- | | `/` | 0 | — | — | — | | `/api` | 1 | `"api"` | — | — | | `/api/user` | 2 | `"api"` | `"user"` | — | | `/api/user/list` | 3 | `"api"` | `"user"` | `"list"` | | `/api/user/123` | 3 | `"api"` | `"user"` | `"123"` | ### 2.4 Typical Use Cases ```vb ' Check if it's an API request If ctx.Request.PathInfoList.Count > 0 Then If ctx.Request.PathInfoList(1) = "api" Then ' Handle API request End If End If ' Get resource ID from path (parameter routing is better for this) If ctx.Request.PathInfoList.Count >= 3 Then If ctx.Request.PathInfoList(2) = "user" Then Dim userId As String userId = ctx.Request.PathInfoList(3) ' e.g. "123" End If End If ' Recommended: Use parameter routing to get IDs instead: ' userId = ctx.Request.RouteParams("id") ``` > **Tip**: For getting dynamic parameters from the path (like user IDs), prefer using parameter routing's `RouteParams` — it's more semantic and type-safe. *** ## 3. New Files List | File | Type | Description | | -------------------------- | -------- | ------------------------------------------------------------------------------- | | `cHttpServerRouteItem.cls` | New | Route item class: parses `{param}` patterns, matches paths, extracts parameters | | `cHttpServerRouter.cls` | Modified | Route matching logic: exact match first, parameter route second | | `cHttpServerRequest.cls` | Modified | Added `RouteParams` (Dictionary) and `PathInfoList` (cCollection) | > 100% backward compatible — existing exact route registration and matching are not affected. *** **Last Updated**: 2026-06-11 --- --- url: /en/vbman/database/parameterized.md --- # Parameterized Queries This document details the parameterized query feature of the cDataBase class, an important security feature for preventing SQL injection attacks. *** ## Table of Contents * [Parameterized Query Overview](#parameterized-query-overview) * [Param Method](#param-method) * [ExecParam Method](#execparam-method) * [QueryParam Method](#queryparam-method) * [Data Types](#data-types) * [Security Advantages](#security-advantages) * [Usage Examples](#usage-examples) * [Best Practices](#best-practices) *** ## Parameterized Query Overview ### What is Parameterized Query Parameterized query is a technique that separates SQL statements and parameter values. Parameter values are passed through placeholders (usually `?`). ### Why Use Parameterized Queries 1. **Prevent SQL Injection** - Parameter values are escaped, cannot execute malicious SQL code 2. **Performance Optimization** - Database can cache execution plans 3. **Type Safety** - Automatic data type conversion 4. **Clean Code** - SQL statements and parameter values are separated, easy to maintain ### SQL Injection Example ```vb ' Dangerous: Direct SQL concatenation (vulnerable to SQL injection) Dim sName As String sName = "'; DROP TABLE users; --" db.Sql("SELECT * FROM users WHERE name = '" & sName & "'").Query ' Actual SQL executed: SELECT * FROM users WHERE name = ''; DROP TABLE users; --' ' Result: users table deleted! ' Safe: Use parameterized query db.Sql("SELECT * FROM users WHERE name = ?") _ .Param("name", sName, VBMAN.adVarWChar) _ .QueryParam ' Parameter values are safely processed, cannot execute malicious code ``` *** ## Param Method ### Syntax ```vb Function Param(ByVal ParamName As String, _ ByVal ParamValue As Variant, _ Optional ByVal ParamType As DataTypeEnum = adVarChar) As cDataBase ``` ### Parameters | Parameter | Type | Description | | ------------ | -------------- | ------------------------------------------------------------------ | | `ParamName` | `String` | Parameter name (for identification, actually uses `?` placeholder) | | `ParamValue` | `Variant` | Parameter value (required) | | `ParamType` | `DataTypeEnum` | Parameter data type (optional, default `adVarChar`) | ### Return Value Returns `cDataBase` object, supports chained calls. ### Example ```vb ' Add single parameter db.Sql("SELECT * FROM users WHERE id = ?") _ .Param("id", 1, VBMAN.adInteger) ' Add multiple parameters (chained call) db.Sql("SELECT * FROM users WHERE name = ? AND age > ?") _ .Param("name", "John", VBMAN.adVarWChar) _ .Param("age", 18, VBMAN.adInteger) ``` *** ## ExecParam Method ### Syntax The `ExecParam` method executes parameterized INSERT, UPDATE, DELETE operations. ```vb Function ExecParam(Optional RecordsAffected) As Boolean ``` ### Parameters | Parameter | Type | Description | | ----------------- | --------- | ------------------------------------------ | | `RecordsAffected` | `Variant` | Returns number of affected rows (optional) | ### Return Value * `True` - Execution successful * `False` - Execution failed (view error via `LastErr`) ### Example ```vb ' Insert data If db.Sql("INSERT INTO users (name, age, email) VALUES (?, ?, ?)") _ .Param("name", "John", VBMAN.adVarWChar) _ .Param("age", 25, VBMAN.adInteger) _ .Param("email", "john@example.com", VBMAN.adVarWChar) _ .ExecParam Then Debug.Print "Insert successful, ID: " & db.LastInsertId End If ' Update data If db.Sql("UPDATE users SET age = ?, email = ? WHERE id = ?") _ .Param("age", 26, VBMAN.adInteger) _ .Param("email", "newemail@example.com", VBMAN.adVarWChar) _ .Param("id", 1, VBMAN.adInteger) _ .ExecParam Then Debug.Print "Update successful" End If ' Delete data If db.Sql("DELETE FROM users WHERE id = ?") _ .Param("id", 1, VBMAN.adInteger) _ .ExecParam Then Debug.Print "Delete successful" End If ``` *** ## QueryParam Method ### Syntax The `QueryParam` method executes parameterized SELECT queries. ```vb Function QueryParam(Optional CurType As CursorTypeEnum = adOpenKeyset, _ Optional LockType As LockTypeEnum = adLockOptimistic) As Boolean ``` ### Parameters | Parameter | Type | Description | | ---------- | ---------------- | ------------------------------------------------ | | `CurType` | `CursorTypeEnum` | Cursor type (optional, default `adOpenKeyset`) | | `LockType` | `LockTypeEnum` | Lock type (optional, default `adLockOptimistic`) | ### Return Value * `True` - Query successful, results stored in `db.Rs` * `False` - Query failed (view error via `LastErr`) **Important**: The `QueryParam` method returns a Boolean value, not a Recordset. Query results need to be accessed through the `db.Rs` property. ### Example ```vb ' Query single record (use db.Rs to access results) If db.Sql("SELECT * FROM users WHERE id = ?") _ .Param("id", 1, VBMAN.adInteger) _ .QueryParam Then ' Use db.Rs to access Recordset If Not db.Rs.EOF Then Debug.Print db.Rs("name") End If db.Rs.Close End If ' Query multiple records (use db.Rs to access results) If db.Sql("SELECT * FROM users WHERE age > ? AND status = ?") _ .Param("age", 18, VBMAN.adInteger) _ .Param("status", "active", VBMAN.adVarWChar) _ .QueryParam Then ' Use db.Rs to iterate through results Do Until db.Rs.EOF Debug.Print db.Rs("name") db.Rs.MoveNext Loop db.Rs.Close End If ' If using Fetch method, can access db.Rows and db.Row If db.Sql("SELECT * FROM users WHERE id = ?") _ .Param("id", 1, VBMAN.adInteger) _ .QueryParam Then ' After using Fetch, can access db.Rows and db.Row If db.Fetch Then If db.Rows.Count > 0 Then Debug.Print db.Row("name") End If End If End If ``` *** ## Data Types ### Common Data Types | Type | Value | Description | Example | | ------------ | ----- | ---------------------- | ---------- | | `adVarChar` | 200 | Variable-length string | "John" | | `adVarWChar` | 202 | Unicode string | "John" | | `adInteger` | 3 | 32-bit integer | 25 | | `adBigInt` | 20 | 64-bit integer | 1234567890 | | `adDouble` | 5 | Double precision float | 3.14 | | `adDate` | 7 | Date time | Now | | `adBoolean` | 11 | Boolean | True | | `adDecimal` | 14 | Exact numeric | 99.99 | ### Data Type Selection ```vb ' String db.Param("name", "John", VBMAN.adVarWChar) ' Unicode string (recommended) db.Param("name", "John", VBMAN.adVarChar) ' ANSI string ' Integer db.Param("age", 25, VBMAN.adInteger) ' 32-bit integer db.Param("id", 1234567890, VBMAN.adBigInt) ' 64-bit integer ' Float db.Param("price", 99.99, VBMAN.adDouble) ' Double precision db.Param("amount", 99.99, VBMAN.adDecimal) ' Exact numeric ' Date time db.Param("created", Now, VBMAN.adDate) ' Date time ' Boolean db.Param("active", True, VBMAN.adBoolean) ' Boolean ``` *** ## Security Advantages ### SQL Injection Protection ```vb ' Dangerous: Direct concatenation Dim sInput As String sInput = "'; DROP TABLE users; --" db.Sql("SELECT * FROM users WHERE name = '" & sInput & "'").Query ' Result: users table deleted ' Safe: Parameterized query db.Sql("SELECT * FROM users WHERE name = ?") _ .Param("name", sInput, VBMAN.adVarWChar) _ .QueryParam ' Parameter values are safely processed, cannot execute malicious code ``` ### Special Character Handling ```vb ' Dangerous: Special characters may cause errors Dim sName As String sName = "O'Brien" db.Sql("SELECT * FROM users WHERE name = '" & sName & "'").Query ' SQL: SELECT * FROM users WHERE name = 'O'Brien' ' Error: Unescaped single quote ' Safe: Parameterized query handles automatically db.Sql("SELECT * FROM users WHERE name = ?") _ .Param("name", sName, VBMAN.adVarWChar) _ .QueryParam ' Special characters are automatically escaped ``` *** ## Usage Examples ### Example 1: User Login ```vb Function UserLogin(sUsername As String, sPassword As String) As Boolean ' Use parameterized query to prevent SQL injection If db.Sql("SELECT * FROM users WHERE username = ? AND password = ?") _ .Param("username", sUsername, VBMAN.adVarWChar) _ .Param("password", sPassword, VBMAN.adVarWChar) _ .QueryParam Then If db.Rows.Count > 0 Then UserLogin = True Else UserLogin = False End If Else UserLogin = False End If End Function ``` ### Example 2: Search Feature ```vb Function SearchUsers(sKeyword As String) As Collection Set SearchUsers = New Collection ' Use LIKE with parameterized query Dim sSql As String sSql = "SELECT * FROM users WHERE name LIKE ? OR email LIKE ?" If db.Sql(sSql) _ .Param("name", "%" & sKeyword & "%", VBMAN.adVarWChar) _ .Param("email", "%" & sKeyword & "%", VBMAN.adVarWChar) _ .QueryParam Then Set SearchUsers = db.Rows End If End Function ``` ### Example 3: Batch Insert ```vb Sub BatchInsertUsers(colUsers As Collection) db.TransBegin Dim i As Long For i = 1 To colUsers.Count Dim dictUser As Dictionary Set dictUser = colUsers(i) If Not db.Sql("INSERT INTO users (name, age, email) VALUES (?, ?, ?)") _ .Param("name", dictUser("name"), VBMAN.adVarWChar) _ .Param("age", dictUser("age"), VBMAN.adInteger) _ .Param("email", dictUser("email"), VBMAN.adVarWChar) _ .ExecParam Then db.TransRollback Exit Sub End If Next db.TransCommit End Sub ``` ### Example 4: Dynamic Query ```vb Function GetUsers(Optional sName As String = "", _ Optional lMinAge As Long = 0, _ Optional sStatus As String = "") As Collection Set GetUsers = New Collection Dim sSql As String sSql = "SELECT * FROM users WHERE 1=1" ' Dynamically build SQL and parameters If sName <> "" Then sSql = sSql & " AND name LIKE ?" End If If lMinAge > 0 Then sSql = sSql & " AND age >= ?" End If If sStatus <> "" Then sSql = sSql & " AND status = ?" End If ' Set SQL db.Sql (sSql) ' Add parameters If sName <> "" Then db.Param "name", "%" & sName & "%", VBMAN.adVarWChar End If If lMinAge > 0 Then db.Param "age", lMinAge, VBMAN.adInteger End If If sStatus <> "" Then db.Param "status", sStatus, VBMAN.adVarWChar End If ' Execute query If db.QueryParam Then Set GetUsers = db.Rows End If End Function ``` *** ## Best Practices ### 1. Always Use Parameterized Queries for User Input ```vb ' Recommended: Use parameterized queries db.Sql("SELECT * FROM users WHERE name = ?") _ .Param("name", txtName.Text, VBMAN.adVarWChar) _ .QueryParam ' Not recommended: Direct concatenation of user input db.Sql("SELECT * FROM users WHERE name = '" & txtName.Text & "'").Query ``` ### 2. Choose Correct Data Types ```vb ' Recommended: Explicitly specify data types db.Param("age", 25, VBMAN.adInteger) db.Param("name", "John", VBMAN.adVarWChar) db.Param("price", 99.99, VBMAN.adDecimal) ' Not recommended: Use default types (may cause type mismatch) db.Param("age", 25) ' Default adVarChar, may cause errors ``` ### 3. Use Unicode String Type ```vb ' Recommended: Use adVarWChar to support Chinese db.Param("name", "John", VBMAN.adVarWChar) ' Not recommended: Use adVarChar (may cause Chinese garbled text) db.Param("name", "John", VBMAN.adVarChar) ``` ### 4. Parameter Order Must Match Placeholder Order ```vb ' Correct: Parameter order matches ? order db.Sql("SELECT * FROM users WHERE name = ? AND age > ?") _ .Param("name", "John", VBMAN.adVarWChar) _ .Param("age", 18, VBMAN.adInteger) ' Wrong: Parameter order is wrong db.Sql("SELECT * FROM users WHERE name = ? AND age > ?") _ .Param("age", 18, VBMAN.adInteger) _ .Param("name", "John", VBMAN.adVarWChar) ``` ### 5. Clear Parameters ```vb ' Note: ExecParam and QueryParam automatically clear parameters ' If only calling Param without executing, need to manually clear (by executing or recreating object) ``` *** ## Common Questions ### Q1: Is Parameterized Query Slower Than Direct Concatenation? **Answer**: No, parameterized queries are usually faster because: * Database can cache execution plans * Reduces SQL parsing time * Avoids string concatenation overhead ### Q2: How to Use Parameters in LIKE Queries? ```vb ' Correct: Include wildcards in parameter value db.Sql("SELECT * FROM users WHERE name LIKE ?") _ .Param("name", "%" & sKeyword & "%", VBMAN.adVarWChar) _ .QueryParam ' Wrong: Use wildcards in SQL db.Sql("SELECT * FROM users WHERE name LIKE '%?%'") _ .Param("name", sKeyword, VBMAN.adVarWChar) _ .QueryParam ``` ### Q3: How to Handle NULL Values? ```vb ' Use Null value db.Sql("SELECT * FROM users WHERE email = ?") _ .Param("email", Null, VBMAN.adVarWChar) _ .QueryParam ' Or use IS NULL db.Sql("SELECT * FROM users WHERE email IS NULL").Query ``` ### Q4: Does Parameterized Query Support IN Clause? ```vb ' Note: ADO parameterized query has limited support for IN clause ' Recommendation: Use multiple OR conditions or dynamically build SQL ' Method 1: Use multiple OR db.Sql("SELECT * FROM users WHERE id = ? OR id = ? OR id = ?") _ .Param("id1", 1, VBMAN.adInteger) _ .Param("id2", 2, VBMAN.adInteger) _ .Param("id3", 3, VBMAN.adInteger) _ .QueryParam ' Method 2: Dynamic building (requires input validation) Dim sIds As String sIds = "1,2,3" ' Needs format validation db.Sql("SELECT * FROM users WHERE id IN (" & sIds & ")").Query ``` *** **Last Updated**: 2026-01-21 --- --- url: /en/packages/vbccr/ranges/progressbar.md description: >- ProgressBar Control - VBCCR Development Manual, complete API reference based on source code --- # ProgressBar Control Wraps the msctls\_progress32 system progress bar control for displaying operation progress, supporting standard, smooth, and marquee scrolling modes as well as taskbar progress display. ## Enumerations ### PrbOrientationConstants | Constant | Value | Description | |----------|-------|-------------| | PrbOrientationHorizontal | 0 | Horizontal orientation | | PrbOrientationVertical | 1 | Vertical orientation | ### PrbScrollingConstants | Constant | Value | Description | |----------|-------|-------------| | PrbScrollingStandard | 0 | Standard mode | | PrbScrollingSmooth | 1 | Smooth scrolling | | PrbScrollingMarquee | 2 | Marquee mode | ### PrbStateConstants | Constant | Value | Description | |----------|-------|-------------| | PrbStateNormal | 1 | Normal state | | PrbStateError | 2 | Error state (red) | | PrbStatePaused | 3 | Paused state (yellow) | ### CCMousePointerConstants See common enumerations. ## Properties ### Min ```vb Property Get Min() As Long Property Let Min(ByVal Value As Long) ``` Minimum value. ### Max ```vb Property Get Max() As Long Property Let Max(ByVal Value As Long) ``` Maximum value. ### Value ```vb Property Get Value() As Long Property Let Value(ByVal Value As Long) ``` Current value. ### Step ```vb Property Get Step() As Long Property Let Step(ByVal Value As Long) ``` Step increment. ### StepAutoReset ```vb Property Get StepAutoReset() As Boolean Property Let StepAutoReset(ByVal Value As Boolean) ``` Whether to automatically reset to the minimum value when StepIt reaches the maximum. ### MarqueeAnimation ```vb Property Get MarqueeAnimation() As Boolean Property Let MarqueeAnimation(ByVal Value As Boolean) ``` Whether to enable marquee animation. Only effective when Scrolling is PrbScrollingMarquee. ### MarqueeSpeed ```vb Property Get MarqueeSpeed() As Long Property Let MarqueeSpeed(ByVal Value As Long) ``` Marquee animation speed in milliseconds. Only effective when Scrolling is PrbScrollingMarquee. ### Orientation ```vb Property Get Orientation() As PrbOrientationConstants Property Let Orientation(ByVal Value As PrbOrientationConstants) ``` Progress bar orientation. ### Scrolling ```vb Property Get Scrolling() As PrbScrollingConstants Property Let Scrolling(ByVal Value As PrbScrollingConstants) ``` Scrolling mode. ### SmoothReverse ```vb Property Get SmoothReverse() As Boolean Property Let SmoothReverse(ByVal Value As Boolean) ``` Whether to enable smooth reverse effect. Requires comctl32.dll version 6.0 or later. ### BackColor ```vb Property Get BackColor() As OLE_COLOR Property Let BackColor(ByVal Value As OLE_COLOR) ``` Background color. ### ForeColor ```vb Property Get ForeColor() As OLE_COLOR Property Let ForeColor(ByVal Value As OLE_COLOR) ``` Foreground color. ### State ```vb Property Get State() As PrbStateConstants Property Let State(ByVal Value As PrbStateConstants) ``` Progress bar state (normal/error/paused). ### ShowInTaskBar ```vb Property Get ShowInTaskBar() As Boolean Property Let ShowInTaskBar(ByVal Value As Boolean) ``` Whether to display progress on the taskbar. Requires Windows 7 or later. ### Text ```vb Property Get Text() As String Property Let Text(ByVal Value As String) ``` Text overlaid on the progress bar. Supports placeholders: `{0}` for current value, `{1}` for minimum value, `{2}` for maximum value, `{3}` for percentage value. ### TextColor ```vb Property Get TextColor() As OLE_COLOR Property Let TextColor(ByVal Value As OLE_COLOR) ``` Color of the overlay text. ### BorderStyle ```vb Property Get BorderStyle() As Integer Property Let BorderStyle(ByVal Value As Integer) ``` Border style (vbBSNone or vbFixedSingle). ### VisualStyles ```vb Property Get VisualStyles() As Boolean Property Let VisualStyles(ByVal Value As Boolean) ``` Whether to enable visual styles. ### hWnd ```vb Property Get hWnd() As LongPtr ``` Window handle of the progress bar control. ### hWndUserControl ```vb Property Get hWndUserControl() As LongPtr ``` Window handle of the user control. ### Font ```vb Property Get Font() As StdFont Property Let Font(ByVal NewFont As StdFont) Property Set Font(ByVal NewFont As StdFont) ``` Font. ### Enabled ```vb Property Get Enabled() As Boolean Property Let Enabled(ByVal Value As Boolean) ``` Whether the control is enabled. ### MousePointer ```vb Property Get MousePointer() As CCMousePointerConstants Property Let MousePointer(ByVal Value As CCMousePointerConstants) ``` Mouse pointer style. See common enumerations. ### MouseIcon ```vb Property Get MouseIcon() As IPictureDisp Property Let MouseIcon(ByVal Value As IPictureDisp) Property Set MouseIcon(ByVal Value As IPictureDisp) ``` Custom mouse icon. ### MouseTrack ```vb Property Get MouseTrack() As Boolean Property Let MouseTrack(ByVal Value As Boolean) ``` Whether to enable mouse enter/leave tracking. ### Name ```vb Property Get Name() As String ``` Control name. Read-only. ### Tag ```vb Property Get Tag() As String Property Let Tag(ByVal Value As String) ``` Custom data. ### Parent ```vb Property Get Parent() As Object ``` Parent object. Read-only. ### Container ```vb Property Get Container() As Object Property Set Container(ByVal Value As Object) ``` Container object. ### Left ```vb Property Get Left() As Single Property Let Left(ByVal Value As Single) ``` Left position. ### Top ```vb Property Get Top() As Single Property Let Top(ByVal Value As Single) ``` Top position. ### Width ```vb Property Get Width() As Single Property Let Width(ByVal Value As Single) ``` Width. ### Height ```vb Property Get Height() As Single Property Let Height(ByVal Value As Single) ``` Height. ### Visible ```vb Property Get Visible() As Boolean Property Let Visible(ByVal Value As Boolean) ``` Whether the control is visible. ### ToolTipText ```vb Property Get ToolTipText() As String Property Let ToolTipText(ByVal Value As String) ``` Tooltip text. ### HelpContextID ```vb Property Get HelpContextID() As Long Property Let HelpContextID(ByVal Value As Long) ``` Help context ID. ### WhatsThisHelpID ```vb Property Get WhatsThisHelpID() As Long Property Let WhatsThisHelpID(ByVal Value As Long) ``` "What's This" help ID. ### DragIcon ```vb Property Get DragIcon() As IPictureDisp Property Let DragIcon(ByVal Value As IPictureDisp) Property Set DragIcon(ByVal Value As IPictureDisp) ``` Drag icon. ### DragMode ```vb Property Get DragMode() As Integer Property Let DragMode(ByVal Value As Integer) ``` Drag mode. ## Methods ### StepIt ```vb Public Sub StepIt() ``` Advances the current position by the increment specified by the Step property. ### Increment ```vb Public Sub Increment(ByVal Delta As Long) ``` Advances the current position by the specified increment. ### Drag ```vb Public Sub Drag([ByRef Action As Variant]) ``` Starts, ends, or cancels a drag operation. ### SetFocus ```vb Public Sub SetFocus() ``` Moves focus to the control. ### ZOrder ```vb Public Sub ZOrder([ByRef Position As Variant]) ``` Sets the Z-order of the control. ### OLEDrag ```vb Public Sub OLEDrag() ``` Initiates an OLE drag operation. ### Refresh ```vb Public Sub Refresh() ``` Forces the control to repaint. ## Events ### Change ```vb Public Event Change() ``` Fired when the Value property changes. ### Click ```vb Public Event Click() ``` Fired when the control is clicked. ### DblClick ```vb Public Event DblClick() ``` Fired when the control is double-clicked. ### MouseDown ```vb Public Event MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` Fired when a mouse button is pressed. ### MouseUp ```vb Public Event MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` Fired when a mouse button is released. ### MouseMove ```vb Public Event MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` Fired when the mouse is moved. ### MouseEnter ```vb Public Event MouseEnter() ``` Fired when the mouse enters the control. ### MouseLeave ```vb Public Event MouseLeave() ``` Fired when the mouse leaves the control. ### KeyDown ```vb Public Event KeyDown(KeyCode As Integer, Shift As Integer) ``` Fired when a key is pressed. ### KeyUp ```vb Public Event KeyUp(KeyCode As Integer, Shift As Integer) ``` Fired when a key is released. ### KeyPress ```vb Public Event KeyPress(KeyChar As Integer) ``` Fired when a key character is input. ## Code Examples ```vb ' Standard progress bar ProgressBar1.Min = 0 ProgressBar1.Max = 100 ProgressBar1.Value = 0 ProgressBar1.Step = 10 ProgressBar1.StepIt ' Progress bar with text overlay ProgressBar1.Min = 0 ProgressBar1.Max = 1000 ProgressBar1.Text = "Processing {3}%" ProgressBar1.TextColor = vbWhite ' Marquee mode (indeterminate progress) ProgressBar1.Scrolling = PrbScrollingMarquee ProgressBar1.MarqueeAnimation = True ProgressBar1.MarqueeSpeed = 30 ' Taskbar progress display (Windows 7+) ProgressBar1.ShowInTaskBar = True ProgressBar1.State = PrbStateNormal ``` --- --- url: /en/vbman/database/query.md --- # Query Operations This document details the query functionality of the cDataBase class, including basic queries, result set processing, etc. *** ## Table of Contents * [Basic Query](#basic-query) * [Query Methods](#query-methods) * [Result Set Processing](#result-set-processing) * [Query Options](#query-options) * [Common Query Scenarios](#common-query-scenarios) *** ## Basic Query ### Sql Method The `Sql` method sets the SQL query statement. #### Syntax ```vb Function Sql(ByVal RawSqlString As String) As cDataBase ``` #### Example ```vb ' Set SQL statement db.Sql "SELECT * FROM users WHERE age > 18" ``` ### Query Method The `Query` method executes a query and returns a Boolean value. **Query results are stored in the `db.Rs` property, not as the return value**. #### Syntax ```vb Function Query(Optional CurType As CursorTypeEnum = adOpenKeyset, _ Optional LockType As LockTypeEnum = adLockOptimistic, _ Optional Options As Long = -1) As Boolean ``` #### Parameters | Parameter | Type | Description | | --------- | ---- | ----------- | | `CurType` | `CursorTypeEnum` | Cursor type (optional, default `adOpenKeyset`) | | `LockType` | `LockTypeEnum` | Lock type (optional, default `adLockOptimistic`) | | `Options` | `Long` | Query options (optional, default -1) | #### Return Value * `True` - Query successful, results stored in `db.Rs` * `False` - Query failed (view error via `LastErr`) **Important**: The `Query` method returns a Boolean value, not a Recordset. Query results need to be accessed through the `db.Rs` property. #### Example ```vb ' Basic query If db.Sql("SELECT * FROM users").Query Then ' Query successful, use db.Rs to access Recordset (not the return value) Do Until db.Rs.EOF Debug.Print db.Rs("name") db.Rs.MoveNext Loop ' Close Recordset when done db.Rs.Close End If ' Wrong example: Don't assign Query return value to Recordset variable ' Dim Rs As ADODB.Recordset ' Set Rs = db.Query("SELECT * FROM users") ' Wrong! Query returns Boolean ' Correct example: Use db.Rs to access results If db.Sql("SELECT * FROM users").Query Then ' Use db.Rs to access results Do Until db.Rs.EOF Debug.Print db.Rs("name") db.Rs.MoveNext Loop db.Rs.Close End If ``` ### Fetch Method The `Fetch` method executes a query and automatically converts to Dictionary collection. **Main use case is for JSON output and data exchange**, especially for use with `cHttpServer` and other components. #### Syntax ```vb Function Fetch(Optional CurType As CursorTypeEnum = adOpenKeyset, _ Optional LockType As LockTypeEnum = adLockOptimistic, _ Optional Options As Long = -1) As Boolean ``` #### Functionality * Execute query * Automatically convert Recordset to Collection (stored in `Rows` property) * Automatically set first row to `Row` property * **Can be directly used for JSON serialization**, works with `cJson` and `cHttpServerResponse` #### Example ```vb ' Query and auto-convert If db.Sql("SELECT * FROM users WHERE age > 18").Fetch Then ' Access first row Debug.Print db.Row("name") Debug.Print db.Row("age") ' Iterate all rows Dim i As Long For i = 1 To db.Rows.Count Debug.Print db.Rows(i)("name") Next End If ``` #### JSON Output Scenario (Main Use Case) The main advantage of `Fetch` is convenient conversion of query results to JSON strings for external data exchange: ```vb ' Usage in HttpServer route Private Sub Server_OnRoute(ctx As VBMAN.cHttpServerContext) ' Query data If ctx.Db.Sql("SELECT * FROM users").Fetch Then ' Direct JSON output (one line) ctx.Response.Json ctx.Db.Rows End If End Sub ' Or use cJson object Dim json As New VBMAN.cJson If db.Sql("SELECT * FROM users").Fetch Then Dim sJson As String sJson = json.Encode(db.Rows) ' Convert to JSON string Debug.Print sJson End If ``` **Note**: `cHttpServerResponse.Json` method automatically recognizes Recordset and converts, but using `Fetch` and passing `db.Rows` (Collection) is more efficient as conversion is already done. *** ## Query Method Comparison | Method | Return Type | Auto Convert | Use Scenario | | ------ | ----------- | ------------ | ------------ | | `Query` | `Recordset` | No | Need direct Recordset operation, need Recordset advanced features | | `Fetch` | `Collection` | Yes | **Mainly for JSON output and data exchange**, use with cHttpServer, cJson | *** ## Result Set Processing ### Rs Property The `Rs` property provides direct access to the ADO Recordset. ```vb ' Use Recordset If db.Sql("SELECT * FROM users").Query Then Do Until db.Rs.EOF Debug.Print db.Rs("name") Debug.Print db.Rs("age") db.Rs.MoveNext Loop ' Get record count Debug.Print "Total records: " & db.Rs.RecordCount End If ``` ### Rows Property The `Rows` property is the converted Collection containing all row Dictionaries. **Can be directly used for JSON serialization**. ```vb ' Use Collection If db.Sql("SELECT * FROM users").Fetch Then Dim i As Long For i = 1 To db.Rows.Count Debug.Print db.Rows(i)("name") Debug.Print db.Rows(i)("age") Next End If ``` #### JSON Output Examples ```vb ' Scenario 1: Direct JSON output in HttpServer Private Sub Server_OnRoute(ctx As VBMAN.cHttpServerContext) If ctx.Db.Sql("SELECT * FROM users").Fetch Then ' Direct JSON output (recommended) ctx.Response.Json ctx.Db.Rows End If End Sub ' Scenario 2: Use cJson object to convert to JSON string Dim json As New VBMAN.cJson If db.Sql("SELECT * FROM users").Fetch Then Dim sJson As String sJson = json.Encode(db.Rows) ' Output: [{"id":1,"name":"John","age":25},{"id":2,"name":"Mary","age":30}] End If ' Scenario 3: JSON output with pagination If db.Sql("SELECT * FROM users").Page(1, 10).Fetch Then Dim lTotal As Long lTotal = db.Count("users") ' Output JSON with total count and pagination info ctx.Response.Json db.Rows, 200, "Success", lTotal End If ``` ### Row Property The `Row` property is the Dictionary of the current first row. ```vb ' Access first row If db.Sql("SELECT * FROM users WHERE id = 1").Fetch Then Debug.Print db.Row("name") Debug.Print db.Row("age") End If ``` ### Result Set Structure ``` Rows (Collection) ├── Rows(1) (Dictionary) │ ├── "id" => 1 │ ├── "name" => "John" │ └── "age" => 25 ├── Rows(2) (Dictionary) │ ├── "id" => 2 │ ├── "name" => "Mary" │ └── "age" => 30 └── ... ``` *** ## Query Options ### Cursor Type (CursorTypeEnum) | Type | Value | Description | | ---- | ----- | ----------- | | `adOpenForwardOnly` | 0 | Forward-only cursor (fastest) | | `adOpenKeyset` | 1 | Keyset cursor (default) | | `adOpenDynamic` | 2 | Dynamic cursor | | `adOpenStatic` | 3 | Static cursor | ```vb ' Use forward-only cursor (best performance) db.Sql("SELECT * FROM users").Query adOpenForwardOnly ' Use static cursor (supports RecordCount) db.Sql("SELECT * FROM users").Query adOpenStatic ``` ### Lock Type (LockTypeEnum) | Type | Value | Description | | ---- | ----- | ----------- | | `adLockReadOnly` | 1 | Read-only (default for query) | | `adLockPessimistic` | 2 | Pessimistic locking | | `adLockOptimistic` | 3 | Optimistic locking | | `adLockBatchOptimistic` | 4 | Batch optimistic locking | ```vb ' Read-only query (best performance) db.Sql("SELECT * FROM users").Query adOpenKeyset, adLockReadOnly ``` *** ## Common Query Scenarios ### Scenario 1: Single Record Query ```vb ' Query single record If db.Sql("SELECT * FROM users WHERE id = 1").Fetch Then If db.Rows.Count > 0 Then Debug.Print "Username: " & db.Row("name") Debug.Print "Age: " & db.Row("age") Else Debug.Print "Record not found" End If End If ``` ### Scenario 2: Conditional Query ```vb ' Multi-condition query Dim sSql As String sSql = "SELECT * FROM users WHERE age > 18 AND status = 'active'" If db.Sql(sSql).Fetch Then Dim i As Long For i = 1 To db.Rows.Count Debug.Print db.Rows(i)("name") Next End If ``` ### Scenario 3: Sorted Query ```vb ' Descending order by age If db.Sql("SELECT * FROM users ORDER BY age DESC").Fetch Then Dim i As Long For i = 1 To db.Rows.Count Debug.Print db.Rows(i)("name") & " - " & db.Rows(i)("age") Next End If ``` ### Scenario 4: Aggregate Query ```vb ' Statistical query If db.Sql("SELECT COUNT(*) AS cnt, AVG(age) AS avg_age FROM users").Fetch Then If db.Rows.Count > 0 Then Debug.Print "Total users: " & db.Row("cnt") Debug.Print "Average age: " & db.Row("avg_age") End If End If ``` ### Scenario 5: Grouped Query ```vb ' Grouped statistics If db.Sql("SELECT status, COUNT(*) AS cnt FROM users GROUP BY status").Fetch Then Dim i As Long For i = 1 To db.Rows.Count Debug.Print db.Rows(i)("status") & ": " & db.Rows(i)("cnt") Next End If ``` ### Scenario 6: Join Query ```vb ' Inner join query Dim sSql As String sSql = "SELECT u.name, p.title " & _ "FROM users u " & _ "INNER JOIN posts p ON u.id = p.user_id" If db.Sql(sSql).Fetch Then Dim i As Long For i = 1 To db.Rows.Count Debug.Print db.Rows(i)("name") & " - " & db.Rows(i)("title") Next End If ``` ### Scenario 7: Subquery ```vb ' Subquery Dim sSql As String sSql = "SELECT * FROM users " & _ "WHERE id IN (SELECT user_id FROM orders WHERE amount > 1000)" If db.Sql(sSql).Fetch Then ' Process results End If ``` ### Scenario 8: Fuzzy Query ```vb ' LIKE query If db.Sql("SELECT * FROM users WHERE name LIKE '%John%'").Fetch Then Dim i As Long For i = 1 To db.Rows.Count Debug.Print db.Rows(i)("name") Next End If ``` ### Scenario 9: Paginated Query ```vb ' Use Page method (see pagination.md for details) If db.Sql("SELECT * FROM users").Page(1, 10).Fetch Then Dim i As Long For i = 1 To db.Rows.Count Debug.Print db.Rows(i)("name") Next End If ``` ### Scenario 10: Parameterized Query ```vb ' Use parameterized query (see parameterized.md for details) If db.Sql("SELECT * FROM users WHERE name = ? AND age > ?") _ .Param("name", "John", VBMAN.adVarWChar) _ .Param("age", 18, VBMAN.adInteger) _ .QueryParam Then Dim i As Long For i = 1 To db.Rows.Count Debug.Print db.Rows(i)("name") Next End If ``` ### Scenario 11: JSON Output (Main Use Case for Fetch) ```vb ' Output JSON in HttpServer route Private Sub Server_OnRoute(ctx As VBMAN.cHttpServerContext) ' Query data and convert to Collection If ctx.Db.Sql("SELECT * FROM users WHERE status = 'active'").Fetch Then ' Direct JSON output (one line) ctx.Response.Json ctx.Db.Rows End If End Sub ' Paginated JSON API Private Sub Server_OnRoute(ctx As VBMAN.cHttpServerContext) Dim lPage As Long Dim lPageSize As Long lPage = CLng(ctx.Request.Query("page")) lPageSize = CLng(ctx.Request.Query("pageSize")) ' Query paginated data If ctx.Db.Sql("SELECT * FROM users ORDER BY id").Page(lPage, lPageSize).Fetch Then Dim lTotal As Long lTotal = ctx.Db.Count("users") ' Output JSON with data, total count, etc. ctx.Response.Json ctx.Db.Rows, 200, "Success", lTotal End If End Sub ' Use cJson object to convert to JSON string Dim json As New VBMAN.cJson If db.Sql("SELECT * FROM users").Fetch Then Dim sJson As String sJson = json.Encode(db.Rows) ' Can be used for file saving, network transmission, etc. Debug.Print sJson End If ``` *** ## Performance Optimization ### 1. Only Query Needed Fields ```vb ' Not recommended: Query all fields db.Sql("SELECT * FROM users").Query ' Recommended: Only query needed fields db.Sql("SELECT id, name FROM users").Query ``` ### 2. Use Indexed Fields ```vb ' Recommended: Use indexed fields as conditions db.Sql("SELECT * FROM users WHERE id = 1").Query ``` ### 3. Limit Result Set Size ```vb ' Recommended: Use TOP to limit results db.Sql("SELECT TOP 100 * FROM users").Query ``` ### 4. Use Appropriate Cursor Types ```vb ' Recommended: Use ForwardOnly for read-only queries db.Sql("SELECT * FROM users").Query adOpenForwardOnly, adLockReadOnly ``` *** ## Error Handling ```vb ' Query error handling If Not db.Sql("SELECT * FROM users").Query Then Debug.Print "Query failed" Debug.Print "Error code: " & db.LastErrNumber Debug.Print "Error description: " & db.LastErrDescription Debug.Print "Full info: " & db.LastErr Exit Sub End If ``` *** ## Best Practices ### 1. Always Check Return Values ```vb ' Recommended If db.Sql("SELECT * FROM users").Query Then ' Process results Else ' Error handling End If ``` ### 2. Use Fetch for JSON Output ```vb ' Recommended: Use Fetch for JSON output (main use case) If db.Sql("SELECT * FROM users").Fetch Then ' Direct output in HttpServer ctx.Response.Json db.Rows ' Output single record only ctx.Response.Json db.Row ' Or use cJson object Dim json As New VBMAN.cJson Dim sJson As String sJson = json.Encode(db.Rows) End If ``` ### 3. Release Resources Promptly ```vb ' Recommended: Close Recordset after query If db.Sql("SELECT * FROM users").Query Then ' Process results If db.Rs.State <> adStateClosed Then db.Rs.Close End If End If ``` *** **Last Updated**: 2026-01-21 --- --- url: /en/vbman/database/quickstart.md --- # Quick Start This guide will help you get started with the cDataBase class library and create basic database applications. *** ## Prerequisites ### Required Files Ensure the following files have been added to your project: | File | Location | Description | | ---- | -------- | ----------- | | `VBMAN.dll` | Project Reference | Compiled COM component | | `Microsoft ActiveX Data Objects 2.8 Library` | Project Reference | ADO core library | ### Adding to Project 1. Open VB6 project 2. Menu: **Project** → **References** 3. Check the following references: * **VBMAN** (VBMAN.dll) * **Microsoft ActiveX Data Objects 2.8 Library** *** ## Client Quick Start ### Step 1: Create Form Create a new form and add the following controls: * 1 TextBox (`txtLog`) - Display logs (MultiLine = True) * 1 CommandButton (`cmdConnect`) - Connect to database * 1 CommandButton (`cmdQuery`) - Execute query ### Step 2: Write Code ```vb Option Explicit ' Declare database object (use class from VBMAN.dll) Private WithEvents m_DB As VBMAN.cDataBase Private Sub Form_Load() ' Create database object Set m_DB = New VBMAN.cDataBase ' Connect to SQL Server database If m_DB.Connect(VBMAN.enumDbType_MsSql, _ "127.0.0.1,1433", _ "sa", _ "Sa123456", _ "master") Then LogMessage "Database connection successful" Else LogMessage "Database connection failed: " & m_DB.LastErr End If End Sub Private Sub cmdQuery_Click() On Error GoTo EH ' Execute query If m_DB.Sql("SELECT TOP 10 * FROM sys.tables").Query Then ' Get result set Dim i As Long For i = 1 To m_DB.Rows.Count LogMessage "Table name: " & m_DB.Rows(i)("name") Next Else LogMessage "Query failed: " & m_DB.LastErr End If Exit Sub EH: LogMessage "Error: " & Err.Description End Sub ' ====== Helper Functions ====== Private Sub LogMessage(sMessage As String) txtLog.Text = txtLog.Text & Format$(Now, "hh:mm:ss") & " - " & sMessage & vbCrLf txtLog.SelStart = Len(txtLog.Text) End Sub Private Sub Form_Unload(Cancel As Integer) ' Disconnect If Not m_DB Is Nothing Then m_DB.Disconnect End If End Sub ``` ### Step 3: Run Test 1. Press F5 to run the program 2. Click "Connect to Database" 3. Click "Execute Query" 4. View log output *** ## Server Quick Start ### Step 1: Create Form Create a new form and add the following controls: * 1 TextBox (`txtPort`) - Port number * 1 CommandButton (`cmdStart`) - Start server * 1 ListBox (`lstResults`) - Display results * 1 TextBox (`txtLog`) - Display logs ### Step 2: Write Code ```vb Option Explicit Private WithEvents m_DB As VBMAN.cDataBase Private Sub Form_Load() Set m_DB = New VBMAN.cDataBase txtPort.Text = "1433" End Sub Private Sub cmdStart_Click() On Error GoTo EH ' Connect to database If m_DB.Connect(VBMAN.enumDbType_MsSql, _ "127.0.0.1," & txtPort.Text, _ "sa", _ "Sa123456", _ "master") Then LogMessage "Database service started" LoadData Else LogMessage "Start failed: " & m_DB.LastErr End If Exit Sub EH: LogMessage "Error: " & Err.Description End Sub Private Sub LoadData() ' Query data If m_DB.Sql("SELECT name FROM sys.tables ORDER BY name").Fetch Then Dim i As Long lstResults.Clear For i = 1 To m_DB.Rows.Count lstResults.AddItem m_DB.Rows(i)("name") Next LogMessage "Loaded " & m_DB.Rows.Count & " records" End If End Sub ' ====== Helper Functions ====== Private Sub LogMessage(sMessage As String) txtLog.Text = txtLog.Text & Format$(Now, "hh:mm:ss") & " - " & sMessage & vbCrLf txtLog.SelStart = Len(txtLog.Text) End Sub Private Sub Form_Unload(Cancel As Integer) If Not m_DB Is Nothing Then m_DB.Disconnect End If End Sub ``` *** ## Complete Example: User Management ### Server Code ```vb Option Explicit Private WithEvents m_DB As VBMAN.cDataBase Private Sub Form_Load() Set m_DB = New VBMAN.cDataBase ' Connect to database m_DB.Connect VBMAN.enumDbType_MsSql, "127.0.0.1,1433", "sa", "pwd", "mydb" ' Create user table (if not exists) CreateUserTable ' Load user list LoadUsers End Sub ' Create user table Private Sub CreateUserTable() Dim sSql As String sSql = "IF NOT EXISTS (SELECT * FROM sys.tables WHERE name = 'users') " & _ "CREATE TABLE users (id INT IDENTITY(1,1) PRIMARY KEY, " & _ "name NVARCHAR(50), age INT, email NVARCHAR(100))" m_DB.Sql(sSql).Exec End Sub ' Load user list Private Sub LoadUsers() If m_DB.Sql("SELECT * FROM users ORDER BY id").Fetch Then Dim i As Long lstUsers.Clear For i = 1 To m_DB.Rows.Count lstUsers.AddItem m_DB.Rows(i)("name") & " - " & m_DB.Rows(i)("age") Next End If End Sub ' Add user Private Sub cmdAddUser_Click() ' Use parameterized query to prevent SQL injection If m_DB.Sql("INSERT INTO users (name, age, email) VALUES (?, ?, ?)") _ .Param("name", txtName.Text, VBMAN.adVarWChar) _ .Param("age", CLng(txtAge.Text), VBMAN.adInteger) _ .Param("email", txtEmail.Text, VBMAN.adVarWChar) _ .ExecParam Then LogMessage "User added successfully, ID: " & m_DB.LastInsertId LoadUsers Else LogMessage "Add failed: " & m_DB.LastErr End If End Sub ' Delete user Private Sub cmdDeleteUser_Click() If m_DB.Sql("DELETE FROM users WHERE id = ?") _ .Param("id", CLng(txtId.Text), VBMAN.adInteger) _ .ExecParam Then LogMessage "User deleted successfully" LoadUsers End If End Sub Private Sub LogMessage(sMessage As String) txtLog.Text = txtLog.Text & Format$(Now, "hh:mm:ss") & " - " & sMessage & vbCrLf txtLog.SelStart = Len(txtLog.Text) End Sub ``` ### Client Code ```vb Option Explicit Private WithEvents m_DB As VBMAN.cDataBase Private Sub Form_Load() Set m_DB = New VBMAN.cDataBase m_DB.Connect VBMAN.enumDbType_MsSql, "127.0.0.1,1433", "sa", "pwd", "mydb" LoadUsers End Sub Private Sub LoadUsers() ' Use paginated query If m_DB.Sql("SELECT * FROM users").Page(1, 10).Fetch Then Dim i As Long lstUsers.Clear For i = 1 To m_DB.Rows.Count lstUsers.AddItem m_DB.Rows(i)("name") & " - " & m_DB.Rows(i)("age") Next End If End Sub Private Sub cmdSearch_Click() ' Use parameterized query for search If m_DB.Sql("SELECT * FROM users WHERE name LIKE ?") _ .Param("name", "%" & txtSearch.Text & "%", VBMAN.adVarWChar) _ .QueryParam Then Dim i As Long lstResults.Clear For i = 1 To m_DB.Rows.Count lstResults.AddItem m_DB.Rows(i)("name") Next End If End Sub ``` *** ## Common Questions ### Q1: Compilation Error "User-defined type not defined" **Cause**: VBMAN.dll or Microsoft ActiveX Data Objects 2.8 Library not referenced **Solution**: 1. Menu: **Project** → **References** 2. Check **VBMAN** and **Microsoft ActiveX Data Objects 2.8 Library** *** ### Q2: Connection Failed "Cannot connect to database" **Cause**: Connection string error or database service not started **Solution**: * Check if database service is running * Verify connection parameters (address, port, username, password) * Check firewall settings *** ### Q3: Query Returns Empty Results **Cause**: SQL statement error or table does not exist **Solution**: * Use `m_DB.LastErr` to view error information * Check SQL statement syntax * Verify table name and field name *** ### Q4: How to Execute Transaction Operations ```vb ' Start transaction m_DB.TransBegin ' Execute multiple operations m_DB.Sql("INSERT INTO table1 ...").Exec m_DB.Sql("INSERT INTO table2 ...").Exec ' Commit transaction (auto rollback on failure) If m_DB.TransCommit Then Debug.Print "Success" Else Debug.Print "Failed: " & m_DB.LastErr End If ``` *** ### Q5: How to Prevent SQL Injection ```vb ' Wrong: Direct SQL concatenation (unsafe) m_DB.Sql("SELECT * FROM users WHERE name = '" & txtName.Text & "'").Query ' Correct: Use parameterized query (safe) m_DB.Sql("SELECT * FROM users WHERE name = ?") _ .Param("name", txtName.Text, VBMAN.adVarWChar) _ .QueryParam ``` *** ### Q6: How to Get Last Inserted ID ```vb ' Insert data m_DB.Sql("INSERT INTO users (name) VALUES (?)") _ .Param("name", "John", VBMAN.adVarWChar) _ .ExecParam ' Get last inserted ID Dim lId As Variant lId = m_DB.LastInsertId Debug.Print "New user ID: " & lId ``` *** ## Next Steps * View [Connection Management](./connection.md) to learn about database connections * View [Query Operations](./query.md) to learn about query features * View [Parameterized Queries](./parameterized.md) to learn about secure queries * View [Advanced Features](./advanced.md) to learn about best practices *** **Last Updated**: 2026-01-21 --- --- url: /en/vbman/websocket/quickstart.md --- # Quick Start Guide This guide will help you quickly get started with the WebSocket library to create basic server and client applications. *** ## 📦 Prerequisites ### Required Files Ensure the following files are added to your project: | File | Location | Description | |------|----------|-------------| | `cWinsock.cls` | `add/` | Low-level Socket wrapper | | `cWebSocketClient.cls` | `newWebsocket/` | Client class | | `cWebSocketServer.cls` | `newWebsocket/` | Server class | | `cWebSocketFrame.cls` | `newWebsocket/` | Frame parsing class | | `cByteBuffer.cls` | `newWebsocket/` | Buffer class | | `cWebSocketServerClient.cls` | `newWebsocket/` | Server client class | | `mWebSocketUtils.bas` | `newWebsocket/` | Utility module | ### Adding to Project 1. Open VB6 project 2. Menu: Project → Add Class Module / Add Module 3. Browse to corresponding file and add *** ## 🚀 Client Quick Start ### Step 1: Create Form Create a new form and add the following controls: * 1 TextBox (`txtURL`) - For entering server address * 2 CommandButton (`cmdConnect`, `cmdDisconnect`) - Connect/Disconnect * 1 TextBox (`txtMessage`) - Input message * 1 CommandButton (`cmdSend`) - Send message * 1 TextBox (`txtLog`) - Display log (MultiLine = True) ### Step 2: Write Code ```vb Option Explicit Private WithEvents m_Client As cWebSocketClient Private Sub Form_Load() Set m_Client = New cWebSocketClient txtURL.Text = "ws://127.0.0.1:8080" txtMessage.Text = "Hello WebSocket!" UpdateUI False End Sub Private Sub cmdConnect_Click() On Error GoTo EH m_Client.Connect txtURL.Text LogMessage "Connecting to: " & txtURL.Text Exit Sub EH: LogMessage "Connection failed: " & Err.Description End Sub Private Sub cmdDisconnect_Click() If Not m_Client Is Nothing Then m_Client.CloseConnection LogMessage "Disconnected" End If UpdateUI False End Sub Private Sub cmdSend_Click() On Error GoTo EH If m_Client.State = WS_STATE_OPEN Then m_Client.SendText txtMessage.Text LogMessage "Sent: " & txtMessage.Text End If Exit Sub EH: LogMessage "Send failed: " & Err.Description End Sub ' ====== WebSocket Event Handling ====== Private Sub m_Client_OnOpen() LogMessage "Successfully connected to WebSocket server" UpdateUI True End Sub Private Sub m_Client_OnClose(ByVal Code As WsCloseCode, ByVal Reason As String) LogMessage "Connection closed: " & Reason & " (Status: " & Code & ")" UpdateUI False End Sub Private Sub m_Client_OnTextMessage(ByVal Message As String) LogMessage "Received message: " & Message End Sub Private Sub m_Client_OnError(ByVal Description As String) LogMessage "Error: " & Description End Sub ' ====== Helper Functions ====== Private Sub LogMessage(sMessage As String) txtLog.Text = txtLog.Text & Format$(Now, "hh:mm:ss") & " - " & sMessage & vbCrLf txtLog.SelStart = Len(txtLog.Text) End Sub Private Sub UpdateUI(bConnected As Boolean) cmdConnect.Enabled = Not bConnected cmdDisconnect.Enabled = bConnected cmdSend.Enabled = bConnected End Sub Private Sub Form_Unload(Cancel As Integer) If Not m_Client Is Nothing Then m_Client.CloseConnection End If End Sub ``` ### Step 3: Run Test 1. Press F5 to run the program 2. Enter server address (e.g., `ws://127.0.0.1:8080`) 3. Click "Connect" 4. After successful connection, enter message and click "Send" *** ## 🌐 Server Quick Start ### Step 1: Create Form Create a new form and add the following controls: * 1 TextBox (`txtPort`) - Port number * 2 CommandButton (`cmdStart`, `cmdStop`) - Start/Stop * 1 ListBox (`lstClients`) - Client list * 1 TextBox (`txtLog`) - Display log (MultiLine = True) ### Step 2: Write Code ```vb Option Explicit Private WithEvents m_Server As cWebSocketServer Private Sub Form_Load() Set m_Server = New cWebSocketServer txtPort.Text = "8080" End Sub Private Sub cmdStart_Click() On Error GoTo EH m_Server.Listen CLng(txtPort.Text) LogMessage "Server started, listening on port: " & txtPort.Text Exit Sub EH: LogMessage "Start failed: " & Err.Description End Sub Private Sub cmdStop_Click() If Not m_Server Is Nothing Then m_Server.StopServer LogMessage "Server stopped" End If lstClients.Clear End Sub ' ====== WebSocket Server Event Handling ====== Private Sub m_Server_OnStart(ByVal Port As Long) LogMessage "Service started, listening on port: " & Port End Sub Private Sub m_Server_OnStop() LogMessage "Service stopped" End Sub Private Sub m_Server_OnClientConnect(ByVal ClientID As String, ByVal RemoteAddress As String, ByVal RemotePort As Long) LogMessage "Client connected: " & ClientID & " (" & RemoteAddress & ":" & RemotePort & ")" lstClients.AddItem ClientID & " - " & RemoteAddress ' Send welcome message m_Server.SendText ClientID, "Welcome to WebSocket Server!" End Sub Private Sub m_Server_OnClientDisconnect(ByVal ClientID As String, ByVal Reason As String) LogMessage "Client disconnected: " & ClientID & " - " & Reason ' Remove from list Dim i As Long For i = 0 To lstClients.ListCount - 1 If InStr(lstClients.List(i), ClientID) > 0 Then lstClients.RemoveItem i Exit For End If Next End Sub Private Sub m_Server_OnClientTextMessage(ByVal ClientID As String, ByVal Message As String) LogMessage "Received message from " & ClientID & ": " & Message ' Echo message m_Server.SendText ClientID, "Server received: " & Message ' Broadcast to all other clients (chat mode) m_Server.BroadcastText ClientID & ": " & Message, ClientID End Sub Private Sub m_Server_OnClientBinaryMessage(ByVal ClientID As String, Data() As Byte) LogMessage "Received binary message from " & ClientID & ": " & (UBound(Data) + 1) & " bytes" End Sub Private Sub m_Server_OnError(ByVal Description As String) LogMessage "Error: " & Description End Sub ' ====== Helper Functions ====== Private Sub LogMessage(sMessage As String) txtLog.Text = txtLog.Text & Format$(Now, "hh:mm:ss") & " - " & sMessage & vbCrLf txtLog.SelStart = Len(txtLog.Text) End Sub Private Sub Form_Unload(Cancel As Integer) If Not m_Server Is Nothing Then m_Server.StopServer End If End Sub ``` ### Step 3: Run Test 1. Press F5 to run the server program 2. Click "Start Service" 3. Run the client program created above 4. Click "Connect" 5. Send messages to test *** ## 💬 Chat Room Example ### Server Code ```vb Option Explicit Private WithEvents m_Server As cWebSocketServer Private Sub Form_Load() Set m_Server = New cWebSocketServer m_Server.Listen 8080 End Sub Private Sub m_Server_OnClientConnect(ByVal ClientID As String, ByVal RemoteAddress As String, ByVal RemotePort As Long) Debug.Print ClientID & " joined chat room" ' Notify other users m_Server.BroadcastText "[System] " & ClientID & " joined chat room", ClientID ' Send welcome message m_Server.SendText ClientID, "Welcome to chat room! Current online: " & m_Server.ClientCount & " users" End Sub Private Sub m_Server_OnClientDisconnect(ByVal ClientID As String, ByVal Reason As String) Debug.Print ClientID & " left chat room" m_Server.BroadcastText "[System] " & ClientID & " left chat room" End Sub Private Sub m_Server_OnClientTextMessage(ByVal ClientID As String, ByVal Message As String) ' Broadcast to all users m_Server.BroadcastText ClientID & ": " & Message, ClientID Debug.Print ClientID & ": " & Message End Sub Private Sub Form_Unload(Cancel As Integer) m_Server.StopServer End Sub ``` ### Client Code ```vb Option Explicit Private WithEvents m_Client As cWebSocketClient Private m_sUsername As String Private Sub Form_Load() Set m_Client = New cWebSocketClient m_sUsername = "User" & CStr(Int(Rnd * 1000)) txtURL.Text = "ws://127.0.0.1:8080" End Sub Private Sub cmdConnect_Click() m_Client.Connect txtURL.Text End Sub Private Sub cmdSend_Click() If m_Client.State = WS_STATE_OPEN Then m_Client.SendText txtMessage.Text txtMessage.Text = "" End If End Sub Private Sub m_Client_OnOpen() Debug.Print "Connected to chat room" UpdateUI True End Sub Private Sub m_Client_OnTextMessage(ByVal Message As String) txtChat.Text = txtChat.Text & Message & vbCrLf txtChat.SelStart = Len(txtChat.Text) End Sub Private Sub UpdateUI(bConnected As Boolean) cmdConnect.Enabled = Not bConnected cmdSend.Enabled = bConnected End Sub Private Sub Form_Unload(Cancel As Integer) m_Client.CloseConnection End Sub ``` *** ## 🔍 Common Questions ### Q1: Compile error "User-defined type not defined" **Cause**: `mWebSocketUtils.bas` module not added. **Solution**: 1. Menu: Project → Add Module 2. Browse to `newWebsocket/mWebSocketUtils.bas` 3. Add to project *** ### Q2: Connection failed "Unable to resolve hostname" **Cause**: URL format error or network issue. **Solution**: * Check URL format: `ws://host:port` * Ensure server is started * Use `127.0.0.1` instead of `localhost` *** ### Q3: Handshake failed "Handshake failed" **Cause**: * Server not implementing WebSocket handshake * Port occupied by another program * Firewall blocking **Solution**: * Ensure using WebSocket library server * Change port * Check firewall settings *** ### Q4: Received garbled text **Cause**: Encoding issue. **Solution**: WebSocket library automatically handles UTF-8 encoding, no manual conversion needed. *** ### Q5: How to send binary data ```vb ' Send binary data Dim baData() As Byte baData = LoadFile("image.png") m_Client.SendBinary baData ' Receive binary data Private Sub m_Client_OnBinaryMessage(Data() As Byte) Debug.Print "Received " & (UBound(Data) + 1) & " bytes" SaveFile Data, "received.png" End Sub ``` *** ### Q6: How to implement auto-reconnect ```vb Private WithEvents m_Client As cWebSocketClient Private WithEvents tmrReconnect As Timer Private m_bAutoReconnect As Boolean Private m_sServerURL As String Private Sub Form_Load() Set m_Client = New cWebSocketClient Set tmrReconnect = New Timer tmrReconnect.Interval = 5000 ' Reconnect after 5 seconds m_bAutoReconnect = True m_sServerURL = "ws://127.0.0.1:8080" ConnectToServer End Sub Private Sub ConnectToServer() If m_Client.State = WS_STATE_CLOSED Then m_Client.Connect m_sServerURL End If End Sub Private Sub m_Client_OnClose(ByVal Code As WsCloseCode, ByVal Reason As String) Debug.Print "Connection closed: " & Reason If m_bAutoReconnect Then Debug.Print "Reconnecting in 5 seconds..." tmrReconnect.Enabled = True End If End Sub Private Sub tmrReconnect_Timer() tmrReconnect.Enabled = False ConnectToServer End Sub ``` *** ## 📚 Next Steps * See [client.md](./client.md) for detailed client API * See [server.md](./server.md) for detailed server API * See [advanced.md](./advanced.md) for advanced features *** **Last Updated**: 2026-01-10 --- --- url: /en/packages/vbccr/text/richtextbox.md description: >- RichTextBox Control - VBCCR Development Manual, complete API reference based on source code --- # RichTextBox Control Wraps the RichEdit system rich text editing control, providing formatted text editing, RTF file read/write, OLE object embedding, printing, find/replace, and automatic hyperlink detection. ## Enumerations ### RtfLoadSaveFormatConstants | Constant | Value | Description | |----------|-------|-------------| | RtfLoadSaveFormatRTF | 0 | RTF format | | RtfLoadSaveFormatText | 1 | Plain text format | | RtfLoadSaveFormatUnicodeText | 2 | Unicode plain text format | ### RtfFindOptionConstants | Constant | Value | Description | |----------|-------|-------------| | RtfFindOptionWholeWord | \&H2 | Match whole word | | RtfFindOptionMatchCase | \&H4 | Case-sensitive | | RtfFindOptionNoHighlight | \&H8 | Do not highlight matches | | RtfFindOptionReverse | \&H10 | Reverse search | ### RtfActionTypeConstants | Constant | Value | Description | |----------|-------|-------------| | RtfActionTypeUnknown | 0 | Unknown action | | RtfActionTypeTyping | 1 | Typing action | | RtfActionTypeDelete | 2 | Delete action | | RtfActionTypeDragDrop | 3 | Drag-and-drop action | | RtfActionTypeCut | 4 | Cut action | | RtfActionTypePaste | 5 | Paste action | | RtfActionTypeAutoTable | 6 | Auto-table action | ### RtfSelAlignmentConstants | Constant | Value | Description | |----------|-------|-------------| | RtfSelAlignmentLeft | 0 | Left-aligned | | RtfSelAlignmentRight | 1 | Right-aligned | | RtfSelAlignmentCenter | 2 | Center-aligned | | RtfSelAlignmentJustified | 3 | Justified | ### RtfSelTypeConstants | Constant | Value | Description | |----------|-------|-------------| | RtfSelTypeEmpty | 0 | Empty selection | | RtfSelTypeText | 1 | Text | | RtfSelTypeObject | 2 | OLE object | | RtfSelTypeMultiChar | 4 | Multiple characters | | RtfSelTypeMultiObject | 8 | Multiple OLE objects | ### RtfTextModeConstants | Constant | Value | Description | |----------|-------|-------------| | RtfTextModeRichText | 0 | Rich text mode | | RtfTextModePlainText | 1 | Plain text mode | ### CCMousePointerConstants See common enumerations. ### OLEDropModeConstants See common enumerations. ### CCRightToLeftModeConstants See common enumerations. ### CCIMEModeConstants See common enumerations. ## Properties ### Text ```vb Property Get Text() As String Property Let Text(ByVal Value As String) ``` The plain text content contained in the control. Default property. ### TextLength ```vb Property Get TextLength() As Long ``` The text length (number of characters). Read-only. ### TextRTF ```vb Property Get TextRTF() As String Property Let TextRTF(ByVal Value As String) ``` The RTF text content containing all RTF codes. ### SelText ```vb Property Get SelText() As String Property Let SelText(ByVal Value As String) ``` The text content of the current selection. ### SelRTF ```vb Property Get SelRTF() As String Property Let SelRTF(ByVal Value As String) ``` The RTF text of the current selection (containing all RTF codes). ### SelStart ```vb Property Get SelStart() As Long Property Let SelStart(ByVal Value As Long) ``` The starting position of the selection; the insertion point when there is no selection. ### SelLength ```vb Property Get SelLength() As Long Property Let SelLength(ByVal Value As Long) ``` The number of characters in the selection. ### SelAlignment ```vb Property Get SelAlignment() As Variant Property Let SelAlignment(ByVal Value As Variant) ``` The paragraph alignment, one of the RtfSelAlignmentConstants values. ### SelBold ```vb Property Get SelBold() As Variant Property Let SelBold(ByVal Value As Variant) ``` The bold formatting of the current selection. ### SelItalic ```vb Property Get SelItalic() As Variant Property Let SelItalic(ByVal Value As Variant) ``` The italic formatting of the current selection. ### SelStrikethru ```vb Property Get SelStrikethru() As Variant Property Let SelStrikethru(ByVal Value As Variant) ``` The strikethrough formatting of the current selection. ### SelUnderline ```vb Property Get SelUnderline() As Variant Property Let SelUnderline(ByVal Value As Variant) ``` The underline formatting of the current selection. ### SelBullet ```vb Property Get SelBullet() As Variant Property Let SelBullet(ByVal Value As Variant) ``` Whether the paragraph at the current selection or insertion point has a bullet style. ### SelCharOffset ```vb Property Get SelCharOffset() As Variant Property Let SelCharOffset(ByVal Value As Variant) ``` The character offset, determining whether text is displayed on the baseline (normal), above the baseline (superscript), or below the baseline (subscript). ### SelColor ```vb Property Get SelColor() As Variant Property Let SelColor(ByVal Value As Variant) ``` The text color of the current selection. ### SelBkColor ```vb Property Get SelBkColor() As Variant Property Let SelBkColor(ByVal Value As Variant) ``` The text background color of the current selection. ### SelFontName ```vb Property Get SelFontName() As Variant Property Let SelFontName(ByVal Value As Variant) ``` The font name of the current selection. ### SelFontSize ```vb Property Get SelFontSize() As Variant Property Let SelFontSize(ByVal Value As Variant) ``` The font size of the current selection (in points). ### SelFontCharset ```vb Property Get SelFontCharset() As Variant Property Let SelFontCharset(ByVal Value As Variant) ``` The font character set of the current selection. ### SelProtected ```vb Property Get SelProtected() As Variant Property Let SelProtected(ByVal Value As Variant) ``` Whether the text in the current selection is protected (non-editable). ### SelIndent ```vb Property Get SelIndent() As Variant Property Let SelIndent(ByVal Value As Variant) ``` The left indent distance. ### SelRightIndent ```vb Property Get SelRightIndent() As Variant Property Let SelRightIndent(ByVal Value As Variant) ``` The right indent distance. ### SelHangingIndent ```vb Property Get SelHangingIndent() As Variant Property Let SelHangingIndent(ByVal Value As Variant) ``` The first-line indent distance (relative to the left indent). ### SelVisible ```vb Property Get SelVisible() As Variant Property Let SelVisible(ByVal Value As Variant) ``` Whether the text in the current selection is visible. ### SelLink ```vb Property Get SelLink() As Variant Property Let SelLink(ByVal Value As Variant) ``` Whether the text in the current selection is marked as a hyperlink. ### SelTabCount ```vb Property Get SelTabCount() As Variant Property Let SelTabCount(ByVal Value As Variant) ``` The number of tab stops in the current selection. ### SelTabs ```vb Property Get SelTabs(ByVal Element As Integer) As Variant Property Let SelTabs(ByVal Element As Integer, ByVal Value As Variant) ``` The absolute tab stop positions of the current selection. ### Modified ```vb Property Get Modified() As Boolean Property Let Modified(ByVal Value As Boolean) ``` Whether the control content has been modified. Setting the Text property resets this to False; any input operation sets it to True. ### UndoType ```vb Property Get UndoType() As RtfActionTypeConstants ``` The type of the next undo operation. Read-only. ### RedoType ```vb Property Get RedoType() As RtfActionTypeConstants ``` The type of the next redo operation. Read-only. ### LeftMargin ```vb Property Get LeftMargin() As Single Property Let LeftMargin(ByVal Value As Single) ``` The left margin width. ### RightMargin ```vb Property Get RightMargin() As Single Property Let RightMargin(ByVal Value As Single) ``` The right margin width. ### ZoomFactor ```vb Property Get ZoomFactor() As Double Property Let ZoomFactor(ByVal Value As Double) ``` The current zoom factor. ### VisualStyles ```vb Property Get VisualStyles() As Boolean Property Let VisualStyles(ByVal Value As Boolean) ``` Whether visual styles are enabled. Requires comctl32.dll version 6.0 or later. ### Enabled ```vb Property Get Enabled() As Boolean Property Let Enabled(ByVal Value As Boolean) ``` Whether the control is enabled. ### AllowDropFiles ```vb Property Get AllowDropFiles() As Boolean Property Let AllowDropFiles(ByVal Value As Boolean) ``` Whether drag-and-drop files are allowed. Only applicable when there is no OLE drop target. ### OLEDragDropRTF ```vb Property Get OLEDragDropRTF() As Boolean Property Let OLEDragDropRTF(ByVal Value As Boolean) ``` Whether the RichTextBox control can act as an OLE drag source and drop target. ### OLEDragMode ```vb Property Get OLEDragMode() As VBRUN.OLEDragConstants Property Let OLEDragMode(ByVal Value As VBRUN.OLEDragConstants) ``` The OLE drag mode. Must be Manual when OLEDragDropRTF is True. ### OLEDragDropScroll ```vb Property Get OLEDragDropScroll() As Boolean Property Let OLEDragDropScroll(ByVal Value As Boolean) ``` Whether scrolling is allowed during OLE drag-and-drop operations. Must be True when OLEDragDropRTF is True. ### OLEDropMode ```vb Property Get OLEDropMode() As OLEDropModeConstants Property Let OLEDropMode(ByVal Value As OLEDropModeConstants) ``` The OLE drop target mode. Must be None when OLEDragDropRTF is True. See common enumerations. ### MousePointer ```vb Property Get MousePointer() As CCMousePointerConstants Property Let MousePointer(ByVal Value As CCMousePointerConstants) ``` The mouse pointer style. See common enumerations. ### MouseIcon ```vb Property Get MouseIcon() As IPictureDisp Property Let MouseIcon(ByVal Value As IPictureDisp) Property Set MouseIcon(ByVal Value As IPictureDisp) ``` The custom mouse icon. ### MouseTrack ```vb Property Get MouseTrack() As Boolean Property Let MouseTrack(ByVal Value As Boolean) ``` Whether mouse enter/leave tracking is enabled. ### RightToLeft ```vb Property Get RightToLeft() As Boolean Property Let RightToLeft(ByVal Value As Boolean) ``` The right-to-left display direction. ### RightToLeftMode ```vb Property Get RightToLeftMode() As CCRightToLeftModeConstants Property Let RightToLeftMode(ByVal Value As CCRightToLeftModeConstants) ``` The right-to-left mode. See common enumerations. ### BorderStyle ```vb Property Get BorderStyle() As Integer Property Let BorderStyle(ByVal Value As Integer) ``` The border style (vbBSNone or vbFixedSingle). ### BackColor ```vb Property Get BackColor() As OLE_COLOR Property Let BackColor(ByVal Value As OLE_COLOR) ``` The background color. Only applicable when Enabled is True. ### Locked ```vb Property Get Locked() As Boolean Property Let Locked(ByVal Value As Boolean) ``` Whether the content is locked as read-only. ### HideSelection ```vb Property Get HideSelection() As Boolean Property Let HideSelection(ByVal Value As Boolean) ``` Whether the selection is hidden when the control loses focus. ### PasswordChar ```vb Property Get PasswordChar() As String Property Let PasswordChar(ByVal Value As String) ``` The password character used to display in place of actual characters. This property is ignored when UseSystemPasswordChar is True. ### UseSystemPasswordChar ```vb Property Get UseSystemPasswordChar() As Boolean Property Let UseSystemPasswordChar(ByVal Value As Boolean) ``` Whether to use the default system password character. This property takes precedence over PasswordChar. ### MultiLine ```vb Property Get MultiLine() As Boolean Property Let MultiLine(ByVal Value As Boolean) ``` Whether multi-line text is allowed. Read-only at runtime. ### MaxLength ```vb Property Get MaxLength() As Long Property Let MaxLength(ByVal Value As Long) ``` The maximum number of characters that can be entered. ### ScrollBars ```vb Property Get ScrollBars() As VBRUN.ScrollBarConstants Property Let ScrollBars(ByVal Value As VBRUN.ScrollBarConstants) ``` The scroll bar style. ### WantReturn ```vb Property Get WantReturn() As Boolean Property Let WantReturn(ByVal Value As Boolean) ``` Whether pressing Enter activates the default button or inserts a line break. Only applicable for multi-line RichTextBox with a default button. ### DisableNoScroll ```vb Property Get DisableNoScroll() As Boolean Property Let DisableNoScroll(ByVal Value As Boolean) ``` Whether scroll bars are disabled rather than hidden when not needed. Read-only at runtime. ### AutoURLDetect ```vb Property Get AutoURLDetect() As Boolean Property Let AutoURLDetect(ByVal Value As Boolean) ``` Whether automatic hyperlink detection is enabled. ### BulletIndent ```vb Property Get BulletIndent() As Single Property Let BulletIndent(ByVal Value As Single) ``` The indent amount when paragraphs use bullet style. ### SelectionBar ```vb Property Get SelectionBar() As Boolean Property Let SelectionBar(ByVal Value As Boolean) ``` Whether to add a selection bar in the left margin, where the cursor becomes a right-up arrow, allowing the user to select entire lines. ### FileName ```vb Property Get FileName() As String Property Let FileName(ByVal Value As String) ``` The file name to load into the control at design time. ### TextMode ```vb Property Get TextMode() As RtfTextModeConstants Property Let TextMode(ByVal Value As RtfTextModeConstants) ``` The text mode (rich text or plain text). ### UndoLimit ```vb Property Get UndoLimit() As Long Property Let UndoLimit(ByVal Value As Long) ``` The maximum number of actions that can be stored in the undo queue. 0 disables undo functionality. ### IMEMode ```vb Property Get IMEMode() As CCIMEModeConstants Property Let IMEMode(ByVal Value As CCIMEModeConstants) ``` The Input Method Editor (IME) mode. See common enumerations. ### AllowOverType ```vb Property Get AllowOverType() As Boolean Property Let AllowOverType(ByVal Value As Boolean) ``` Whether overtype mode can be activated. ### OverTypeMode ```vb Property Get OverTypeMode() As Boolean Property Let OverTypeMode(ByVal Value As Boolean) ``` Whether overtype mode is active. In overtype mode, typed characters replace existing characters one by one. ### UseCrLf ```vb Property Get UseCrLf() As Boolean Property Let UseCrLf(ByVal Value As Boolean) ``` Whether the control translates each Cr to CrLf for the Text property. ### AutoVerbMenu ```vb Property Get AutoVerbMenu() As Boolean Property Let AutoVerbMenu(ByVal Value As Boolean) ``` Whether to display the verb pop-up menu when right-clicking a selected OLE object. ### Font ```vb Property Get Font() As StdFont Property Let Font(ByVal NewFont As StdFont) Property Set Font(ByVal NewFont As StdFont) ``` The font. ### hWnd ```vb Property Get hWnd() As LongPtr ``` The window handle of the RichTextBox control. ### hWndUserControl ```vb Property Get hWndUserControl() As LongPtr ``` The window handle of the UserControl. ### Name ```vb Property Get Name() As String ``` The control name. Read-only. ### Tag ```vb Property Get Tag() As String Property Let Tag(ByVal Value As String) ``` Custom data. ### Parent ```vb Property Get Parent() As Object ``` The parent object. Read-only. ### Container ```vb Property Get Container() As Object Property Set Container(ByVal Value As Object) ``` The container object. ### Left ```vb Property Get Left() As Single Property Let Left(ByVal Value As Single) ``` The left margin. ### Top ```vb Property Get Top() As Single Property Let Top(ByVal Value As Single) ``` The top margin. ### Width ```vb Property Get Width() As Single Property Let Width(ByVal Value As Single) ``` The width. ### Height ```vb Property Get Height() As Single Property Let Height(ByVal Value As Single) ``` The height. ### Visible ```vb Property Get Visible() As Boolean Property Let Visible(ByVal Value As Boolean) ``` Whether the control is visible. ### ToolTipText ```vb Property Get ToolTipText() As String Property Let ToolTipText(ByVal Value As String) ``` The tooltip text. ### HelpContextID ```vb Property Get HelpContextID() As Long Property Let HelpContextID(ByVal Value As Long) ``` The help context ID. ### WhatsThisHelpID ```vb Property Get WhatsThisHelpID() As Long Property Let WhatsThisHelpID(ByVal Value As Long) ``` The "What's This" help ID. ### DragIcon ```vb Property Get DragIcon() As IPictureDisp Property Let DragIcon(ByVal Value As IPictureDisp) Property Set DragIcon(ByVal Value As IPictureDisp) ``` The drag icon. ### DragMode ```vb Property Get DragMode() As Integer Property Let DragMode(ByVal Value As Integer) ``` The drag mode. ## Methods ### Copy ```vb Public Sub Copy() ``` Copies the current selection to the clipboard. ### Cut ```vb Public Sub Cut() ``` Deletes the current selection and copies the text to the clipboard. ### Paste ```vb Public Sub Paste() ``` Pastes the clipboard contents at the current insertion point. ### CanPaste ```vb Public Function CanPaste(Optional ByVal wFormat As Long) As Boolean ``` Determines whether the clipboard contains content that can be pasted in the specified format. ### PasteSpecial ```vb Public Sub PasteSpecial(ByVal wFormat As Long) ``` Pastes content into the RichTextBox in the specified clipboard format. ### PasteSpecialDlg ```vb Public Sub PasteSpecialDlg() ``` Displays the "Paste Special" dialog. ### Clear ```vb Public Sub Clear() ``` Clears the current selection. ### Undo ```vb Public Sub Undo() ``` Undoes the last operation, if any. ### CanUndo ```vb Public Function CanUndo() As Boolean ``` Determines whether there are actions in the undo queue that can be undone. ### StopUndoAction ```vb Public Sub StopUndoAction() ``` Stops the control from collecting subsequent typing actions into the current undo action. ### ResetUndoQueue ```vb Public Sub ResetUndoQueue() ``` Resets the undo queue. ### Redo ```vb Public Sub Redo() ``` Redoes the next operation, if any. ### CanRedo ```vb Public Function CanRedo() As Boolean ``` Determines whether there are actions in the redo queue that can be redone. ### GetTextRange ```vb Public Function GetTextRange(ByVal Min As Long, ByVal Max As Long) As String ``` Gets the text within the specified range. ### Find ```vb Public Function Find(ByVal Text As String, Optional ByVal Min As Long, Optional ByVal Max As Long = -1, Optional ByVal Options As RtfFindOptionConstants) As Long ``` Searches for text in the RichTextBox, returning the character position found, or -1 if not found. ### Span ```vb Public Sub Span(ByVal CharacterSet As String, Optional ByVal Forward As Boolean, Optional ByVal Negate As Boolean) ``` Selects text based on the specified character set. ### UpTo ```vb Public Sub UpTo(ByVal CharacterSet As String, Optional ByVal Forward As Boolean, Optional ByVal Negate As Boolean) ``` Moves the insertion point to but not including the first character in the specified character set. ### SaveFile ```vb Public Sub SaveFile(ByVal FileName As String, Optional ByVal Format As RtfLoadSaveFormatConstants = RtfLoadSaveFormatRTF, Optional ByVal SelectionOnly As Boolean) ``` Saves the control contents to a file. ### LoadFile ```vb Public Sub LoadFile(ByVal FileName As String, Optional ByVal Format As RtfLoadSaveFormatConstants = RtfLoadSaveFormatRTF, Optional ByVal SelectionOnly As Boolean) ``` Loads an RTF or text file into the control. ### GetLine ```vb Public Function GetLine(ByVal LineNumber As Long) As String ``` Gets the text of the specified line. 0 indicates the current line (the line containing the insertion point). ### GetLineCount ```vb Public Function GetLineCount() As Long ``` Gets the number of lines. ### ScrollToLine ```vb Public Sub ScrollToLine(ByVal LineNumber As Long) ``` Scrolls to ensure the specified line is visible. ### ScrollToCaret ```vb Public Sub ScrollToCaret() ``` Scrolls the insertion point into the visible area. ### CharFromPos ```vb Public Function CharFromPos(ByVal X As Single, ByVal Y As Single) As Long ``` Returns the character index closest to the specified point. ### GetLineFromChar ```vb Public Function GetLineFromChar(ByVal CharIndex As Long) As Long ``` Gets the line number containing the specified character index. A character index of -1 returns the current line. ### GetSelType ```vb Public Function GetSelType() As Integer ``` Determines the current selection type, returning a combination of RtfSelTypeConstants flags. ### SelPrint ```vb Public Sub SelPrint(ByVal hDC As LongPtr, Optional ByVal CallStartEndDoc As Boolean = True, Optional ByVal DocName As String = "RICHTEXT", Optional ByVal LeftMargin As Long, Optional ByVal TopMargin As Long, Optional ByVal RightMargin As Long, Optional ByVal BottomMargin As Long) ``` Sends the formatted text in the RichTextBox to a device for printing. If there is no selection, all content is printed. ### PrintDoc ```vb Public Sub PrintDoc(ByVal hDC As LongPtr, Optional ByVal CallStartEndDoc As Boolean = True, Optional ByVal DocName As String = "RICHTEXT", Optional ByVal LeftMargin As Long, Optional ByVal TopMargin As Long, Optional ByVal RightMargin As Long, Optional ByVal BottomMargin As Long) ``` Sends all formatted text in the RichTextBox to a device for printing. ### GetOLEInterface ```vb Public Function GetOLEInterface() As IUnknown ``` Retrieves the IRichEditOle object for accessing COM functionality. ### OLEObjectsAdd ```vb Public Sub OLEObjectsAdd(ByVal LpOleObject As LongPtr) ``` Inserts an OLE object into the RichTextBox. ### OLEObjectsAddFromFile ```vb Public Sub OLEObjectsAddFromFile(ByVal FileName As String, Optional ByVal LinkToFile As Boolean) ``` Inserts an OLE object from a file into the RichTextBox. ### OLEObjectsAddFromPicture ```vb Public Sub OLEObjectsAddFromPicture(ByVal Picture As IPictureDisp, Optional ByVal ClipFormat As Variant) ``` Inserts an OLE object from a picture object into the RichTextBox. ### OLEObjectsGet ```vb Public Function OLEObjectsGet(ByVal IndexObj As Long, Optional ByVal CharPos As Long) As LongPtr ``` Retrieves an OLE object from the RichTextBox. ### OLEObjectsCount ```vb Public Function OLEObjectsCount() As Long ``` Returns the number of OLE objects currently contained in the RichTextBox. ### Drag ```vb Public Sub Drag([ByRef Action As Variant]) ``` Starts, ends, or cancels a drag operation. ### SetFocus ```vb Public Sub SetFocus() ``` Moves the focus to the control. ### ZOrder ```vb Public Sub ZOrder([ByRef Position As Variant]) ``` Sets the Z-order of the control. ### OLEDrag ```vb Public Sub OLEDrag() ``` Initiates an OLE drag-and-drop operation. ### Refresh ```vb Public Sub Refresh() ``` Forces the control to repaint. ## Events ### Change ```vb Public Event Change() ``` Occurs when the control content changes. ### MaxText ```vb Public Event MaxText() ``` Occurs when the current text insertion exceeds the maximum character limit. ### SelChange ```vb Public Event SelChange(ByVal SelType As Integer, ByVal SelStart As Long, ByVal SelEnd As Long) ``` Occurs when the current text selection changes or the insertion point moves. ### LinkEvent ```vb Public Event LinkEvent(ByVal wMsg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr, ByVal LinkStart As Long, ByVal LinkEnd As Long) ``` Occurs when the mouse clicks or hovers over text with hyperlink formatting. ### DropFiles ```vb Public Event DropFiles(ByRef FileList As Variant, ByVal X As Single, ByVal Y As Single, ByVal CharPos As Long, ByVal Protected As Boolean, ByRef Cancel As Boolean) ``` Occurs when the user drags and drops files onto the control. Only applicable when there is no OLE drop target and AllowDropFiles is True. ### ModifyProtected ```vb Public Event ModifyProtected(ByRef Allow As Boolean, ByVal SelStart As Long, ByVal SelEnd As Long) ``` Occurs when the user attempts to edit protected text. ### Scroll ```vb Public Event Scroll() ``` Occurs when scroll bars are repositioned. ### ContextMenu ```vb Public Event ContextMenu(ByRef Handled As Boolean, ByVal X As Single, ByVal Y As Single) ``` Occurs when the user right-clicks or presses Shift+F10. Set Handled to True to cancel the default menu. ### PreviewKeyDown ```vb Public Event PreviewKeyDown(ByVal KeyCode As Integer, ByRef IsInputKey As Boolean) ``` Occurs before the KeyDown event. ### PreviewKeyUp ```vb Public Event PreviewKeyUp(ByVal KeyCode As Integer, ByRef IsInputKey As Boolean) ``` Occurs before the KeyUp event. ### MouseEnter ```vb Public Event MouseEnter() ``` Occurs when the mouse enters the control. ### MouseLeave ```vb Public Event MouseLeave() ``` Occurs when the mouse leaves the control. ### OLEDragDropDone ```vb Public Event OLEDragDropDone() ``` Occurs after the RichTextBox control completes or cancels an OLE drag-and-drop operation. ### OLEGetDropEffect ```vb Public Event OLEGetDropEffect(ByRef Effect As Long, ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) ``` Raised by the control during an OLE drag-and-drop operation to specify the resulting effect of the drop operation. ### OLEGetDragEffect ```vb Public Event OLEGetDragEffect(ByRef AllowedEffects As Long) ``` Occurs when the control initiates an OLE drag-and-drop operation. ### OLEGetContextMenu ```vb Public Event OLEGetContextMenu(ByVal SelType As Integer, ByVal LpOleObject As LongPtr, ByVal SelStart As Long, ByVal SelEnd As Long, ByRef hMenu As LongPtr) ``` Raised to request a pop-up menu for the control's right-click. The control destroys this menu after use. ### OLEContextMenuClick ```vb Public Event OLEContextMenuClick(ByVal ID As Long) ``` Occurs when the user selects an item from the pop-up menu provided by the OLEGetContextMenu event. ### OLEDeleteObject ```vb Public Event OLEDeleteObject(ByVal LpOleObject As LongPtr) ``` Occurs when an OLE object is about to be deleted in the control. The OLE object is not necessarily released. ### Click ```vb Public Event Click() ``` Occurs when a mouse button is pressed and released on the control. ### DblClick ```vb Public Event DblClick() ``` Occurs when the mouse is double-clicked on the control. ### KeyDown ```vb Public Event KeyDown(KeyCode As Integer, Shift As Integer) ``` Occurs when a key is pressed. ### KeyUp ```vb Public Event KeyUp(KeyCode As Integer, Shift As Integer) ``` Occurs when a key is released. ### KeyPress ```vb Public Event KeyPress(KeyChar As Integer) ``` Occurs when a key character is input. ### MouseDown ```vb Public Event MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` Occurs when a mouse button is pressed. ### MouseMove ```vb Public Event MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` Occurs when the mouse is moved. ### MouseUp ```vb Public Event MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` Occurs when a mouse button is released. ### OLECompleteDrag ```vb Public Event OLECompleteDrag(Effect As Long) ``` Occurs after an OLE drag-and-drop operation has been completed or canceled. ### OLEDragDrop ```vb Public Event OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single) ``` Occurs when data is dropped onto the control via an OLE drag-and-drop operation. ### OLEDragOver ```vb Public Event OLEDragOver(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single, State As Integer) ``` Occurs when the mouse moves over the control during an OLE drag-and-drop operation. ### OLEGiveFeedback ```vb Public Event OLEGiveFeedback(Effect As Long, DefaultCursors As Boolean) ``` Occurs when the mouse cursor needs to be changed during an OLE drag-and-drop operation. ### OLESetData ```vb Public Event OLESetData(Data As DataObject, DataFormat As Integer) ``` Occurs when the drop target requests data that was not provided during OLEDragStart. ### OLEStartDrag ```vb Public Event OLEStartDrag(Data As DataObject, AllowedEffects As Long) ``` Occurs when an OLE drag-and-drop operation is initiated. ## Code Examples ```vb ' Load an RTF file RichTextBox1.LoadFile "C:\doc.rtf", RtfLoadSaveFormatRTF ' Set selection formatting RichTextBox1.SelStart = 0 RichTextBox1.SelLength = 10 RichTextBox1.SelBold = True RichTextBox1.SelColor = vbRed RichTextBox1.SelFontSize = 14 ' Find text Dim pos As Long pos = RichTextBox1.Find("keyword", 0, -1, RtfFindOptionMatchCase) ' Undo/Redo If RichTextBox1.CanUndo Then RichTextBox1.Undo If RichTextBox1.CanRedo Then RichTextBox1.Redo ' Print RichTextBox1.SelPrint Printer.hDC ' Insert OLE object RichTextBox1.OLEObjectsAddFromPicture LoadPicture("C:\image.bmp") ' Save as plain text RichTextBox1.SaveFile "C:\output.txt", RtfLoadSaveFormatText ``` --- --- url: /en/vbman/httpserver/router.md --- # Router System Guide ## Overview `cHttpServerRouter` is the core component of HttpServer, responsible for mapping HTTP requests to corresponding handlers. Supports **manual routing** and **auto routing** modes, along with HTTP method restrictions, parameter routing, route groups, and other advanced features. ## Router Execution Flow ``` ┌─────────────────────────────────────────────────────────────┐ │ Request Arrives │ └─────────────────────────────────────────────────────────────┘ │ ▼ ┌─────────────────────────────────────────────────────────────┐ │ 1. Static File Check │ │ └─> If matches file in WebRoot, return static file │ └─────────────────────────────────────────────────────────────┘ │ ▼ ┌─────────────────────────────────────────────────────────────┐ │ 2. Execute Pre-Middleware (RouteBefore) │ │ └─> Can intercept requests, verify permissions, etc. │ └─────────────────────────────────────────────────────────────┘ │ ▼ ┌─────────────────────────────────────────────────────────────┐ │ 3. Route Matching │ │ ├─> a) Exact match manual routes (O(1) dictionary lookup) │ │ ├─> b) Parameter route pattern matching ({param} wildcard) │ │ ├─> c) Check auto routes (if enabled) │ │ └─> d) 404 Not Found │ └─────────────────────────────────────────────────────────────┘ │ ▼ ┌─────────────────────────────────────────────────────────────┐ │ 4. Execute Controller Method │ │ └─> Call matched Controller@Action │ └─────────────────────────────────────────────────────────────┘ │ ▼ ┌─────────────────────────────────────────────────────────────┐ │ 5. Execute Post-Processing (RouteAfter) │ │ └─> Can add response headers, log responses, etc. │ └─────────────────────────────────────────────────────────────┘ ``` ## Manual Routing ### Basic Routes ```vb ' Register controllers Call Server.Router.Reg("User", New cUserController) Call Server.Router.Reg("Api", New cApiController) ' Add routes Call Server.Router.Add("/", "User@Index") ' Accessible by GET/POST Call Server.Router.Add("/list", "User@List", OnlyGet) ' GET only Call Server.Router.Add("/create", "User@Create", OnlyPost) ' POST only ``` ### HTTP Method Restriction ```vb ' Any method (default) Call Server.Router.Add("/any", "Home@Any", Any_) ' GET only Call Server.Router.Add("/get", "Home@Get", OnlyGet) ' POST only Call Server.Router.Add("/post", "Home@Post", OnlyPost) ' PUT only Call Server.Router.Add("/put", "Home@Put", OnlyPut) ' DELETE only Call Server.Router.Add("/delete", "Home@Delete", OnlyDelete) ``` ### RESTful API Route Examples ```vb ' User resource RESTful API Call Server.Router.Reg("User", New cUserController) ' GET /users -> List Call Server.Router.Add("/users", "User@Index", OnlyGet) ' GET /users/detail?id=123 -> Detail (query parameter approach) Call Server.Router.Add("/users/detail", "User@Detail", OnlyGet) ' POST /users -> Create Call Server.Router.Add("/users", "User@Create", OnlyPost) ' PUT /users/update?id=123 -> Update (query parameter approach) Call Server.Router.Add("/users/update", "User@Update", OnlyPut) ' DELETE /users/delete?id=123 -> Delete (query parameter approach) Call Server.Router.Add("/users/delete", "User@Delete", OnlyDelete) ``` > **More elegant approach**: Use parameter routing `{param}` to pass parameters directly in the path. See [Parameter Routing & Path Segment Parsing](./route-params.md) ### Controller Writing Standards ```vb ' cUserController.cls Option Explicit ' GET /users Public Sub Index(ctx As cHttpServerContext) Dim users As New Dictionary users("items") = Array("John", "Jane") users("total") = 2 ctx.Response.Json users, 0, "Success" End Sub ' GET /users/detail?id=123 Public Sub Detail(ctx As cHttpServerContext) Dim id As String id = ctx.Request.QueryString("id") Dim user As New Dictionary user("id") = id user("name") = "John" ctx.Response.Json user End Sub ' POST /users Public Sub Create(ctx As cHttpServerContext) ' Get form data Dim name As String, email As String name = ctx.Request.Form("name") email = ctx.Request.Form("email") ' Or get JSON data ' name = ctx.Request.Json.GetItem("name") ' Business logic... ctx.Response.Json Nothing, 0, "Created successfully" End Sub ' PUT /users/update Public Sub Update(ctx As cHttpServerContext) Dim id As String id = ctx.Request("id") ' Auto-get from Query/Form/Json ctx.Response.Json Nothing, 0, "Updated successfully" End Sub ' DELETE /users/delete Public Sub Delete(ctx As cHttpServerContext) Dim id As String id = ctx.Request.QueryString("id") ctx.Response.Json Nothing, 0, "Deleted successfully" End Sub ``` > **Parameter route controller example**: Use `RouteParams` to get path parameters. See [Parameter Routing & Path Segment Parsing](./route-params.md) ## Parameter Routing Supports using `{param}` syntax in URL paths to define dynamic parameter segments. After matching, parameter values are accessed via `ctx.Request.RouteParams`. Supports single parameter, multi-parameter, nested resources, and more scenarios. 👉 **Full documentation**: [Parameter Routing & Path Segment Parsing](./route-params.md) ## Auto Routing When auto routing is enabled, the framework automatically parses controller and method based on URL path. ```vb ' Enable auto routing Server.Router.AutoRoute = True ``` ### URL Parsing Rules ``` Format: /ControllerName/ActionName?param1=value1¶m2=value2 Examples: /User/List -> List method of User controller /User/Detail?id=1 -> Detail method of User controller /Home/Index -> Index method of Home controller ``` ### Auto Routing Usage Example ```vb ' Only need to register controllers, no manual routes required Call Server.Router.Reg("User", New cUserController) Call Server.Router.Reg("Product", New cProductController) ' Enable auto routing Server.Router.AutoRoute = True ' The following URLs will route automatically: ' GET /User/List -> Call cUserController.List ' GET /User/Detail -> Call cUserController.Detail ' POST /Product/Add -> Call cProductController.Add ``` ### Manual vs Auto Routing | Feature | Manual Routing | Auto Routing | | ----------------- | --------------------------------- | ----------------------------------- | | Performance | Faster (direct dictionary lookup) | Slightly slower (needs URL parsing) | | Flexibility | Can customize URL paths | Follows fixed format | | Security | Only exposes registered routes | Exposes all public methods | | Parameter Routing | ✅ Supports `{param}` | ❌ Not supported | | Use Case | API services, production | Rapid development, admin panels | ## Route and Middleware Integration ```vb ' Pre-middleware: Login verification Public Sub AuthMiddleware(ctx As cHttpServerContext) ' Exclude login endpoint If ctx.Request.PathInfo = "/login" Then Exit Sub ' Check session If ctx.Session("user_id") = "" Then ctx.Response.State401 "Please login first" ctx.fIsAbort = True ' Terminate subsequent processing End If End Sub ' Register middleware Call Server.RouteBefore.Add("auth", New cAuthMiddleware) ' Route registration (will be intercepted by auth) Call Server.Router.Add("/api/data", "Api@Data", OnlyGet) ``` ## Route Performance Optimization Tips 1. **Use manual routing in production**: Better performance, higher security 2. **Static files first**: Files in WebRoot are returned first, not entering routing 3. **Use HTTP method restrictions wisely**: Can match route dictionaries faster 4. **Controller caching**: Controller objects are registered once and reused 5. **Exact routes first**: Exact routes use O(1) dictionary lookup; parameter routes require traversal matching. Use exact routes for high-frequency paths 6. **Parameter route segment grouping** (planned): Group parameter routes by segment count for indexing to reduce traversal scope *** **Last Updated**: 2026-06-11 --- --- url: /demo/api-examples.md --- # Runtime API Examples This page demonstrates usage of some of the runtime APIs provided by VitePress. The main `useData()` API can be used to access site, theme, and page data for the current page. It works in both `.md` and `.vue` files: ```md ## Results ### Theme Data 
    {{ theme }}
    ### Page Data 
    {{ page }}
    ### Page Frontmatter 
    {{ frontmatter }}
    ``` ## Results ### Theme Data ### Page Data ### Page Frontmatter ## More Check out the documentation for the [full list of runtime APIs](https://vitepress.dev/reference/runtime-api#usedata). --- --- url: /en/vbman/httpserver/security.md --- # Security Best Practices Guide ## Overview This document introduces security best practices in HttpServer development, including input validation, SQL injection prevention, XSS protection, CSRF protection, etc. ## Input Validation ### Parameter Validation Middleware ```vb ' cValidationMiddleware.cls Option Explicit Public Sub Entry(ctx As cHttpServerContext) Dim rules As Dictionary Set rules = GetValidationRules(ctx.Request.PathInfo) If Not rules Is Nothing Then Dim field As Variant Dim errors As String errors = "" For Each field In rules.Keys Dim value As String value = ctx.Request(field) ' Required check If rules(field)("required") And value = "" Then errors = errors & field & " cannot be empty; " End If ' Type check If rules(field)("type") = "number" And value <> "" Then If Not IsNumeric(value) Then errors = errors & field & " must be a number; " End If End If ' Length check If rules(field).Exists("maxLength") Then If Len(value) > rules(field)("maxLength") Then errors = errors & field & " length cannot exceed " & rules(field)("maxLength") & "; " End If End If Next If errors <> "" Then ctx.Response.State400 "Parameter error: " & errors ctx.fIsAbort = True End If End If End Sub Private Function GetValidationRules(path As String) As Dictionary Set GetValidationRules = Nothing Dim rules As New Dictionary Select Case path Case "/api/users/create" Dim userRules As New Dictionary userRules("required") = True userRules("type") = "string" userRules("maxLength") = 50 rules("username") = userRules Dim emailRules As New Dictionary emailRules("required") = True emailRules("type") = "email" rules("email") = emailRules Set GetValidationRules = rules End Select End Function ``` ## SQL Injection Prevention ### Wrong Example ```vb ' Dangerous! Direct SQL concatenation Dim sql As String sql = "SELECT * FROM users WHERE username='" & ctx.Request("username") & "'" ``` ### Correct Approach: Parameterized Query ```vb ' Safe: Using parameterized query If ctx.Db.Sql("SELECT * FROM users WHERE username=?") _ .Param("username", ctx.Request("username"), adVarChar) _ .Fetch Then ' ... End If ``` ### Input Filtering Helper ```vb ' Filter dangerous characters Public Function SqlSafe(input As String) As String Dim result As String result = input result = Replace(result, "'", "''") ' Escape single quote result = Replace(result, ";", "") ' Remove semicolon result = Replace(result, "--", "") ' Remove comment SqlSafe = result End Function ``` ## XSS Protection ### HTML Encoding Output ```vb ' cSecurityUtils.bas Public Function HtmlEncode(text As String) As String Dim result As String result = text result = Replace(result, "&", "&") result = Replace(result, "<", "<") result = Replace(result, ">", ">") result = Replace(result, """", """) result = Replace(result, "'", "'") HtmlEncode = result End Function ' Usage in controller Public Sub Search(ctx As cHttpServerContext) Dim keyword As String keyword = ctx.Request.QueryString("q") ' Encode before output ctx.Response.Html "

    Search results: " & HtmlEncode(keyword) & "

    " End Sub ``` ### Cookie HttpOnly ```vb ' Set secure session cookie With ctx.Cookies.Cookie("SESSIONID") .Value = ctx.Session.SessionID .HttpOnly = True ' Disable JavaScript access .Secure = True ' HTTPS only .SameSite = "Strict" End With ``` ## CSRF Protection ### Token Verification ```vb ' cCsrfMiddleware.cls Option Explicit Public Sub Entry(ctx As cHttpServerContext) ' Only verify data-modifying requests If ctx.Request.Method <> ReqGet And _ ctx.Request.Method <> ReqOptions Then Dim token As String token = ctx.Request.Header("X-CSRF-Token") If token = "" Then token = ctx.Request.Form("_csrf") End If ' Verify token If token <> ctx.Session("csrf_token") Then ctx.Response.State403 "CSRF Token invalid" ctx.fIsAbort = True End If End If End Sub ``` ### Token Generation ```vb ' Generate CSRF token on login Public Sub Login(ctx As cHttpServerContext) ' ... Validate credentials ... ' Generate random token ctx.Session("csrf_token") = GenerateRandomToken() ' Return to client Dim result As New Dictionary result("csrf_token") = ctx.Session("csrf_token") ctx.Response.Json result End Sub Private Function GenerateRandomToken() As String ' Use GUID as token GenerateRandomToken = Replace(ToolsStr.GetGUID(False), "-", "") End Function ``` ## Password Security ### Password Hashing ```vb ' Use bcrypt or similar algorithm Public Function HashPassword(password As String) As String ' Use bcrypt in real projects ' This demonstrates basic hash + salt Dim salt As String salt = GenerateSalt() HashPassword = salt & "$" & SHA256(salt & password) End Function Public Function VerifyPassword(password As String, hashed As String) As Boolean Dim parts() As String parts = Split(hashed, "$") If UBound(parts) = 1 Then Dim salt As String salt = parts(0) VerifyPassword = (SHA256(salt & password) = parts(1)) End If End Function ``` ## Rate Limiting ```vb ' cRateLimitMiddleware.cls (complete version) Option Explicit Dim RequestLog As Dictionary ' IP -> Request record Dim BlockList As Dictionary ' IP -> Unblock time Private Sub Class_Initialize() Set RequestLog = New Dictionary Set BlockList = New Dictionary End Sub Public Sub Entry(ctx As cHttpServerContext) Dim ip As String ip = ctx.ClientInfo.IP ' Check if in blacklist If BlockList.Exists(ip) Then If Now < BlockList(ip) Then ctx.Response.State403 "IP blocked, try again in " & DateDiff("n", Now, BlockList(ip)) & " minutes" ctx.fIsAbort = True Exit Sub Else BlockList.Remove ip End If End If ' Get/create request record If Not RequestLog.Exists(ip) Then Dim record As New Dictionary record("count") = 0 record("startTime") = Now record("urls") = New Dictionary Set RequestLog(ip) = record End If Dim rec As Dictionary Set rec = RequestLog(ip) ' Reset if more than 1 minute If DateDiff("n", rec("startTime"), Now) >= 1 Then rec("count") = 0 rec("startTime") = Now Set rec("urls") = New Dictionary End If ' Count rec("count") = rec("count") + 1 Dim urls As Dictionary Set urls = rec("urls") urls(ctx.Request.PathInfo) = urls.Exists(ctx.Request.PathInfo) + 1 ' Check limit If rec("count") > 100 Then ' 100 per minute BlockList(ip) = DateAdd("n", 10, Now) ' Block for 10 minutes ctx.Response.State429 "Too many requests, IP has been blocked" ctx.fIsAbort = True Exit Sub End If ' Single URL rate check If urls(ctx.Request.PathInfo) > 30 Then ' 30 per minute per URL BlockList(ip) = DateAdd("n", 5, Now) ctx.Response.State429 "This endpoint has too many requests" ctx.fIsAbort = True End If End Sub ``` ## Security Headers ```vb ' cSecurityHeadersMiddleware.cls Option Explicit Public Sub Entry(ctx As cHttpServerContext) ' HSTS (Force HTTPS) ctx.Response.Header("Strict-Transport-Security") = "max-age=31536000; includeSubDomains" ' Prevent clickjacking ctx.Response.Header("X-Frame-Options") = "DENY" ' XSS protection ctx.Response.Header("X-Content-Type-Options") = "nosniff" ctx.Response.Header("X-XSS-Protection") = "1; mode=block" ' Content Security Policy ctx.Response.Header("Content-Security-Policy") = _ "default-src 'self'; " & _ "script-src 'self' 'unsafe-inline'; " & _ "style-src 'self' 'unsafe-inline';" ' Referrer Policy ctx.Response.Header("Referrer-Policy") = "strict-origin-when-cross-origin" End Sub ``` ## Logging Security ```vb ' cSecurityLogMiddleware.cls Option Explicit Public Sub Entry(ctx As cHttpServerContext) ' Log sensitive operations If IsSensitiveOperation(ctx.Request.PathInfo) Then Dim log As String log = Now & " | " & _ ctx.ClientInfo.IP & " | " & _ ctx.Request.MethodName & " | " & _ ctx.Request.PathInfo & " | " & _ ctx.Session("user_id") Call WriteSecurityLog(log) End If End Sub Private Function IsSensitiveOperation(path As String) As Boolean IsSensitiveOperation = (InStr(path, "/login") > 0 Or _ InStr(path, "/password") > 0 Or _ InStr(path, "/delete") > 0 Or _ InStr(path, "/admin") > 0) End Function Private Sub WriteSecurityLog(msg As String) Dim f As Integer f = FreeFile Open "C:\Logs\security.log" For Append As #f Print #f, msg Close #f End Sub ``` ## Request Body Size Limit ### MaxRequestSize Configuration Prevents malicious clients from sending oversized request bodies that could cause server OOM crashes. ```vb ' Configure before starting Server.MaxRequestSize = 5242880 ' 5MB ' When exceeded, connection is automatically closed and logged ' Client receives 413 Payload Too Large response ``` **Description**: Default 10MB. Adjust based on business needs: * Pure API services: 1-5MB * File upload support: Set based on maximum file size ### Maximum Connection Limit ```vb Server.MaxConnections = 500 ' Max 500 simultaneous connections ``` **Description**: Default 1000. When exceeded, new connections are rejected and `OnLogs` event records a WARN log. *** ## Security Configuration Checklist | Check Item | Status | Description | | ----------------------- | ------ | ------------------------------------------------------------------------------------ | | Force HTTPS | ☐ | Production must use HTTPS | | Parameterized Query | ☐ | All database operations use parameterized | | XSS Filtering | ☐ | Encode HTML in output | | CSRF Token | ☐ | Verify CSRF token on modifications | | HttpOnly Cookie | ☐ | Session cookie with HttpOnly | | Secure Cookie | ☐ | Set Secure in HTTPS environment | | Password Hashing | ☐ | Use bcrypt or secure algorithm | | Rate Limiting | ☐ | Limit endpoint request frequency | | Security Headers | ☐ | Add X-Frame-Options etc. | | Logging | ☐ | Log sensitive operations and security events | | Request Body Size Limit | ☐ | Configure MaxRequestSize to prevent OOM | | Connection Limit | ☐ | Configure MaxConnections to prevent resource exhaustion | | Idle Connection Timeout | ☐ | Configure IdleTimeoutSeconds to clean zombie connections | | Session Auto Cleanup | ☐ | Built-in timer auto cleans expired sessions, or manually call CleanupExpiredSessions | | SSE Client Release | ☐ | CloseClient auto closes Socket and cleans all references, preventing resource leaks | *** **Last Updated**: 2026-06-13 --- --- url: /en/vbman/serialport/framing.md --- # Serial Port Data Framing Protocol > Solving the core problem of "device continuous transmission causing packet concatenation" and "unable to identify complete frames" in serial communication ## 📖 Table of Contents: * [Problem Background](#problem-background) * [Framing Solution Comparison](#framing-solution-comparison) * [Plan B: Frame Interval Timeout Framing](#plan-b-frame-interval-timeout-framing) * [Plan C: Protocol Frame Parser](#plan-c-protocol-frame-parser) * [B + C Combined Practice](#b--c-combined-practice) * [Solution Selection Guide](#solution-selection-guide) * [Tuning and Troubleshooting](#tuning-and-troubleshooting) *** ## Problem Background ### Packet Concatenation Phenomenon In serial communication, devices often continuously send multiple frames of data. The Windows serial driver stacks all received bytes in the receive buffer, **without distinguishing frame boundaries**. If using a 50ms polling timer to read: ``` Timeline: 0ms Device sends Frame1 (10 bytes) 5ms Device sends Frame2 (8 bytes) ← No pause between Frame1 12ms Device sends Frame3 (12 bytes) ... 50ms Timer triggers Poll() Buffer has 30 bytes → ReadExisting() reads all at once Result: 3 frames concatenated, unable to parse ``` ### Polling Timer Limitations `SetTimer` on Windows has a real precision of only ~15ms. Even setting `PollInterval` to 10ms cannot achieve true real-time. **Shortening the polling interval only mitigates, cannot eliminate packet concatenation**. ### Solution Approach To identify the boundary of each frame, explicit "framing rules" are needed. This class provides two complementary solutions: * **Plan B**: Use the **brief pause** after the device finishes sending one frame as a natural framing point * **Plan C**: Precisely split by device **protocol format** (delimiter / start-end markers / length field / fixed length) *** ## Framing Solution Comparison | Solution | Real-time | Precision | Need Protocol Knowledge | Applicable Scenario | |----------|-----------|-----------|------------------------|---------------------| | **B. Frame Interval Timeout** | Good | Medium | No | Device pauses after sending each frame (most scenarios) | | **C1. Delimiter** | Best | High | Yes | Text protocol with fixed delimiter (e.g., `\r\n`) | | **C2. Start-End Markers** | Best | High | Yes | Binary protocol with STX/ETX markers | | **C3. Length Prefix** | Best | High | Yes | Protocol with length field (e.g., Modbus-like) | | **C4. Fixed Length** | Best | High | Yes | Protocol with fixed frame length | | **B + C Combined** | Best | Highest | Yes | High reliability scenarios, coarse then fine splitting | *** ## Plan B: Frame Interval Timeout Framing ### Principle After the device finishes sending each frame, there is necessarily a brief pause (even a few milliseconds) before sending the next frame. This pause is the natural frame boundary: ``` Frame1(10B) |pause| Frame2(8B) |pause| Frame3(12B) ↑ ↑ Framing point Framing point ``` `cSerialPort` internally maintains a frame buffer; continuously received data is treated as the same frame; when no new data arrives for more than `FrameInterval` milliseconds, one frame is considered complete, and the `FrameReceived` event is triggered. ### Enabling Framing Simply set the `FrameInterval` property to a non-zero value to enable: ```vb Private WithEvents m_Port As cSerialPort Private Sub Form_Load() Set m_Port = New cSerialPort m_Port.PortName = "COM3" m_Port.Config.BaudRate = br9600 If m_Port.OpenPort() Then ' Enable framing: 30ms no new data = one frame ends m_Port.FrameInterval = 30 ' Polling interval recommended <= FrameInterval / 2, for timeliness m_Port.StartMonitoring 20 End If End Sub ' Frame received event - triggered once for each complete frame received Private Sub m_Port_FrameReceived(FrameData() As Byte) Dim s As String s = StrConv(FrameData, vbUnicode) Debug.Print "Received frame (" & UBound(FrameData) + 1 & " bytes): " & s End Sub ``` ### Key Properties | Property | Type | Default | Description | |----------|------|---------|-------------| | `FrameInterval` | Long | 0 | Frame interval timeout (ms), 0=disable framing (keep original `DataReceived` mode) | | `MaxFrameSize` | Long | 65536 | Maximum bytes per frame, forced trigger if exceeded, preventing memory overflow from abnormal data | | `FrameBufferLength` | Long | - | Read-only, number of bytes currently in frame buffer (untriggered data received) | ### FrameInterval Value Recommendations | Device Type | Recommended Value | Description | |-------------|-------------------|-------------| | Text devices (GPS, temperature/humidity, etc.) | 20-50ms | Obvious inter-frame pauses | | Industrial instruments | 10-30ms | Fast response, short pauses | | Modbus RTU | - | Not recommended for Plan B, should use Plan C3 (see below) | | Slow devices (electronic scales, etc.) | 50-100ms | Device sends slowly by itself | > Empirical rule: First observe the actual pause between frames when the device continuously sends data (use a serial debug assistant with timestamps), and set `FrameInterval` to about half of the pause time for the most stable result. ### Notes 1. **Relationship between polling interval and frame interval**: `PollInterval` should be ≤ `FrameInterval / 2`, otherwise the frame timeout detection timing may be missed. 2. **Does not break original mode**: When `FrameInterval = 0`, it still follows the original `DataReceived` path, backward compatible. 3. **Last frame not lost**: `StopMonitoring` and `ClosePort` automatically flush remaining untriggered frames in the buffer. 4. **Large frame protection**: Single frame exceeding `MaxFrameSize` is forced to trigger, avoiding memory exhaustion from abnormal data. *** ## Plan C: Protocol Frame Parser `cSerialFrameParser` is an independent frame parsing class that supports 4 protocol framing modes. **It does not directly read the serial port**, but receives byte streams passed via `AppendData`, splitting complete frames according to protocol rules. ### Reference Method ```vb ' Method 1: Source code reference ' Add src/SerialPort/cSerialFrameParser.cls to the project ' Method 2: DLL reference Dim parser As New VBMANLIB.cSerialFrameParser ``` ### C1. Delimiter Mode Suitable for protocols with fixed delimiters (most common for text protocols): ``` [DATA1][DELIM][DATA2][DELIM][DATA3][DELIM]... ``` ```vb Dim parser As New cSerialFrameParser ' Frame by CRLF, returned frames do not include delimiter parser.SetDelimiterMode vbCrLf, False ' Can also use other delimiters parser.SetDelimiterMode Chr(10), False ' Only LF parser.SetDelimiterMode "|", False ' Custom character ' Inject data parser.AppendData someBytes ' Loop to extract all complete frames Do While parser.HasFrame() Dim frame() As Byte frame = parser.GetFrame() Debug.Print StrConv(frame, vbUnicode) Loop ``` Parameter description: | Parameter | Description | |-----------|-------------| | `DelimiterStr` | Delimiter string (can be multi-byte, e.g., `vbCrLf`) | | `IncludeDelim` | `True`=returned frames include delimiter; `False`=not included (default) | ### C2. Start-End Marker Mode Suitable for binary protocols with STX/ETX and other delimiters: ``` [STX][DATA1][ETX][STX][DATA2][ETX]... ``` ```vb Dim parser As New cSerialFrameParser ' STX(0x02) ... ETX(0x03), returned frames include markers parser.SetStartEndMode Chr$(&H2), Chr$(&H3), True ' Also supports multi-byte markers parser.SetStartEndMode "<<<", ">>>", True ``` | Parameter | Description | |-----------|-------------| | `StartStr` | Start marker string | | `EndStr` | End marker string | | `IncludeMarks` | `True`=returned frames include markers; `False`=only return middle data | **Fault tolerance**: When the buffer start is not `StartMark`, the parser automatically skips invalid bytes and starts parsing from the next `StartMark`. This correctly handles the "half-frame residue" problem (unfinished frames from the previous reception). ### C3. Length Prefix Mode Suitable for binary protocols with length fields (e.g., Modbus, custom header protocols): ``` ┌─────────┬───────────┬──────────┬─────────┐ │ Header │ Length(n) │ Payload │ Trailer │ │ (fixed) │ (1/2/4B) │ (n bytes)│ (fixed) │ └─────────┴───────────┴──────────┴─────────┘ ``` #### Configuration Parameters | Parameter | Description | |-----------|-------------| | `Offset` | Byte offset of the length field in the frame (starting from 0) | | `Size` | Length field size: 1/2/4 bytes | | `BaseSize` | Frame base size (bytes outside the length value range: Header + Length field + Trailer) | | `BigEndian` | `True`=big-endian; `False`=little-endian | | `Meaning` | Meaning of the length value (see table below) | #### LengthMeaning Enumeration | Value | Meaning | Frame Total Length Calculation | |-------|---------|-------------------------------| | `lmPayload` (0) | Length value = data payload length | `FrameBaseSize + length value` | | `lmPayloadAndTrailer` (1) | Length value = payload + trailer | `FrameBaseSize + length value` | | `lmTotalFrame` (2) | Length value = entire frame length | `length value` | #### Common Protocol Configuration Examples **Example 1: Simple Length Prefix** ``` [LEN(1)][DATA(n)] ``` Length value = n (data length), no Header/Trailer. ```vb ' Offset=0, Size=1, BaseSize=1(LEN itself), little-endian, lmPayload parser.SetLengthPrefixMode 0, 1, 1, False, lmPayload ``` **Example 2: With STX and CRC** ``` [STX(1)][LEN(2,BE)][DATA(n)][CRC(1)] ``` Length value = n, BaseSize = 1(STX) + 2(LEN) + 1(CRC) = 4. ```vb parser.SetLengthPrefixMode 1, 2, 4, True, lmPayload ' Offset=1(skip STX), Size=2 bytes, BaseSize=4, big-endian ``` **Example 3: Length Value Represents Entire Frame** ``` [HEADER(2)][LEN(2,LE)][DATA(n)] ``` Length value = 2 + 2 + n (entire frame length). ```vb parser.SetLengthPrefixMode 2, 2, 0, False, lmTotalFrame ' Offset=2(skip HEADER), Size=2 bytes, BaseSize=0(not used), little-endian ``` **Example 4: Length Value Includes Trailer** ``` [LEN(1)][DATA(n)][CRC(1)] ``` Length value = n + 1 (includes CRC), BaseSize = 1 (only LEN field). ```vb parser.SetLengthPrefixMode 0, 1, 1, False, lmPayloadAndTrailer ``` #### Modbus RTU Special Note Modbus RTU **has no length field**; frame boundaries are identified by a 3.5 character time silent interval (~3.5ms at 9600bps). In this case: * Recommended to use **Plan B** (`FrameInterval = 4` approx.) for "Modbus-style framing" * Or directly use VBManLib's `cModbusMaster` / `cModbusSlave` classes, which have built-in RTU framing ### C4. Fixed Length Mode Suitable for protocols with fixed frame length (e.g., some sensors output 16 bytes per frame): ```vb parser.SetFixedSizeMode 16 ' Cut one frame every 16 bytes Do While parser.HasFrame() Dim frame() As Byte frame = parser.GetFrame() ' Process frame... Loop ``` ### Common API Regardless of the mode, the external interface is unified: | Method/Property | Description | |----------------|-------------| | `AppendData(Data() As Byte)` | Append byte stream to internal buffer | | `HasFrame() As Boolean` | Check if buffer has complete frames | | `GetFrame() As Byte()` | Extract one frame and remove from buffer | | `GetAllFrames() As Collection` | Extract all available frames (each element is a Byte array) | | `Clear()` | Clear internal buffer | | `BufferLength` | Read-only, remaining unparsed bytes in buffer | ```vb ' Extract all frames at once Dim frames As Collection Set frames = parser.GetAllFrames() Dim v As Variant, frame() As Byte For Each v In frames frame = v Debug.Print StrConv(frame, vbUnicode) Next ``` *** ## B + C Combined Practice Highest reliability scenario: first use Plan B for coarse splitting (time-based), then use Plan C for fine splitting (protocol-based). This way, even if the device has no pause between frames, correct framing can still be achieved. ### Typical Scenario Device protocol: `[STX][LEN][DATA][ETX]`, but the device may continuously send multiple frames without pauses. ### Complete Code ```vb Private WithEvents m_Port As cSerialPort Private m_Parser As cSerialFrameParser Private Sub Form_Load() Set m_Port = New cSerialPort Set m_Parser = New cSerialFrameParser ' Configure protocol framing (Plan C2: start-end marker mode) m_Parser.SetStartEndMode Chr$(&H2), Chr$(&H3), True ' Configure serial port m_Port.PortName = "COM3" m_Port.Config.BaudRate = br115200 If m_Port.OpenPort() Then ' Enable time framing (Plan B) m_Port.FrameInterval = 50 ' Start monitoring m_Port.StartMonitoring 20 End If End Sub ' Plan B triggers: each "time frame" arrives Private Sub m_Port_FrameReceived(FrameData() As Byte) ' Feed time frame to protocol parser m_Parser.AppendData FrameData ' Plan C fine splitting: extract multiple protocol frames from one time frame Do While m_Parser.HasFrame() Dim frame() As Byte frame = m_Parser.GetFrame() Debug.Print "Complete protocol frame: " & BytesToHex(frame) Loop End Sub Private Sub Form_Unload(Cancel As Integer) If Not m_Port Is Nothing Then If m_Port.IsOpen Then m_Port.ClosePort Set m_Port = Nothing End If End Sub ' Helper: byte array to hex string Private Function BytesToHex(buf() As Byte) As String Dim i As Long, s As String For i = 0 To UBound(buf) s = s & Right$("0" & Hex$(buf(i)), 2) & " " Next BytesToHex = Trim$(s) End Function ``` ### Data Flow Diagram ``` Device sends: [STX][LEN=3][A][B][C][ETX][STX][LEN=2][X][Y][ETX] (two frames without pause) PlanB (FrameInterval=50ms): └─ Triggers FrameReceived(12 bytes) PlanC (SetStartEndMode): └─ Extracts two frames: 1. [STX][LEN=3][A][B][C][ETX] 2. [STX][LEN=2][X][Y][ETX] ``` *** ## Solution Selection Guide ``` Do you know the device protocol format? ├── No → Use Plan B (FrameInterval = 30~50ms) │ └── Yes → What features does the protocol have? ├── Has delimiter (\r\n, etc.) → Plan C1 ├── Has STX/ETX start-end markers → Plan C2 ├── Has length field → Plan C3 ├── Fixed length → Plan C4 └── None, but pauses between frames → Plan B │ └── High reliability requirement? ├── Yes → B + C Combined └── No → Only B ``` ### Quick Reference for Each Solution's Applicable Scenarios | Device Type | Recommended Solution | Configuration Example | |-------------|---------------------|----------------------| | GPS module (NMEA 0183) | C1 | `SetDelimiterMode vbCrLf, False` | | Temperature/humidity sensor (text output) | C1 or B | Delimiter `"\r\n"` or `FrameInterval=50` | | RFID reader (STX/ETX protocol) | C2 | `SetStartEndMode Chr(2), Chr(3), True` | | Modbus RTU | B or dedicated class | `FrameInterval=4`, or use `cModbusMaster` | | Custom binary protocol (with length) | C3 | See length prefix examples | | Electronic scale (fixed length output) | C4 | `SetFixedSizeMode 16` | | Industrial instrument (irregular reporting) | B | `FrameInterval=30` | *** ## Tuning and Troubleshooting ### Common Problems #### 1. Frame Split in Two Parts **Symptom**: Data that should be one frame is split into two `FrameReceived` triggers. **Cause**: `FrameInterval` is too small; a brief pause during device transmission of one frame is misjudged as frame end. **Solution**: Increase `FrameInterval`. Use a serial debug assistant to first observe the maximum byte interval during device single-frame transmission. #### 2. Multiple Frames Concatenated into One **Symptom**: Data that should be two frames is merged into one `FrameReceived` trigger. **Cause**: `FrameInterval` is too large; the pause after the device finishes one frame is less than `FrameInterval`. **Solution**: Decrease `FrameInterval`, or switch to Plan C for precise protocol-based framing. #### 3. Last Frame Lost **Symptom**: After the device finishes sending the last frame and stops, no `FrameReceived` is triggered. **Cause**: After the last frame, there is no subsequent data to "push" the timeout detection. **Solution**: This is a fixed issue. `StopMonitoring` and `ClosePort` automatically flush the remaining buffer. If you manually manage the lifecycle, ensure calling `m_Port.FlushFrames` before stopping. #### 4. Plan C Cannot Parse Frames **Troubleshooting Steps**: ```vb ' 1. Print raw data for confirmation Debug.Print "Raw data: " & BytesToHex(rawBytes) ' 2. Check if BufferLength is growing Debug.Print "Buffer length: " & parser.BufferLength ' 3. Check configuration correctness Debug.Print "Mode: " & parser.Mode ' Should be 1/2/3/4 Debug.Print "Buffer: " & parser.BufferLength ' 4. Does protocol match configuration? ' - Delimiter mode: Check if delimiter bytes are correct ' - Start-end markers: Confirm STX/ETX byte values ' - Length prefix: Use debug assistant to view length field value, manually calculate total frame length to verify match ``` ### Debug Helper Functions ```vb ' Byte array to hex string (for debugging) Private Function BytesToHex(buf() As Byte) As String Dim i As Long, s As String On Error Resume Next For i = LBound(buf) To UBound(buf) s = s & Right$("0" & Hex$(buf(i)), 2) & " " Next BytesToHex = Trim$(s) End Function ' Byte array to visible ASCII (invisible characters shown as .) Private Function BytesToAscii(buf() As Byte) As String Dim i As Long, s As String, b As Byte On Error Resume Next For i = LBound(buf) To UBound(buf) b = buf(i) If b >= 32 And b < 127 Then s = s & Chr$(b) Else s = s & "." End If Next BytesToAscii = s End Function ``` ### Performance Notes 1. **`GetFrame()` does not copy large blocks of memory**: Uses `CopyMemory` for efficient transfer, MB-level single frames are no problem. 2. **Buffer auto-expansion**: `AppendData` auto-expands as needed, no manual management required. 3. **Avoid time-consuming operations in events**: `FrameReceived` event callbacks should process as quickly as possible; avoid heavy computation or UI refresh, to prevent affecting next frame reception. *** ## Complete API Quick Reference ### cSerialPort Framing Related | Member | Type | Description | |--------|------|-------------| | `FrameInterval` | Property | Frame interval timeout (ms), 0=disable framing | | `MaxFrameSize` | Property | Maximum bytes per frame (default 65536) | | `FrameBufferLength` | Property | Read-only, current frame buffer byte count | | `FrameReceived` | Event | Triggered when complete frame arrives (parameter: `FrameData() As Byte`) | | `FlushFrames` | Method | Manually trigger remaining frames in buffer | ### cSerialFrameParser Complete API | Member | Type | Description | |--------|------|-------------| | `Mode` | Property | Framing mode (`fmNone/fmDelimiter/fmStartEnd/fmLengthPrefix/fmFixedSize`) | | `BufferLength` | Property | Read-only, remaining bytes in buffer | | `AppendData` | Method | Append byte stream | | `HasFrame` | Method | Check if complete frame exists | | `GetFrame` | Method | Extract one frame | | `GetAllFrames` | Method | Extract all frames | | `Clear` | Method | Clear buffer | | `SetDelimiterMode` | Method | Configure delimiter mode | | `SetStartEndMode` | Method | Configure start-end marker mode | | `SetLengthPrefixMode` | Method | Configure length prefix mode | | `SetFixedSizeMode` | Method | Configure fixed length mode | *** **Last Updated**: 2026-07-05 --- --- url: /zh/vbman/demo/16.SerialPort.md --- # SerialPort 串口收发示例（Test1） ## 概述 本示例演示如何使用 `cSerialPort` 类实现串口持续收发通信。程序打开 COM4，使用 `cTimer` 定时器每 2 秒发送一次 `hello`，并通过事件驱动方式自动接收对端返回的数据，实时显示在列表框中。 ## 项目结构 ``` Test1/ ├── Form1.frm # 主窗体，串口收发逻辑 ├── COM3_TEST.vbp # VB6 项目文件 ├── COM3_TEST.vbw # 工程组文件 └── pic/ # 截图目录 ``` :::: tip 下载源码 \[ 注意：重新到 `bin` 目录注册 DLL 文件 ] 代码请到首页下载 VBMAN 项目，解压后，打开包含所有 DEMO 项目。 :::: ## 核心代码解析 ### 1. 对象声明 使用 `WithEvents` 声明串口和定时器对象，以便接收事件回调： ```vb Private WithEvents m_Port As cSerialPort ' 串口对象（接收事件） Private WithEvents m_Tmr As cTimer ' 定时器对象（定时发送） ``` ### 2. 启动串口 窗体加载时自动启动 COM4 通信： ```vb Public Sub StartCOM4() Set m_Port = New cSerialPort Set m_Tmr = New cTimer ' 配置串口参数 m_Port.PortName = "COM4" m_Port.Config.BaudRate = br9600 m_Port.Config.DataBits = 8 m_Port.Config.Parity = ptNone m_Port.Config.StopBits = sb1 If Not m_Port.OpenPort() Then Logs "[FAIL] 无法打开 COM4: " & m_Port.LastErrorMsg Exit Sub End If ' 启动串口监控（触发 DataReceived 事件） m_Port.StartMonitoring 50 ' 启动定时器，每2秒发送一次 hello m_Tmr.Interval = 2000 m_Tmr.Enabled = True Logs "[INFO] COM4 已打开，每2秒发送 hello，持续监听接收..." End Sub ``` ### 3. 定时发送 `cTimer` 每 2 秒触发一次，发送 `hello`： ```vb Private Sub m_Tmr_Timer() If Not m_Port Is Nothing Then If m_Port.IsOpen Then m_Port.WriteText "hello" Logs "[TX] hello" End If End If End Sub ``` ### 4. 事件驱动接收 当输入缓冲区有新数据到达时，`DataReceived` 事件自动触发，读取并显示： ```vb Private Sub m_Port_DataReceived(ByVal BytesCount As Long) Dim s As String s = m_Port.ReadExisting() Logs "[RX] " & s End Sub ``` ### 5. 错误处理 串口通信错误通过事件回调捕获： ```vb Private Sub m_Port_ErrorOccurred(ByVal ErrorCode As Long, ByVal ErrorMsg As String) Logs "[ERR] " & ErrorMsg End Sub ``` ### 6. 停止与清理 ```vb Public Sub StopCOM4() If Not m_Tmr Is Nothing Then m_Tmr.Enabled = False Set m_Tmr = Nothing End If If Not m_Port Is Nothing Then If m_Port.IsOpen Then m_Port.ClosePort Set m_Port = Nothing End If Logs "[INFO] 已停止" End Sub ``` ## 功能说明 1. **持续通信** * 使用 `cTimer` 定时器每 2 秒自动发送 `hello` * 通过 `StartMonitoring` 启动事件监控，自动接收数据 2. **事件驱动架构** * `DataReceived` 事件：有数据到达时自动触发 * `ErrorOccurred` 事件：通信错误时自动触发 * `m_Tmr_Timer` 事件：定时发送触发 3. **实时日志** * 收发记录实时显示在 `ListBox` 中 * 每条记录带时间戳，新记录显示在顶部 ## 技术要点 1. **`WithEvents` 事件绑定**：通过 `WithEvents` 声明对象变量，VB6 自动生成事件处理过程，无需手动注册回调。 2. **异步监控模式**：`StartMonitoring 50` 以 50ms 间隔轮询串口缓冲区，检测到新数据时触发 `DataReceived` 事件，不阻塞 UI 线程。 3. **对象生命周期管理**：`StopCOM4` 中按顺序停止定时器、关闭串口、释放对象，避免资源泄漏。先 `Enabled = False` 再 `Set Nothing`。 4. **配置参数**：示例使用 9600/8/N/1 的常见配置，使用枚举常量 `br9600`、`ptNone`、`sb1` 设置（编译为 DLL 后枚举随类型库导出，可直接使用）。 ## 运行效果 ``` 2026/7/5 10:30:00 [INFO] COM4 已打开，每2秒发送 hello，持续监听接收... 2026/7/5 10:30:02 [TX] hello 2026/7/5 10:30:02 [RX] world 2026/7/5 10:30:04 [TX] hello 2026/7/5 10:30:04 [RX] world ... ``` ## 运行前提 * 需要一个可用的串口（COM4），或使用虚拟串口软件（如 com0com、Virtual Serial Port Driver）创建虚拟串口对。 * 对端设备收到 `hello` 后应回应数据（如 `world`）。 * 已注册 VBMAN.dll 或将源码加入工程。 ## 扩展建议 1. **改用其他端口**：修改 `m_Port.PortName = "COM3"` 等以适配实际硬件。 2. **动态配置**：在窗体上添加端口名、波特率输入框，运行时动态设置。 3. **十六进制显示**：将接收数据以十六进制显示，便于调试二进制协议。 4. **发送自定义数据**：添加文本框和发送按钮，支持手动发送任意数据。 5. **信号线监控**：订阅 `PinChanged` 事件，监控 CTS/DSR/RING 状态变化。 6. **Modbus 协议**：基于本示例扩展，实现 Modbus RTU 主站/从站通信。 7. **数据分帧**：当设备连发导致粘包时，使用分帧功能识别每一帧（详见下文）。 ## 进阶：使用分帧解决粘包问题 ### 问题场景 本示例使用 `DataReceived` 事件 + 50ms 轮询读取数据。当设备连续发送多帧数据时（如设备快速发了几次响应），50ms 内缓冲区可能堆积好几帧，`ReadExisting()` 一次读出所有数据，导致帧粘连无法解析。 ### 方案 B：帧间隔超时分帧 利用设备发完一帧后的短暂停顿作为天然分帧点： ```vb Public Sub StartCOM4() Set m_Port = New cSerialPort m_Port.PortName = "COM4" m_Port.Config.BaudRate = br9600 If Not m_Port.OpenPort() Then Logs "[FAIL] 无法打开 COM4: " & m_Port.LastErrorMsg Exit Sub End If ' 关键：启用分帧，30ms 无新数据 = 一帧结束 m_Port.FrameInterval = 30 ' 轮询间隔建议 <= FrameInterval/2 m_Port.StartMonitoring 20 Logs "[INFO] COM4 已打开，分帧模式已启用" End Sub ' 改用 FrameReceived 事件替代 DataReceived Private Sub m_Port_FrameReceived(FrameData() As Byte) Dim s As String s = StrConv(FrameData, vbUnicode) Logs "[RX帧] " & s & " (" & UBound(FrameData) + 1 & "字节)" End Sub ``` ### 方案 C：协议分帧解析器 按设备协议精确切分（如按 `\r\n` 分隔）： ```vb Private m_Parser As cSerialFrameParser Private Sub Form_Load() Set m_Port = New cSerialPort Set m_Parser = New cSerialFrameParser ' 配置协议分帧 m_Parser.SetDelimiterMode vbCrLf, False m_Port.PortName = "COM4" m_Port.Config.BaudRate = br9600 m_Port.FrameInterval = 50 ' 方案 B 粗切 m_Port.OpenPort m_Port.StartMonitoring 20 End Sub ' 方案 B 触发时间帧 → 喂给方案 C 精切 Private Sub m_Port_FrameReceived(FrameData() As Byte) m_Parser.AppendData FrameData Do While m_Parser.HasFrame() Dim frame() As Byte frame = m_Parser.GetFrame() Logs "[完整帧] " & StrConv(frame, vbUnicode) Loop End Sub ``` 详细的分帧原理、四种协议模式（分隔符/起止标记/长度前缀/固定长度）、调参与排错，请参阅 [串口分帧协议专题文档](../serialport/framing.md)。 --- --- url: /en/vbman/demo/16.SerialPort.md --- # SerialPort Send/Receive Example (Test1) ## Overview This example demonstrates how to use the `cSerialPort` class to implement continuous serial port send/receive communication. The program opens COM4, uses the `cTimer` timer to send `hello` every 2 seconds, and automatically receives data returned from the peer through event-driven mode, displaying it in a list box in real-time. ## Project Structure ``` Test1/ ├── Form1.frm # Main form, serial send/receive logic ├── COM3_TEST.vbp # VB6 project file ├── COM3_TEST.vbw # Project group file └── pic/ # Screenshots directory ``` ::::: tip Download Source Code \[ Note: Re-register the DLL file in the `bin` directory ] Download the VBMAN project from the homepage, unzip it, and open all DEMO projects included. ::::: ## Core Code Analysis ### 1. Object Declaration Declare serial port and timer objects with `WithEvents` to receive event callbacks: ```vb Private WithEvents m_Port As cSerialPort ' Serial port object (receive events) Private WithEvents m_Tmr As cTimer ' Timer object (periodic sending) ``` ### 2. Start Serial Port Automatically start COM4 communication when form loads: ```vb Public Sub StartCOM4() Set m_Port = New cSerialPort Set m_Tmr = New cTimer ' Configure serial port parameters m_Port.PortName = "COM4" m_Port.Config.BaudRate = br9600 m_Port.Config.DataBits = 8 m_Port.Config.Parity = ptNone m_Port.Config.StopBits = sb1 If Not m_Port.OpenPort() Then Logs "[FAIL] Cannot open COM4: " & m_Port.LastErrorMsg Exit Sub End If ' Start serial port monitoring (triggers DataReceived event) m_Port.StartMonitoring 50 ' Start timer, send hello every 2 seconds m_Tmr.Interval = 2000 m_Tmr.Enabled = True Logs "[INFO] COM4 opened, sending hello every 2 seconds, continuously listening..." End Sub ``` ### 3. Periodic Sending `cTimer` triggers every 2 seconds, sending `hello`: ```vb Private Sub m_Tmr_Timer() If Not m_Port Is Nothing Then If m_Port.IsOpen Then m_Port.WriteText "hello" Logs "[TX] hello" End If End If End Sub ``` ### 4. Event-Driven Receiving When new data arrives in the input buffer, the `DataReceived` event automatically triggers, reads and displays: ```vb Private Sub m_Port_DataReceived(ByVal BytesCount As Long) Dim s As String s = m_Port.ReadExisting() Logs "[RX] " & s End Sub ``` ### 5. Error Handling Serial communication errors are captured via event callback: ```vb Private Sub m_Port_ErrorOccurred(ByVal ErrorCode As Long, ByVal ErrorMsg As String) Logs "[ERR] " & ErrorMsg End Sub ``` ### 6. Stop and Cleanup ```vb Public Sub StopCOM4() If Not m_Tmr Is Nothing Then m_Tmr.Enabled = False Set m_Tmr = Nothing End If If Not m_Port Is Nothing Then If m_Port.IsOpen Then m_Port.ClosePort Set m_Port = Nothing End If Logs "[INFO] Stopped" End Sub ``` ## Function Description 1. **Continuous Communication** * Uses `cTimer` timer to automatically send `hello` every 2 seconds * Starts event monitoring via `StartMonitoring` for automatic data reception 2. **Event-Driven Architecture** * `DataReceived` event: automatically triggers when data arrives * `ErrorOccurred` event: automatically triggers on communication errors * `m_Tmr_Timer` event: triggers on periodic send 3. **Real-Time Logging** * Send/receive records displayed in `ListBox` in real-time * Each record has a timestamp, new records appear at the top ## Technical Points 1. **`WithEvents` Event Binding**: Declare object variables with `WithEvents`, VB6 automatically generates event handler procedures, no need for manual callback registration. 2. **Asynchronous Monitoring Mode**: `StartMonitoring 50` polls the serial port buffer at 50ms intervals, triggers `DataReceived` event when new data is detected, does not block UI thread. 3. **Object Lifecycle Management**: In `StopCOM4`, stop timer, close serial port, and release objects in sequence to avoid resource leaks. First `Enabled = False`, then `Set Nothing`. 4. **Configuration Parameters**: Example uses 9600/8/N/1 common configuration, with enum constants `br9600`, `ptNone`, `sb1` (after compiling to DLL, enums are exported with the type library and can be used directly). ## Runtime Output ``` 2026/7/5 10:30:00 [INFO] COM4 opened, sending hello every 2 seconds, continuously listening... 2026/7/5 10:30:02 [TX] hello 2026/7/5 10:30:02 [RX] world 2026/7/5 10:30:04 [TX] hello 2026/7/5 10:30:04 [RX] world ... ``` ## Prerequisites * Requires an available serial port (COM4), or use virtual serial port software (e.g., com0com, Virtual Serial Port Driver) to create virtual port pairs. * Peer device should respond with data (e.g., `world`) after receiving `hello`. * VBMAN.dll must be registered, or source code added to project. ## Extension Suggestions 1. **Use Other Ports**: Modify `m_Port.PortName = "COM3"` etc. to adapt to actual hardware. 2. **Dynamic Configuration**: Add port name, baud rate input boxes on the form for runtime dynamic settings. 3. **Hex Display**: Display received data in hexadecimal for debugging binary protocols. 4. **Send Custom Data**: Add text box and send button for manual sending of arbitrary data. 5. **Signal Line Monitoring**: Subscribe to `PinChanged` event to monitor CTS/DSR/RING status changes. 6. **Modbus Protocol**: Extend from this example to implement Modbus RTU master/slave communication. 7. **Data Framing**: When device continuous transmission causes packet concatenation, use framing to identify each frame (see below). ## Advanced: Using Framing to Solve Packet Concatenation ### Problem Scenario This example uses the `DataReceived` event + 50ms polling to read data. When the device continuously sends multiple frames of data (e.g., the device quickly sends several responses), multiple frames may accumulate in the buffer within 50ms, and `ReadExisting()` reads all data at once, causing frame concatenation that cannot be parsed. ### Plan B: Frame Interval Timeout Framing Use the brief pause after the device finishes sending one frame as a natural framing point: ```vb Public Sub StartCOM4() Set m_Port = New cSerialPort m_Port.PortName = "COM4" m_Port.Config.BaudRate = br9600 If Not m_Port.OpenPort() Then Logs "[FAIL] Cannot open COM4: " & m_Port.LastErrorMsg Exit Sub End If ' Key: Enable framing, 30ms no new data = one frame ends m_Port.FrameInterval = 30 ' Polling interval recommended <= FrameInterval/2 m_Port.StartMonitoring 20 Logs "[INFO] COM4 opened, framing mode enabled" End Sub ' Use FrameReceived event instead of DataReceived Private Sub m_Port_FrameReceived(FrameData() As Byte) Dim s As String s = StrConv(FrameData, vbUnicode) Logs "[RX Frame] " & s & " (" & UBound(FrameData) + 1 & " bytes)" End Sub ``` ### Plan C: Protocol Frame Parser Precisely split by device protocol (e.g., by `\r\n` delimiter): ```vb Private m_Parser As cSerialFrameParser Private Sub Form_Load() Set m_Port = New cSerialPort Set m_Parser = New cSerialFrameParser ' Configure protocol framing m_Parser.SetDelimiterMode vbCrLf, False m_Port.PortName = "COM4" m_Port.Config.BaudRate = br9600 m_Port.FrameInterval = 50 ' Plan B coarse splitting m_Port.OpenPort m_Port.StartMonitoring 20 End Sub ' Plan B triggers time frame -> feed to Plan C for precise splitting Private Sub m_Port_FrameReceived(FrameData() As Byte) m_Parser.AppendData FrameData Do While m_Parser.HasFrame() Dim frame() As Byte frame = m_Parser.GetFrame() Logs "[Complete Frame] " & StrConv(frame, vbUnicode) Loop End Sub ``` For detailed framing principles, four protocol modes (delimiter/start-end markers/length prefix/fixed length), tuning and troubleshooting, see [Serial Port Framing Protocol Guide](../serialport/framing.md). --- --- url: /zh/vbman/httpserver/session.md --- # Session 管理详解 ## 简介 `cHttpServerSession` 提供 HTTP 会话管理功能，支持三种存储方式： * **内存存储** (SessionStorageMemory) - 默认，进程内存储 * **文件系统** (SessionStorageFileSystem) - 持久化到文件 * **数据库存储** (SessionStorageDatabase) - 存储到数据库表 ## Session 存储类型配置 ```vb Public Enum EnumSessionStorageType SessionStorageMemory = 0 ' 内存存储（不持久化） SessionStorageFileSystem = 1 ' 文件系统存储 SessionStorageDatabase = 2 ' 数据库存储 End Enum ``` ## 快速开始 ### 1. 内存存储（默认） ```vb Private Sub Form_Load() Set Server = New cHttpServer ' 默认就是内存存储，无需配置 Server.SessionStorageType = SessionStorageMemory Call Server.Start(8080) End Sub ' 控制器中使用 Public Sub Login(ctx As cHttpServerContext) ' 登录成功后存储用户信息 ctx.Session("user_id") = "123" ctx.Session("username") = "张三" ctx.Session.TimeOut = 30 ' 30分钟超时 ctx.Response.Json Nothing, 0, "登录成功" End Sub Public Sub Profile(ctx As cHttpServerContext) ' 读取 Session Dim userId As String userId = ctx.Session("user_id") If userId = "" Then ctx.Response.State401 "未登录" Exit Sub End If Dim profile As New Dictionary profile("user_id") = userId profile("username") = ctx.Session("username") ctx.Response.Json profile End Sub Public Sub Logout(ctx As cHttpServerContext) ' 清除 Session ctx.Session.Abandon ctx.Response.Json Nothing, 0, "退出成功" End Sub ``` ### 2. 文件系统存储 ```vb Private Sub Form_Load() Set Server = New cHttpServer ' 配置文件存储 Server.SessionStorageType = SessionStorageFileSystem Server.SessionStoragePath = "C:\MyApp\Sessions" ' Session 文件保存目录 Server.SessionCookieName = "MY_SESSIONID" ' Cookie 名称 Call Server.Start(8080) End Sub ``` Session 文件格式（JSON）： ```json { "SessionID": "550e8400-e29b-41d4-a716-446655440000", "CreatedAt": "2026-05-17 10:30:00", "LastAccessedAt": "2026-05-17 10:35:00", "Timeout": 20, "Data": { "user_id": "123", "username": "张三" } } ``` ### 3. 数据库存储 ```vb Private Sub Form_Load() Set Server = New cHttpServer ' 配置数据库连接 If Server.Database.Connect(enumDbType.Mysql, "localhost,3306", "root", "password", "mydb") Then ' 配置数据库 Session 存储 Server.SessionStorageType = SessionStorageDatabase Server.SessionStoragePath = "user_sessions" ' 表名 Server.SessionCookieName = "SESSION_ID" Call Server.Start(8080) End If End Sub ``` **数据库表结构**： ```sql CREATE TABLE user_sessions ( SessionID VARCHAR(255) PRIMARY KEY, SessionData TEXT, CreatedAt DATETIME, LastAccessedAt DATETIME, ExpiresAt DATETIME, INDEX idx_expires (ExpiresAt) ); ``` ## Session 属性详解 ### Item (默认属性) 获取或设置 Session 数据。 ```vb ' 存储数据 ctx.Session("key") = "value" ctx.Session("user") = userObject ' 支持对象 ' 读取数据 Dim value As Variant value = ctx.Session("key") ' 检查存在性 If ctx.Session.Exists("key") Then ' ... End If ``` ### SessionID 获取 Session ID。注意：如果 Session 未写入过任何数据，`sessionID` 返回空字符串。 ```vb Debug.Print "Session ID: " & ctx.Session.SessionID ' 如果写入过数据，输出: 550e8400-e29b-41d4-a716-446655440000 ' 如果未写入数据，输出: （空字符串） ``` ### HasID 判断 Session 是否已生成 SessionID（即是否有实际数据被写入）。用于替代判断 `sessionID <> ""`。 ```vb ' 只有实际写入了数据的 Session 才会被持久化到 m_Sessions 和写入响应 Cookie If ctx.Session.HasID Then Debug.Print "Session 已激活: " & ctx.Session.SessionID End If ``` > **重要**：框架内部仅当 `Session.HasID = True` 时，才会将 Session 存入内存字典和写入响应 Cookie。未写入数据的空 Session 不会占用服务器内存，也不会发送 Session Cookie 给客户端。 ### TimeOut 超时时间（分钟），默认 20 分钟。 ```vb ' 设置 60 分钟超时 ctx.Session.TimeOut = 60 ' 0 表示永不过期 ctx.Session.TimeOut = 0 ``` ### CreatedAt 创建时间。 ```vb Debug.Print "创建时间: " & ctx.Session.CreatedAt ``` ### LastAccessedAt 最后访问时间。 ```vb Debug.Print "最后访问: " & ctx.Session.LastAccessedAt ``` ## Session 方法详解 ### Exists 检查键是否存在。 ```vb If ctx.Session.Exists("user_id") Then ' 用户已登录 Else ' 未登录 End If ``` ### Remove 删除指定键。 ```vb ' 删除单个键 ctx.Session.Remove("temp_data") ``` ### Clear 清空所有数据（保留 SessionID）。 ```vb ctx.Session.Clear ``` ### Abandon 放弃当前 Session（清空数据并生成新 SessionID）。 ```vb ' 退出登录时使用 ctx.Session.Abandon ``` ### IsExpired 检查 Session 是否已过期。 ```vb If ctx.Session.IsExpired Then ctx.Response.State401 "Session 已过期" End If ``` ### Touch 更新最后访问时间。 ```vb ' 手动刷新 Session 时间 ctx.Session.Touch ``` ## 完整登录示例 ```vb ' cAuthController.cls ' POST /login Public Sub Login(ctx As cHttpServerContext) Dim username As String, password As String username = ctx.Request.Form("username") password = ctx.Request.Form("password") ' 验证账号密码 If Not ValidateUser(username, password) Then ctx.Response.Json Nothing, 1, "用户名或密码错误" Exit Sub End If ' 获取用户信息 Dim user As Dictionary Set user = GetUserInfo(username) ' 存储到 Session ctx.Session("user_id") = user("id") ctx.Session("username") = user("username") ctx.Session("role") = user("role") ctx.Session.TimeOut = 120 ' 2小时 ' 返回用户信息 ctx.Response.Json user, 0, "登录成功" End Sub ' GET /logout Public Sub Logout(ctx As cHttpServerContext) ctx.Session.Abandon ctx.Response.Json Nothing, 0, "退出成功" End Sub ' GET /profile Public Sub Profile(ctx As cHttpServerContext) ' 检查登录状态 If Not ctx.Session.Exists("user_id") Then ctx.Response.State401 "请先登录" Exit Sub End If ' 返回用户信息 Dim profile As New Dictionary profile("user_id") = ctx.Session("user_id") profile("username") = ctx.Session("username") profile("role") = ctx.Session("role") ctx.Response.Json profile End Sub ' 辅助函数 Private Function ValidateUser(username As String, password As String) As Boolean ' 验证逻辑... ValidateUser = True End Function Private Function GetUserInfo(username As String) As Dictionary Dim user As New Dictionary user("id") = "123" user("username") = username user("role") = "admin" Set GetUserInfo = user End Function ``` ## Session 安全建议 1. **使用 HttpOnly Cookie**：防止 XSS 攻击 2. **设置合理超时时间**：不要过长 3. **使用 HTTPS**：防止 Session ID 被截获 4. **定期清理过期 Session**：文件/数据库存储需要清理任务 5. **敏感数据加密**：不要在 Session 中存储明文密码 ```vb ' 安全配置示例 ' 1. 设置 Cookie HttpOnly With ctx.Cookies.Cookie("SESSIONID") .HttpOnly = True .Secure = True ' HTTPS 下使用 .SameSite = "Strict" End With ' 2. Session 超时设置 ctx.Session.TimeOut = 20 ' 20分钟 ``` *** **最后更新**: 2026-05-17 --- --- url: /en/vbman/httpserver/session.md --- # Session Management Guide ## Overview `cHttpServerSession` provides HTTP session management functionality, supporting three storage types: * **Memory Storage** (SessionStorageMemory) - Default, in-process storage * **File System Storage** (SessionStorageFileSystem) - Persisted to file * **Database Storage** (SessionStorageDatabase) - Stored to database table ## Session Storage Type Configuration ```vb Public Enum EnumSessionStorageType SessionStorageMemory = 0 ' Memory storage (non-persistent) SessionStorageFileSystem = 1 ' File system storage SessionStorageDatabase = 2 ' Database storage End Enum ``` ## Quick Start ### 1. Memory Storage (Default) ```vb Private Sub Form_Load() Set Server = New cHttpServer ' Memory storage is default, no config needed Server.SessionStorageType = SessionStorageMemory Call Server.Start(8080) End Sub ' Usage in controller Public Sub Login(ctx As cHttpServerContext) ' Store user info after successful login ctx.Session("user_id") = "123" ctx.Session("username") = "John" ctx.Session.TimeOut = 30 ' 30 minutes timeout ctx.Response.Json Nothing, 0, "Login successful" End Sub Public Sub Profile(ctx As cHttpServerContext) ' Read session Dim userId As String userId = ctx.Session("user_id") If userId = "" Then ctx.Response.State401 "Not logged in" Exit Sub End If Dim profile As New Dictionary profile("user_id") = userId profile("username") = ctx.Session("username") ctx.Response.Json profile End Sub Public Sub Logout(ctx As cHttpServerContext) ' Clear session ctx.Session.Abandon ctx.Response.Json Nothing, 0, "Logout successful" End Sub ``` ### 2. File System Storage ```vb Private Sub Form_Load() Set Server = New cHttpServer ' Configure file storage Server.SessionStorageType = SessionStorageFileSystem Server.SessionStoragePath = "C:\MyApp\Sessions" ' Session file save directory Server.SessionCookieName = "MY_SESSIONID" ' Cookie name Call Server.Start(8080) End Sub ``` Session file format (JSON): ```json { "SessionID": "550e8400-e29b-41d4-a716-446655440000", "CreatedAt": "2026-05-17 10:30:00", "LastAccessedAt": "2026-05-17 10:35:00", "Timeout": 20, "Data": { "user_id": "123", "username": "John" } } ``` ### 3. Database Storage ```vb Private Sub Form_Load() Set Server = New cHttpServer ' Configure database connection If Server.Database.Connect(enumDbType.Mysql, "localhost,3306", "root", "password", "mydb") Then ' Configure database session storage Server.SessionStorageType = SessionStorageDatabase Server.SessionStoragePath = "user_sessions" ' Table name Server.SessionCookieName = "SESSION_ID" Call Server.Start(8080) End If End Sub ``` **Database table structure**: ```sql CREATE TABLE user_sessions ( SessionID VARCHAR(255) PRIMARY KEY, SessionData TEXT, CreatedAt DATETIME, LastAccessedAt DATETIME, ExpiresAt DATETIME, INDEX idx_expires (ExpiresAt) ); ``` ## Session Properties Explained ### Item (Default Property) Get or set session data. ```vb ' Store data ctx.Session("key") = "value" ctx.Session("user") = userObject ' Objects supported ' Read data Dim value As Variant value = ctx.Session("key") ' Check existence If ctx.Session.Exists("key") Then ' ... End If ``` ### SessionID Get session ID. Note: If no data has been written to the session, `sessionID` returns an empty string. ```vb Debug.Print "Session ID: " & ctx.Session.SessionID ' If data has been written: 550e8400-e29b-41d4-a716-446655440000 ' If no data written: (empty string) ``` ### HasID Check if a SessionID has been generated (i.e., whether actual data has been written). Used as a replacement for checking `sessionID <> ""`. ```vb ' Only sessions that have actually written data will be persisted to m_Sessions and have response cookies written If ctx.Session.HasID Then Debug.Print "Session activated: " & ctx.Session.SessionID End If ``` > **Important**: The framework internally only stores Session to the memory dictionary and writes response Cookie when `Session.HasID = True`. Empty sessions with no data written will not consume server memory or send Session Cookie to clients. ### TimeOut Timeout in minutes, default 20 minutes. ```vb ' Set 60 minutes timeout ctx.Session.TimeOut = 60 ' 0 means never expire ctx.Session.TimeOut = 0 ``` ### CreatedAt Creation time. ```vb Debug.Print "Created at: " & ctx.Session.CreatedAt ``` ### LastAccessedAt Last access time. ```vb Debug.Print "Last accessed: " & ctx.Session.LastAccessedAt ``` ## Session Methods Explained ### Exists Check if key exists. ```vb If ctx.Session.Exists("user_id") Then ' User is logged in Else ' Not logged in End If ``` ### Remove Delete specified key. ```vb ' Delete single key ctx.Session.Remove("temp_data") ``` ### Clear Clear all data (keep SessionID). ```vb ctx.Session.Clear ``` ### Abandon Abandon current session (clear data and generate new SessionID). ```vb ' Use when logging out ctx.Session.Abandon ``` ### IsExpired Check if session has expired. ```vb If ctx.Session.IsExpired Then ctx.Response.State401 "Session expired" End If ``` ### Touch Update last access time. ```vb ' Manually refresh session time ctx.Session.Touch ``` ## Complete Login Example ```vb ' cAuthController.cls ' POST /login Public Sub Login(ctx As cHttpServerContext) Dim username As String, password As String username = ctx.Request.Form("username") password = ctx.Request.Form("password") ' Validate credentials If Not ValidateUser(username, password) Then ctx.Response.Json Nothing, 1, "Invalid username or password" Exit Sub End If ' Get user info Dim user As Dictionary Set user = GetUserInfo(username) ' Store in session ctx.Session("user_id") = user("id") ctx.Session("username") = user("username") ctx.Session("role") = user("role") ctx.Session.TimeOut = 120 ' 2 hours ' Return user info ctx.Response.Json user, 0, "Login successful" End Sub ' GET /logout Public Sub Logout(ctx As cHttpServerContext) ctx.Session.Abandon ctx.Response.Json Nothing, 0, "Logout successful" End Sub ' GET /profile Public Sub Profile(ctx As cHttpServerContext) ' Check login status If Not ctx.Session.Exists("user_id") Then ctx.Response.State401 "Please login first" Exit Sub End If ' Return user info Dim profile As New Dictionary profile("user_id") = ctx.Session("user_id") profile("username") = ctx.Session("username") profile("role") = ctx.Session("role") ctx.Response.Json profile End Sub ' Helper functions Private Function ValidateUser(username As String, password As String) As Boolean ' Validation logic... ValidateUser = True End Function Private Function GetUserInfo(username As String) As Dictionary Dim user As New Dictionary user("id") = "123" user("username") = username user("role") = "admin" Set GetUserInfo = user End Function ``` ## Session Security Recommendations 1. **Use HttpOnly Cookie**: Prevent XSS attacks 2. **Set reasonable timeout**: Don't set too long 3. **Use HTTPS**: Prevent session ID interception 4. **Regular cleanup of expired sessions**: Cleanup tasks needed for file/database storage 5. **Encrypt sensitive data**: Don't store plaintext passwords in session ```vb ' Security configuration example ' 1. Set cookie HttpOnly With ctx.Cookies.Cookie("SESSIONID") .HttpOnly = True .Secure = True ' Use in HTTPS .SameSite = "Strict" End With ' 2. Session timeout setting ctx.Session.TimeOut = 20 ' 20 minutes ``` *** **Last Updated**: 2026-05-17 --- --- url: /zh/vbman/redis/set-operations.md --- # Set 操作 Redis Set 是无序的字符串集合，不允许重复元素。适合存储唯一值。 ## SAdd - 添加集合成员 ### 添加单个成员 ```vb oRedis.SAdd "myset", "apple" ``` ### 添加多个成员 ```vb oRedis.SAdd "myset", "banana", "orange", "grape" ``` **注意：** 集合会自动去重，重复添加相同元素只会保留一个。 ## SMembers - 获取所有集合成员 ```vb ' 获取所有成员 Dim vMembers As Variant vMembers = oRedis.SMembers("myset") If IsArray(vMembers) Then Dim i As Long For i = 0 To UBound(vMembers) Debug.Print vMembers(i) Next End If ``` ## SCard - 获取集合成员数量 ```vb Dim lCount As Long lCount = oRedis.SCard("myset") Debug.Print "集合成员数: " & lCount ``` ## SIsMember - 检查成员是否存在 ```vb If oRedis.SIsMember("myset", "apple") Then Debug.Print "成员存在" Else Debug.Print "成员不存在" End If ``` ## SRem - 删除集合成员 ```vb ' 删除单个成员 oRedis.SRem "myset", "apple" ' 删除多个成员 oRedis.SRem "myset", "banana", "orange" ``` ## 应用场景 ### 1. 文章标签 ```vb Sub ArticleTags() Dim oRedis As New cRedisClient If Not oRedis.Connect() Then Exit Sub Dim sArticleId As String sArticleId = "post:1:tags" ' 添加标签 oRedis.SAdd sArticleId, "技术", "编程", "Redis", "VB6", "数据库" ' 检查标签数量 Debug.Print "文章标签数: " & oRedis.SCard(sArticleId) ' 检查特定标签是否存在 If oRedis.SIsMember(sArticleId, "Redis") Then Debug.Print "这篇文章包含 Redis 标签" End If ' 获取所有标签 Dim vTags As Variant vTags = oRedis.SMembers(sArticleId) Debug.Print vbCrLf & "所有标签:" Dim i As Long If IsArray(vTags) Then For i = 0 To UBound(vTags) Debug.Print " - " & vTags(i) Next End If ' 删除某个标签 oRedis.SRem sArticleId, "VB6" Debug.Print vbCrLf & "删除标签后，剩余标签数: " & oRedis.SCard(sArticleId) oRedis.DisConnect End Sub ``` ### 2. 用户关注 ```vb Sub UserFollowers() Dim oRedis As New cRedisClient If Not oRedis.Connect() Then Exit Sub Dim sUserId As String sUserId = "user:123" ' 用户关注的人 oRedis.SAdd sUserId & ":following", "user:456", "user:789", "user:101" ' 关注用户的人 oRedis.SAdd sUserId & ":followers", "user:200", "user:300", "user:400" ' 检查是否关注了某用户 If oRedis.SIsMember(sUserId & ":following", "user:456") Then Debug.Print "已关注用户 456" End If ' 获取关注列表 Dim vFollowing As Variant vFollowing = oRedis.SMembers(sUserId & ":following") Debug.Print vbCrLf & "关注列表:" Dim i As Long If IsArray(vFollowing) Then For i = 0 To UBound(vFollowing) Debug.Print " " & vFollowing(i) Next End If ' 获取粉丝数 Debug.Print vbCrLf & "粉丝数: " & oRedis.SCard(sUserId & ":followers") ' 取消关注 oRedis.SRem sUserId & ":following", "user:789" Debug.Print "取消关注后，关注数: " & oRedis.SCard(sUserId & ":following") oRedis.DisConnect End Sub ``` ### 3. 在线用户 ```vb Sub OnlineUsers() Dim oRedis As New cRedisClient If Not oRedis.Connect() Then Exit Sub Dim sOnlineSet As String sOnlineSet = "users:online" ' 用户上线 oRedis.SAdd sOnlineSet, "user:1001", "user:1002", "user:1003", "user:1004" ' 获取在线用户数 Debug.Print "在线用户数: " & oRedis.SCard(sOnlineSet) ' 检查某用户是否在线 If oRedis.SIsMember(sOnlineSet, "user:1001") Then Debug.Print "用户 1001 在线" End If ' 获取所有在线用户 Dim vUsers As Variant vUsers = oRedis.SMembers(sOnlineSet) Debug.Print vbCrLf & "在线用户列表:" Dim i As Long If IsArray(vUsers) Then For i = 0 To UBound(vUsers) Debug.Print " " & vUsers(i) Next End If ' 用户下线 oRedis.SRem sOnlineSet, "user:1002" Debug.Print vbCrLf & "用户 1002 下线，在线用户数: " & oRedis.SCard(sOnlineSet) oRedis.DisConnect End Sub ``` ### 4. IP 黑名单 ```vb Sub IpBlacklist() Dim oRedis As New cRedisClient If Not oRedis.Connect() Then Exit Sub Dim sBlacklist As String sBlacklist = "security:blacklist" ' 添加 IP 到黑名单 oRedis.SAdd sBlacklist, "192.168.1.100" oRedis.SAdd sBlacklist, "192.168.1.101" oRedis.SAdd sBlacklist, "192.168.1.102" ' 检查 IP 是否在黑名单中 Dim sCheckIp As String sCheckIp = "192.168.1.100" If oRedis.SIsMember(sBlacklist, sCheckIp) Then Debug.Print "IP " & sCheckIp & " 在黑名单中，拒绝访问" Else Debug.Print "IP " & sCheckIp & " 可以访问" End If ' 获取黑名单中的所有 IP Dim vIps As Variant vIps = oRedis.SMembers(sBlacklist) Debug.Print vbCrLf & "黑名单中的 IP:" Dim i As Long If IsArray(vIps) Then For i = 0 To UBound(vIps) Debug.Print " " & vIps(i) Next End If ' 从黑名单移除 IP oRedis.SRem sBlacklist, "192.168.1.101" Debug.Print vbCrLf & "已将 192.168.1.101 从黑名单移除" oRedis.DisConnect End Sub ``` ### 5. 唯一访客统计 ```vb Sub UniqueVisitors() Dim oRedis As New cRedisClient If Not oRedis.Connect() Then Exit Sub Dim sDate As String sDate = "2024-01-01" Dim sVisitorKey As String sVisitorKey = "stats:visitors:" & sDate ' 记录访客 ID oRedis.SAdd sVisitorKey, "visitor:001" oRedis.SAdd sVisitorKey, "visitor:002" oRedis.SAdd sVisitorKey, "visitor:003" ' 同一访客再次访问（不会重复计数） oRedis.SAdd sVisitorKey, "visitor:001" oRedis.SAdd sVisitorKey, "visitor:002" ' 获取当日唯一访客数 Debug.Print sDate & " 的唯一访客数: " & oRedis.SCard(sVisitorKey) ' 获取所有访客 ID Dim vVisitors As Variant vVisitors = oRedis.SMembers(sVisitorKey) Debug.Print vbCrLf & "访客列表:" Dim i As Long If IsArray(vVisitors) Then For i = 0 To UBound(vVisitors) Debug.Print " " & vVisitors(i) Next End If oRedis.DisConnect End Sub ``` ### 6. 收藏夹 ```vb Sub Bookmarks() Dim oRedis As New cRedisClient If Not oRedis.Connect() Then Exit Sub Dim sUserId As String sUserId = "user:123" Dim sBookmarksKey As String sBookmarksKey = sUserId & ":bookmarks" ' 添加收藏 oRedis.SAdd sBookmarksKey, "article:1" oRedis.SAdd sBookmarksKey, "article:2" oRedis.SAdd sBookmarksKey, "article:3" ' 检查文章是否已收藏 If oRedis.SIsMember(sBookmarksKey, "article:1") Then Debug.Print "文章 1 已收藏" End If ' 获取收藏数 Debug.Print "收藏数: " & oRedis.SCard(sBookmarksKey) ' 获取所有收藏 Dim vBookmarks As Variant vBookmarks = oRedis.SMembers(sBookmarksKey) Debug.Print vbCrLf & "收藏列表:" Dim i As Long If IsArray(vBookmarks) Then For i = 0 To UBound(vBookmarks) Debug.Print " " & vBookmarks(i) Next End If ' 取消收藏 oRedis.SRem sBookmarksKey, "article:2" Debug.Print vbCrLf & "取消收藏后，剩余收藏数: " & oRedis.SCard(sBookmarksKey) oRedis.DisConnect End Sub ``` ## 完整示例 ```vb Sub Example_SetOperations() Dim oRedis As New cRedisClient If Not oRedis.Connect() Then Debug.Print "连接失败: " & oRedis.LastError Exit Sub End If ' 使用 Set 存储标签 oRedis.SAdd "post:1:tags", "技术", "编程", "Redis", "VB6" Debug.Print "文章标签数: " & oRedis.SCard("post:1:tags") Dim vTags As Variant vTags = oRedis.SMembers("post:1:tags") Debug.Print "所有标签:" Dim i As Long For i = 0 To UBound(vTags) Debug.Print " - " & vTags(i) Next ' 检查标签是否存在 If oRedis.SIsMember("post:1:tags", "Redis") Then Debug.Print vbCrLf & "包含 Redis 标签" End If ' 删除标签 oRedis.SRem "post:1:tags", "VB6" Debug.Print "删除标签后，剩余标签数: " & oRedis.SCard("post:1:tags") ' 再次添加（不会重复） oRedis.SAdd "post:1:tags", "编程" Debug.Print "再次添加 '编程' 后，标签数: " & oRedis.SCard("post:1:tags") oRedis.DisConnect End Sub ``` ## Set vs List 的选择 | 场景 | 推荐类型 | 原因 | |------|---------|------| | 需要唯一值 | Set | 自动去重 | | 允许重复 | List | 可以存储重复元素 | | 成员检查 | Set | O(1) 时间复杂度 | | 按顺序存储 | List | 保持插入顺序 | | 去重需求 | Set | 集合天然支持去重 | | 栈/队列 | List | 支持 LPush/LPop/RPush/RPop | ## Set 特性 1. **无序**：成员没有顺序之分 2. **唯一**：不允许重复元素 3. **快速查找**：检查成员是否存在非常快 4. **集合运算**：支持交集、并集、差集等运算（需要扩展实现） --- --- url: /en/vbman/redis/set-operations.md --- # Set Operations Redis Set is an unordered collection of unique strings, suitable for storing unique values. ## SAdd - Add Set Members ### Add Single Member ```vb oRedis.SAdd "myset", "apple" ``` ### Add Multiple Members ```vb oRedis.SAdd "myset", "banana", "orange", "grape" ``` **Note:** Sets automatically deduplicate, adding duplicate elements will only keep one. ## SMembers - Get All Set Members ```vb ' Get all members Dim vMembers As Variant vMembers = oRedis.SMembers("myset") If IsArray(vMembers) Then Dim i As Long For i = 0 To UBound(vMembers) Debug.Print vMembers(i) Next End If ``` ## SCard - Get Set Member Count ```vb Dim lCount As Long lCount = oRedis.SCard("myset") Debug.Print "Set member count: " & lCount ``` ## SIsMember - Check if Member Exists ```vb If oRedis.SIsMember("myset", "apple") Then Debug.Print "Member exists" Else Debug.Print "Member does not exist" End If ``` ## SRem - Delete Set Members ```vb ' Delete single member oRedis.SRem "myset", "apple" ' Delete multiple members oRedis.SRem "myset", "banana", "orange" ``` ## Use Cases ### 1. Article Tags ```vb Sub ArticleTags() Dim oRedis As New cRedisClient If Not oRedis.Connect() Then Exit Sub Dim sArticleId As String sArticleId = "post:1:tags" ' Add tags oRedis.SAdd sArticleId, "Technology", "Programming", "Redis", "VB6", "Database" ' Check tag count Debug.Print "Article tags count: " & oRedis.SCard(sArticleId) ' Check if specific tag exists If oRedis.SIsMember(sArticleId, "Redis") Then Debug.Print "This article contains Redis tag" End If ' Get all tags Dim vTags As Variant vTags = oRedis.SMembers(sArticleId) Debug.Print vbCrLf & "All tags:" Dim i As Long If IsArray(vTags) Then For i = 0 To UBound(vTags) Debug.Print " - " & vTags(i) Next End If ' Delete specific tag oRedis.SRem sArticleId, "VB6" Debug.Print vbCrLf & "After deleting tag, remaining tags count: " & oRedis.SCard(sArticleId) oRedis.DisConnect End Sub ``` ### 2. User Following ```vb Sub UserFollowers() Dim oRedis As New cRedisClient If Not oRedis.Connect() Then Exit Sub Dim sUserId As String sUserId = "user:123" ' Users this user follows oRedis.SAdd sUserId & ":following", "user:456", "user:789", "user:101" ' Users following this user oRedis.SAdd sUserId & ":followers", "user:200", "user:300", "user:400" ' Check if following specific user If oRedis.SIsMember(sUserId & ":following", "user:456") Then Debug.Print "Already following user 456" End If ' Get following list Dim vFollowing As Variant vFollowing = oRedis.SMembers(sUserId & ":following") Debug.Print vbCrLf & "Following list:" Dim i As Long If IsArray(vFollowing) Then For i = 0 To UBound(vFollowing) Debug.Print " " & vFollowing(i) Next End If ' Get follower count Debug.Print vbCrLf & "Follower count: " & oRedis.SCard(sUserId & ":followers") ' Unfollow oRedis.SRem sUserId & ":following", "user:789" Debug.Print "After unfollowing, following count: " & oRedis.SCard(sUserId & ":following") oRedis.DisConnect End Sub ``` ### 3. Online Users ```vb Sub OnlineUsers() Dim oRedis As New cRedisClient If Not oRedis.Connect() Then Exit Sub Dim sOnlineSet As String sOnlineSet = "users:online" ' Users come online oRedis.SAdd sOnlineSet, "user:1001", "user:1002", "user:1003", "user:1004" ' Get online user count Debug.Print "Online users count: " & oRedis.SCard(sOnlineSet) ' Check if specific user is online If oRedis.SIsMember(sOnlineSet, "user:1001") Then Debug.Print "User 1001 is online" End If ' Get all online users Dim vUsers As Variant vUsers = oRedis.SMembers(sOnlineSet) Debug.Print vbCrLf & "Online user list:" Dim i As Long If IsArray(vUsers) Then For i = 0 To UBound(vUsers) Debug.Print " " & vUsers(i) Next End If ' User goes offline oRedis.SRem sOnlineSet, "user:1002" Debug.Print vbCrLf & "User 1002 offline, online users count: " & oRedis.SCard(sOnlineSet) oRedis.DisConnect End Sub ``` ### 4. IP Blacklist ```vb Sub IpBlacklist() Dim oRedis As New cRedisClient If Not oRedis.Connect() Then Exit Sub Dim sBlacklist As String sBlacklist = "security:blacklist" ' Add IP to blacklist oRedis.SAdd sBlacklist, "192.168.1.100" oRedis.SAdd sBlacklist, "192.168.1.101" oRedis.SAdd sBlacklist, "192.168.1.102" ' Check if IP is in blacklist Dim sCheckIp As String sCheckIp = "192.168.1.100" If oRedis.SIsMember(sBlacklist, sCheckIp) Then Debug.Print "IP " & sCheckIp & " is in blacklist, access denied" Else Debug.Print "IP " & sCheckIp & " can access" End If ' Get all IPs in blacklist Dim vIps As Variant vIps = oRedis.SMembers(sBlacklist) Debug.Print vbCrLf & "IPs in blacklist:" Dim i As Long If IsArray(vIps) Then For i = 0 To UBound(vIps) Debug.Print " " & vIps(i) Next End If ' Remove IP from blacklist oRedis.SRem sBlacklist, "192.168.1.101" Debug.Print vbCrLf & "Removed 192.168.1.101 from blacklist" oRedis.DisConnect End Sub ``` ### 5. Unique Visitor Statistics ```vb Sub UniqueVisitors() Dim oRedis As New cRedisClient If Not oRedis.Connect() Then Exit Sub Dim sDate As String sDate = "2024-01-01" Dim sVisitorKey As String sVisitorKey = "stats:visitors:" & sDate ' Record visitor IDs oRedis.SAdd sVisitorKey, "visitor:001" oRedis.SAdd sVisitorKey, "visitor:002" oRedis.SAdd sVisitorKey, "visitor:003" ' Same visitor visits again (will not count again) oRedis.SAdd sVisitorKey, "visitor:001" oRedis.SAdd sVisitorKey, "visitor:002" ' Get unique visitor count for the day Debug.Print sDate & " unique visitors: " & oRedis.SCard(sVisitorKey) ' Get all visitor IDs Dim vVisitors As Variant vVisitors = oRedis.SMembers(sVisitorKey) Debug.Print vbCrLf & "Visitor list:" Dim i As Long If IsArray(vVisitors) Then For i = 0 To UBound(vVisitors) Debug.Print " " & vVisitors(i) Next End If oRedis.DisConnect End Sub ``` ### 6. Bookmarks ```vb Sub Bookmarks() Dim oRedis As New cRedisClient If Not oRedis.Connect() Then Exit Sub Dim sUserId As String sUserId = "user:123" Dim sBookmarksKey As String sBookmarksKey = sUserId & ":bookmarks" ' Add bookmarks oRedis.SAdd sBookmarksKey, "article:1" oRedis.SAdd sBookmarksKey, "article:2" oRedis.SAdd sBookmarksKey, "article:3" ' Check if article is bookmarked If oRedis.SIsMember(sBookmarksKey, "article:1") Then Debug.Print "Article 1 is bookmarked" End If ' Get bookmark count Debug.Print "Bookmark count: " & oRedis.SCard(sBookmarksKey) ' Get all bookmarks Dim vBookmarks As Variant vBookmarks = oRedis.SMembers(sBookmarksKey) Debug.Print vbCrLf & "Bookmark list:" Dim i As Long If IsArray(vBookmarks) Then For i = 0 To UBound(vBookmarks) Debug.Print " " & vBookmarks(i) Next End If ' Remove bookmark oRedis.SRem sBookmarksKey, "article:2" Debug.Print vbCrLf & "After removing bookmark, remaining count: " & oRedis.SCard(sBookmarksKey) oRedis.DisConnect End Sub ``` ## Complete Example ```vb Sub Example_SetOperations() Dim oRedis As New cRedisClient If Not oRedis.Connect() Then Debug.Print "Connection failed: " & oRedis.LastError Exit Sub End If ' Use Set to store tags oRedis.SAdd "post:1:tags", "Technology", "Programming", "Redis", "VB6" Debug.Print "Article tags count: " & oRedis.SCard("post:1:tags") Dim vTags As Variant vTags = oRedis.SMembers("post:1:tags") Debug.Print "All tags:" Dim i As Long For i = 0 To UBound(vTags) Debug.Print " - " & vTags(i) Next ' Check if tag exists If oRedis.SIsMember("post:1:tags", "Redis") Then Debug.Print vbCrLf & "Contains Redis tag" End If ' Delete tag oRedis.SRem "post:1:tags", "VB6" Debug.Print "After deleting tag, remaining tags count: " & oRedis.SCard("post:1:tags") ' Add again (will not duplicate) oRedis.SAdd "post:1:tags", "Programming" Debug.Print "After adding 'Programming' again, tags count: " & oRedis.SCard("post:1:tags") oRedis.DisConnect End Sub ``` ## Set vs List Selection | Scenario | Recommended Type | Reason | | -------------------- | ---------------- | --------------------------------- | | Need unique values | Set | Automatic deduplication | | Allow duplicates | List | Can store duplicate elements | | Member check | Set | O(1) time complexity | | Store in order | List | Maintain insertion order | | Deduplication needed | Set | Sets naturally support dedup | | Stack/Queue | List | Supports LPush/LPop/RPush/RPop | ## Set Features 1. **Unordered**: Members have no order 2. **Unique**: Duplicate elements not allowed 3. **Fast lookup**: Very fast to check member existence 4. **Set operations**: Supports intersection, union, difference operations (requires extended implementation) --- --- url: /en/packages/vbccr/ranges/slider.md description: >- Slider Control - VBCCR Development Manual, complete API reference based on source code --- # Slider Control Provides a customizable slider control supporting horizontal/vertical orientation, tick styles, selection range, owner-draw, and OLE drag-and-drop. ## Enumerations ### SldOrientationConstants Control orientation constants. | Constant | Value | Description | |----------|-------|-------------| | SldOrientationHorizontal | 0 | Horizontal orientation | | SldOrientationVertical | 1 | Vertical orientation | ### SldTipSideConstants Tooltip position constants. | Constant | Value | Description | |----------|-------|-------------| | SldTipSideAboveLeft | 0 | Tooltip displayed above/left | | SldTipSideBelowRight | 1 | Tooltip displayed below/right | ### SldTickStyleConstants Tick style constants. | Constant | Value | Description | |----------|-------|-------------| | SldTickStyleBottomRight | 0 | Bottom/right ticks | | SldTickStyleTopLeft | 1 | Top/left ticks | | SldTickStyleBoth | 2 | Ticks on both sides | | SldTickStyleNone | 3 | No ticks | ### SldDrawModeConstants Draw mode constants. | Constant | Value | Description | |----------|-------|-------------| | SldDrawModeNormal | 0 | Normal drawing | | SldDrawModeOwnerDraw | 1 | Owner-draw mode | ### SldOwnerDrawItemConstants Owner-draw item constants. | Constant | Value | Description | |----------|-------|-------------| | SldOwnerDrawItemTics | 1 | Tick marks | | SldOwnerDrawItemThumb | 2 | Slider thumb | | SldOwnerDrawItemChannel | 3 | Channel | ## Properties ### Name ```vb Public Property Get Name() As String ``` Returns the name used to identify the object in code. ### Tag ```vb Public Property Get Tag() As String Public Property Let Tag(ByVal Value As String) ``` Stores extra data needed by the program. ### Parent ```vb Public Property Get Parent() As Object ``` Returns the object that contains this object. ### Container ```vb Public Property Get Container() As Object Public Property Set Container(ByVal Value As Object) ``` Returns/sets the container of the object. ### Left ```vb Public Property Get Left() As Single Public Property Let Left(ByVal Value As Single) ``` Returns/sets the distance between the left edge of the object and the left edge of its container. ### Top ```vb Public Property Get Top() As Single Public Property Let Top(ByVal Value As Single) ``` Returns/sets the distance between the top edge of the object and the top edge of its container. ### Width ```vb Public Property Get Width() As Single Public Property Let Width(ByVal Value As Single) ``` Returns/sets the width of the object. ### Height ```vb Public Property Get Height() As Single Public Property Let Height(ByVal Value As Single) ``` Returns/sets the height of the object. ### Visible ```vb Public Property Get Visible() As Boolean Public Property Let Visible(ByVal Value As Boolean) ``` Returns/sets whether the object is visible. ### ToolTipText ```vb Public Property Get ToolTipText() As String Public Property Let ToolTipText(ByVal Value As String) ``` Returns/sets the tooltip text displayed when the mouse hovers. ### HelpContextID ```vb Public Property Get HelpContextID() As Long Public Property Let HelpContextID(ByVal Value As Long) ``` Returns/sets the associated context help ID. ### WhatsThisHelpID ```vb Public Property Get WhatsThisHelpID() As Long Public Property Let WhatsThisHelpID(ByVal Value As Long) ``` Returns/sets the associated context help ID. ### DragIcon ```vb Public Property Get DragIcon() As IPictureDisp Public Property Let DragIcon(ByVal Value As IPictureDisp) Public Property Set DragIcon(ByVal Value As IPictureDisp) ``` Returns/sets the icon displayed during a drag-and-drop operation. ### DragMode ```vb Public Property Get DragMode() As Integer Public Property Let DragMode(ByVal Value As Integer) ``` Returns/sets the drag mode. ### hWnd ```vb Public Property Get hWnd() As LongPtr ``` Returns the control handle. ### hWndUserControl ```vb Public Property Get hWndUserControl() As LongPtr ``` Returns the UserControl handle. ### VisualStyles ```vb Public Property Get VisualStyles() As Boolean Public Property Let VisualStyles(ByVal Value As Boolean) ``` Returns/sets whether visual styles are enabled. Requires comctl32.dll version 6.0 or later. ### BackColor ```vb Public Property Get BackColor() As OLE_COLOR Public Property Let BackColor(ByVal Value As OLE_COLOR) ``` Returns/sets the background color. ### Enabled ```vb Public Property Get Enabled() As Boolean Public Property Let Enabled(ByVal Value As Boolean) ``` Returns/sets whether the object can respond to user events. ### OLEDropMode ```vb Public Property Get OLEDropMode() As OLEDropModeConstants Public Property Let OLEDropMode(ByVal Value As OLEDropModeConstants) ``` Returns/sets whether the object can act as an OLE drop target. ### MousePointer ```vb Public Property Get MousePointer() As CCMousePointerConstants Public Property Let MousePointer(ByVal Value As CCMousePointerConstants) ``` Returns/sets the type of mouse pointer displayed when hovering. See common enumerations. ### MouseIcon ```vb Public Property Get MouseIcon() As IPictureDisp Public Property Let MouseIcon(ByVal Value As IPictureDisp) Public Property Set MouseIcon(ByVal Value As IPictureDisp) ``` Returns/sets the custom mouse icon. ### MouseTrack ```vb Public Property Get MouseTrack() As Boolean Public Property Let MouseTrack(ByVal Value As Boolean) ``` Returns/sets whether events are fired when the mouse enters or leaves the control. ### RightToLeft ```vb Public Property Get RightToLeft() As Boolean Public Property Let RightToLeft(ByVal Value As Boolean) ``` Returns/sets the right-to-left display direction. ### RightToLeftLayout ```vb Public Property Get RightToLeftLayout() As Boolean Public Property Let RightToLeftLayout(ByVal Value As Boolean) ``` Returns/sets the right-to-left layout. ### RightToLeftMode ```vb Public Property Get RightToLeftMode() As CCRightToLeftModeConstants Public Property Let RightToLeftMode(ByVal Value As CCRightToLeftModeConstants) ``` Returns/sets the right-to-left mode. See common enumerations. ### Min ```vb Public Property Get Min() As Long Public Property Let Min(ByVal Value As Long) ``` Returns/sets the minimum value. ### Max ```vb Public Property Get Max() As Long Public Property Let Max(ByVal Value As Long) ``` Returns/sets the maximum value. ### Value ```vb Public Property Get Value() As Long Public Property Let Value(ByVal NewValue As Long) ``` Returns/sets the current value. ### TickFrequency ```vb Public Property Get TickFrequency() As Long Public Property Let TickFrequency(ByVal Value As Long) ``` Returns/sets the tick frequency. ### Orientation ```vb Public Property Get Orientation() As SldOrientationConstants Public Property Let Orientation(ByVal Value As SldOrientationConstants) ``` Returns/sets the control orientation. ### SmallChange ```vb Public Property Get SmallChange() As Long Public Property Let SmallChange(ByVal Value As Long) ``` Returns/sets the change amount when pressing arrow keys. ### LargeChange ```vb Public Property Get LargeChange() As Long Public Property Let LargeChange(ByVal Value As Long) ``` Returns/sets the change amount when pressing PageUp/PageDown or clicking the channel. ### TickStyle ```vb Public Property Get TickStyle() As SldTickStyleConstants Public Property Let TickStyle(ByVal Value As SldTickStyleConstants) ``` Returns/sets the tick style. ### ShowTip ```vb Public Property Get ShowTip() As Boolean Public Property Let ShowTip(ByVal Value As Boolean) ``` Returns/sets whether to display the value tooltip. ### TipSide ```vb Public Property Get TipSide() As SldTipSideConstants Public Property Let TipSide(ByVal Value As SldTipSideConstants) ``` Returns/sets the tooltip display position. ### SelectRange ```vb Public Property Get SelectRange() As Boolean Public Property Let SelectRange(ByVal Value As Boolean) ``` Returns/sets whether selection range is enabled. ### SelStart ```vb Public Property Get SelStart() As Long Public Property Let SelStart(ByVal Value As Long) ``` Returns/sets the start position of the selection range. ### SelLength ```vb Public Property Get SelLength() As Long Public Property Let SelLength(ByVal Value As Long) ``` Returns/sets the length of the selection range. ### Transparent ```vb Public Property Get Transparent() As Boolean Public Property Let Transparent(ByVal Value As Boolean) ``` Returns/sets whether the control background is transparent. ### HideThumb ```vb Public Property Get HideThumb() As Boolean Public Property Let HideThumb(ByVal Value As Boolean) ``` Returns/sets whether the slider thumb is hidden. ### Reversed ```vb Public Property Get Reversed() As Boolean Public Property Let Reversed(ByVal Value As Boolean) ``` Returns/sets whether the slider direction is reversed. ### DrawMode ```vb Public Property Get DrawMode() As SldDrawModeConstants Public Property Let DrawMode(ByVal Value As SldDrawModeConstants) ``` Returns/sets the draw mode. ### ThumbLeft ```vb Public Property Get ThumbLeft() As Single ``` Returns the left position of the thumb. ### ThumbTop ```vb Public Property Get ThumbTop() As Single ``` Returns the top position of the thumb. ### ThumbWidth ```vb Public Property Get ThumbWidth() As Single ``` Returns the width of the thumb. ### ThumbHeight ```vb Public Property Get ThumbHeight() As Single ``` Returns the height of the thumb. ### ChannelLeft ```vb Public Property Get ChannelLeft() As Single ``` Returns the left position of the channel. ### ChannelTop ```vb Public Property Get ChannelTop() As Single ``` Returns the top position of the channel. ### ChannelWidth ```vb Public Property Get ChannelWidth() As Single ``` Returns the width of the channel. ### ChannelHeight ```vb Public Property Get ChannelHeight() As Single ``` Returns the height of the channel. ## Methods ### Refresh ```vb Public Sub Refresh() ``` Forces a complete repaint of the object. ### ClearSel ```vb Public Sub ClearSel() ``` Clears the selection range. ### GetNumTicks ```vb Public Function GetNumTicks() As Long ``` Returns the number of ticks. ### GetTickPosition ```vb Public Function GetTickPosition(ByVal Index As Long) As Single ``` Returns the position of the specified tick. ### OLEDrag ```vb Public Sub OLEDrag() ``` Initiates an OLE drag-and-drop operation. ### Drag ```vb Public Sub Drag(Optional ByRef Action As Variant) ``` Starts, ends, or cancels a drag operation. ### SetFocus ```vb Public Sub SetFocus() ``` Moves focus to the control. ### ZOrder ```vb Public Sub ZOrder(Optional ByRef Position As Variant) ``` Sets the Z-order. ## Events ### Click ```vb Public Event Click() ``` Fired when the user clicks the control. ### Scroll ```vb Public Event Scroll() ``` Fired when the user drags the slider thumb. ### Change ```vb Public Event Change() ``` Fired after the value changes. ### ContextMenu ```vb Public Event ContextMenu(ByVal X As Single, ByVal Y As Single) ``` Fired when the control is right-clicked. ### ModifyTipText ```vb Public Event ModifyTipText(ByRef Text As String) ``` Fired when the tooltip text is about to be displayed, allowing modification of the tooltip text. ### ItemDraw ```vb Public Event ItemDraw(ByVal Item As SldOwnerDrawItemConstants, ByRef Cancel As Boolean, ByVal ItemState As Long, ByVal hDC As Long, ByVal Left As Long, ByVal Top As Long, ByVal Right As Long, ByVal Bottom As Long) ``` Fired when an owner-draw item needs to be drawn. Item is the owner-draw item type, Cancel can cancel default drawing, hDC is the device context. ### PreviewKeyDown ```vb Public Event PreviewKeyDown(ByVal KeyCode As Integer, ByRef IsInputKey As Boolean) ``` Preview before key down. IsInputKey being True indicates the key is an input key. ### PreviewKeyUp ```vb Public Event PreviewKeyUp(ByVal KeyCode As Integer, ByRef IsInputKey As Boolean) ``` Preview before key up. ### KeyDown ```vb Public Event KeyDown(KeyCode As Integer, Shift As Integer) ``` Fired when a keyboard key is pressed. ### KeyUp ```vb Public Event KeyUp(KeyCode As Integer, Shift As Integer) ``` Fired when a keyboard key is released. ### KeyPress ```vb Public Event KeyPress(KeyChar As Integer) ``` Fired when an ANSI key is pressed and released. ### MouseDown ```vb Public Event MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` Fired when a mouse button is pressed. ### MouseMove ```vb Public Event MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` Fired when the mouse is moved. ### MouseUp ```vb Public Event MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` Fired when a mouse button is released. ### MouseEnter ```vb Public Event MouseEnter() ``` Fired when the mouse enters the control area. ### MouseLeave ```vb Public Event MouseLeave() ``` Fired when the mouse leaves the control area. ### OLECompleteDrag ```vb Public Event OLECompleteDrag(Effect As Long) ``` Fired when an OLE drag-and-drop operation completes. ### OLEDragDrop ```vb Public Event OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single) ``` Fired when data is dropped via an OLE drag-and-drop operation. ### OLEDragOver ```vb Public Event OLEDragOver(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single, State As Integer) ``` Fired when the mouse hovers during an OLE drag-and-drop operation. ### OLEGiveFeedback ```vb Public Event OLEGiveFeedback(Effect As Long, DefaultCursors As Boolean) ``` Fired when an OLE drag-and-drop operation gives feedback. ### OLESetData ```vb Public Event OLESetData(Data As DataObject, DataFormat As Integer) ``` Fired when an OLE drag-and-drop operation sets data. ### OLEStartDrag ```vb Public Event OLEStartDrag(Data As DataObject, AllowedEffects As Long) ``` Fired when an OLE drag-and-drop operation starts. ## Code Examples ### Basic Usage ```vb ' Set up the slider control With Slider1 .Min = 0 .Max = 100 .Value = 50 .TickFrequency = 10 .SmallChange = 1 .LargeChange = 10 .SelectRange = True .SelStart = 20 .SelLength = 60 End With ' Respond to value change Private Sub Slider1_Change() Debug.Print "Current value: " & Slider1.Value End Sub ' Customize tooltip text Private Sub Slider1_ModifyTipText(ByRef Text As String) Text = "Progress: " & Slider1.Value & "%" End Sub ``` --- --- url: /zh/vbman/redis/sorted-set-operations.md --- # Sorted Set 操作 Redis Sorted Set 是有序集合，每个成员关联一个分数（score）。集合根据分数进行排序。 ## ZAdd - 添加有序集合成员 ### 添加带分数的成员 ```vb oRedis.ZAdd "mysortedset", 100, "member1" oRedis.ZAdd "mysortedset", 200, "member2" oRedis.ZAdd "mysortedset", 150, "member3" ``` **注意：** * 分数可以是整数或浮点数 * 相同分数的成员按字典序排序 * 如果成员已存在，会更新其分数 ## ZRange - 获取范围内的成员 ### 获取所有成员（按分数升序） ```vb Dim vMembers As Variant vMembers = oRedis.ZRange("mysortedset", 0, -1) If IsArray(vMembers) Then Dim i As Long For i = 0 To UBound(vMembers) Debug.Print vMembers(i) Next End If ``` ### 获取带分数的成员 ```vb vMembers = oRedis.ZRange("mysortedset", 0, -1, True) If IsArray(vMembers) Then For i = 0 To UBound(vMembers) Step 2 If i + 1 <= UBound(vMembers) Then Debug.Print vMembers(i) & ": " & vMembers(i + 1) End If Next End If ``` ### 获取前 N 名 ```vb ' 获取前 3 名（分数最低的 3 个） vMembers = oRedis.ZRange("mysortedset", 0, 2) ``` ### 获取最后 N 名 ```vb ' 获取最后 3 名（分数最高的 3 个） vMembers = oRedis.ZRange("mysortedset", -3, -1) ``` ## ZRem - 删除有序集合成员 ```vb ' 删除单个成员 oRedis.ZRem "mysortedset", "member1" ' 删除多个成员 oRedis.ZRem "mysortedset", "member2", "member3" ``` ## ZCard - 获取有序集合成员数量 ```vb Dim lCount As Long lCount = oRedis.ZCard("mysortedset") Debug.Print "有序集合成员数: " & lCount ``` ## 应用场景 ### 1. 排行榜 ```vb Sub Leaderboard() Dim oRedis As New cRedisClient If Not oRedis.Connect() Then Exit Sub Dim sLeaderboard As String sLeaderboard = "leaderboard" ' 添加玩家分数 oRedis.ZAdd sLeaderboard, 1000, "玩家A" oRedis.ZAdd sLeaderboard, 1500, "玩家B" oRedis.ZAdd sLeaderboard, 800, "玩家C" oRedis.ZAdd sLeaderboard, 2000, "玩家D" oRedis.ZAdd sLeaderboard, 1200, "玩家E" ' 获取排行榜（按分数升序） Dim vRanking As Variant vRanking = oRedis.ZRange(sLeaderboard, 0, -1) Debug.Print "排行榜（升序）:" Dim i As Long If IsArray(vRanking) Then For i = 0 To UBound(vRanking) Debug.Print " " & (i + 1) & ". " & vRanking(i) Next End If ' 获取排行榜（带分数） vRanking = oRedis.ZRange(sLeaderboard, 0, -1, True) Debug.Print vbCrLf & "排行榜（带分数）:" If IsArray(vRanking) Then For i = 0 To UBound(vRanking) Step 2 If i + 1 <= UBound(vRanking) Then Debug.Print " " & vRanking(i) & ": " & vRanking(i + 1) & " 分" End If Next End If ' 获取前 3 名 vRanking = oRedis.ZRange(sLeaderboard, 0, 2, True) Debug.Print vbCrLf & "前 3 名:" If IsArray(vRanking) Then For i = 0 To UBound(vRanking) Step 2 If i + 1 <= UBound(vRanking) Then Debug.Print " 第 " & (i / 2 + 1) & " 名: " & vRanking(i) & " (" & vRanking(i + 1) & " 分)" End If Next End If ' 更新玩家分数 oRedis.ZAdd sLeaderboard, 2500, "玩家A" Debug.Print vbCrLf & "更新玩家A分数后:" vRanking = oRedis.ZRange(sLeaderboard, -1, -1, True) If IsArray(vRanking) Then Debug.Print " 第一名: " & vRanking(0) & " (" & vRanking(1) & " 分)" End If oRedis.DisConnect End Sub ``` ### 2. 时间轴 ```vb Sub Timeline() Dim oRedis As New cRedisClient If Not oRedis.Connect() Then Exit Sub Dim sTimeline As String sTimeline = "timeline:events" ' 添加事件（使用时间戳作为分数） oRedis.ZAdd sTimeline, 1640995200, "事件1: 项目启动" oRedis.ZAdd sTimeline, 1640995800, "事件2: 需求分析" oRedis.ZAdd sTimeline, 1640996400, "事件3: 设计完成" oRedis.ZAdd sTimeline, 1640997000, "事件4: 开始开发" oRedis.ZAdd sTimeline, 1640997600, "事件5: 测试阶段" ' 获取按时间排序的事件 Dim vEvents As Variant vEvents = oRedis.ZRange(sTimeline, 0, -1, True) Debug.Print "时间轴:" Dim i As Long If IsArray(vEvents) Then For i = 0 To UBound(vEvents) Step 2 If i + 1 <= UBound(vEvents) Then Dim lTimestamp As Long lTimestamp = CLng(vEvents(i + 1)) Debug.Print " " & FormatDateTime(lTimestamp) & " - " & vEvents(i) End If Next End If oRedis.DisConnect End Sub Function FormatDateTime(ByVal lTimestamp As Long) As String ' 将 Unix 时间戳转换为日期时间字符串 Dim dtDate As Date dtDate = DateAdd("s", lTimestamp, #1/1/1970#) FormatDateTime = Format(dtDate, "yyyy-mm-dd hh:nn:ss") End Function ``` ### 3. 延迟队列 ```vb Sub DelayedQueue() Dim oRedis As New cRedisClient If Not oRedis.Connect() Then Exit Sub Dim sQueue As String sQueue = "queue:delayed" ' 添加任务（使用执行时间作为分数） Dim lNow As Long lNow = Timer ' 当前秒数（简化） oRedis.ZAdd sQueue, lNow + 60, "任务1: 1分钟后执行" oRedis.ZAdd sQueue, lNow + 120, "任务2: 2分钟后执行" oRedis.ZAdd sQueue, lNow + 30, "任务3: 30秒后执行" ' 模拟时间流逝 Dim i As Long For i = 1 To 5 lNow = Timer ' 获取到期的任务 Dim vTasks As Variant vTasks = oRedis.ZRange(sQueue, 0, 0, True) If IsArray(vTasks) And UBound(vTasks) >= 1 Then Dim lTaskTime As Long lTaskTime = CLng(vTasks(1)) If lTaskTime <= lNow Then Debug.Print "执行任务: " & vTasks(0) oRedis.ZRem sQueue, vTasks(0) End If End If ' 等待一秒 Application.Wait (Now + TimeValue("0:00:01")) Next oRedis.DisConnect End Sub ``` ### 4. 热度排行 ```vb Sub HotArticles() Dim oRedis As New cRedisClient If Not oRedis.Connect() Then Exit Sub Dim sHotKey As String sHotKey = "hot:articles" ' 模拟文章浏览量 oRedis.ZAdd sHotKey, 1000, "article:1" oRedis.ZAdd sHotKey, 2500, "article:2" oRedis.ZAdd sHotKey, 800, "article:3" oRedis.ZAdd sHotKey, 3000, "article:4" oRedis.ZAdd sHotKey, 1500, "article:5" ' 获取热门文章 TOP 10 Dim vHotArticles As Variant vHotArticles = oRedis.ZRange(sHotKey, -10, -1, True) Debug.Print "热门文章 TOP 10:" Dim i As Long, lIndex As Long lIndex = 1 If IsArray(vHotArticles) Then For i = UBound(vHotArticles) To 0 Step -2 If i - 1 >= 0 Then Debug.Print " " & lIndex & ". " & vHotArticles(i - 1) & " (" & vHotArticles(i) & " 浏览)" lIndex = lIndex + 1 End If Next End If ' 文章被浏览，增加热度 Dim sArticle As String sArticle = "article:1" ' 获取当前分数 Dim lCurrentScore As Long lCurrentScore = CLng(oRedis.Get_(sArticle)) lCurrentScore = lCurrentScore + 1 ' 更新分数 oRedis.ZAdd sHotKey, lCurrentScore, sArticle Debug.Print vbCrLf & "文章 " & sArticle & " 浏览后热度更新" oRedis.DisConnect End Sub ``` ### 5. 优先级队列 ```vb Sub PriorityQueue() Dim oRedis As New cRedisClient If Not oRedis.Connect() Then Exit Sub Dim sQueue As String sQueue = "queue:priority" ' 添加任务（使用优先级作为分数，优先级越高分数越小） oRedis.ZAdd sQueue, 1, "紧急任务: 修复生产环境bug" oRedis.ZAdd sQueue, 3, "普通任务: 编写文档" oRedis.ZAdd sQueue, 2, "重要任务: 代码审查" oRedis.ZAdd sQueue, 1, "紧急任务: 数据库维护" ' 获取最高优先级任务 Dim vTask As Variant vTask = oRedis.ZRange(sQueue, 0, 0) If IsArray(vTask) Then Debug.Print "最高优先级任务: " & vTask(0) End If ' 处理任务 Debug.Print vbCrLf & "处理顺序:" While oRedis.ZCard(sQueue) > 0 vTask = oRedis.ZRange(sQueue, 0, 0) If IsArray(vTask) Then Debug.Print " " & vTask(0) oRedis.ZRem sQueue, vTask(0) End If Wend oRedis.DisConnect End Sub ``` ### 6. 评分系统 ```vb Sub RatingSystem() Dim oRedis As New cRedisClient If Not oRedis.Connect() Then Exit Sub Dim sProductId As String sProductId = "product:1001" ' 用户评分 oRedis.ZAdd sProductId & ":ratings", 5, "user:1" oRedis.ZAdd sProductId & ":ratings", 4, "user:2" oRedis.ZAdd sProductId & ":ratings", 5, "user:3" oRedis.ZAdd sProductId & ":ratings", 3, "user:4" oRedis.ZAdd sProductId & ":ratings", 4, "user:5" ' 获取所有评分 Dim vRatings As Variant vRatings = oRedis.ZRange(sProductId & ":ratings", 0, -1, True) Debug.Print "所有评分:" Dim i As Long Dim dSum As Double dSum = 0 If IsArray(vRatings) Then For i = 0 To UBound(vRatings) Step 2 If i + 1 <= UBound(vRatings) Then Dim lRating As Long lRating = CLng(vRatings(i + 1)) Debug.Print " " & vRatings(i) & ": " & lRating & " 星" dSum = dSum + lRating End If Next End If ' 计算平均评分 Dim lCount As Long lCount = oRedis.ZCard(sProductId & ":ratings") Dim dAverage As Double dAverage = dSum / lCount Debug.Print vbCrLf & "平均评分: " & Format(dAverage, "0.00") & " 星 (" & lCount & " 人评分)" oRedis.DisConnect End Sub ``` ## 完整示例 ```vb Sub Example_SortedSets() Dim oRedis As New cRedisClient If Not oRedis.Connect() Then Debug.Print "连接失败: " & oRedis.LastError Exit Sub End If ' 使用 Sorted Set 存储排行榜 oRedis.ZAdd "leaderboard", 1000, "玩家A" oRedis.ZAdd "leaderboard", 1500, "玩家B" oRedis.ZAdd "leaderboard", 800, "玩家C" oRedis.ZAdd "leaderboard", 2000, "玩家D" Debug.Print "排行榜（按分数升序）:" Dim vPlayers As Variant vPlayers = oRedis.ZRange("leaderboard", 0, -1) Dim i As Long If IsArray(vPlayers) Then For i = 0 To UBound(vPlayers) Debug.Print " " & (i + 1) & ". " & vPlayers(i) Next End If Debug.Print vbCrLf & "排行榜（带分数）:" vPlayers = oRedis.ZRange("leaderboard", 0, -1, True) If IsArray(vPlayers) Then For i = 0 To UBound(vPlayers) Step 2 If i + 1 <= UBound(vPlayers) Then Debug.Print " " & vPlayers(i) & ": " & vPlayers(i + 1) & " 分" End If Next End If ' 获取有序集合成员数量 Debug.Print vbCrLf & "玩家数量: " & oRedis.ZCard("leaderboard") oRedis.DisConnect End Sub ``` ## Sorted Set 特性 1. **有序**：根据分数自动排序 2. **唯一**：成员唯一，但分数可以相同 3. **可更新**：可以更新成员的分数 4. **范围查询**：支持按分数范围查询 5. **高性能**：插入和查询都是 O(log N) 复杂度 ## 使用建议 1. **排行榜**：使用分数存储评分，`ZRange` 获取排名 2. **时间线**：使用时间戳作为分数 3. **优先级队列**：使用优先级作为分数 4. **范围查询**：可以查询分数在特定范围内的成员 --- --- url: /en/vbman/redis/sorted-set-operations.md --- # Sorted Set Operations Redis Sorted Set is an ordered set where each member is associated with a score. The set is sorted by score. ## ZAdd - Add Sorted Set Member ### Add Member with Score ```vb oRedis.ZAdd "mysortedset", 100, "member1" oRedis.ZAdd "mysortedset", 200, "member2" oRedis.ZAdd "mysortedset", 150, "member3" ``` **Notes:** * Score can be integer or floating-point * Members with same score are sorted lexicographically * If member already exists, its score will be updated ## ZRange - Get Members in Range ### Get All Members (sorted by score ascending) ```vb Dim vMembers As Variant vMembers = oRedis.ZRange("mysortedset", 0, -1) If IsArray(vMembers) Then Dim i As Long For i = 0 To UBound(vMembers) Debug.Print vMembers(i) Next End If ``` ### Get Members with Scores ```vb vMembers = oRedis.ZRange("mysortedset", 0, -1, True) If IsArray(vMembers) Then For i = 0 To UBound(vMembers) Step 2 If i + 1 <= UBound(vMembers) Then Debug.Print vMembers(i) & ": " & vMembers(i + 1) End If Next End If ``` ### Get Top N ```vb ' Get top 3 (lowest 3 scores) vMembers = oRedis.ZRange("mysortedset", 0, 2) ``` ### Get Bottom N ```vb ' Get bottom 3 (highest 3 scores) vMembers = oRedis.ZRange("mysortedset", -3, -1) ``` ## ZRem - Delete Sorted Set Member ```vb ' Delete single member oRedis.ZRem "mysortedset", "member1" ' Delete multiple members oRedis.ZRem "mysortedset", "member2", "member3" ``` ## ZCard - Get Sorted Set Member Count ```vb Dim lCount As Long lCount = oRedis.ZCard("mysortedset") Debug.Print "Sorted set member count: " & lCount ``` ## Use Cases ### 1. Leaderboard ```vb Sub Leaderboard() Dim oRedis As New cRedisClient If Not oRedis.Connect() Then Exit Sub Dim sLeaderboard As String sLeaderboard = "leaderboard" ' Add player scores oRedis.ZAdd sLeaderboard, 1000, "Player A" oRedis.ZAdd sLeaderboard, 1500, "Player B" oRedis.ZAdd sLeaderboard, 800, "Player C" oRedis.ZAdd sLeaderboard, 2000, "Player D" oRedis.ZAdd sLeaderboard, 1200, "Player E" ' Get leaderboard (sorted by score ascending) Dim vRanking As Variant vRanking = oRedis.ZRange(sLeaderboard, 0, -1) Debug.Print "Leaderboard (ascending):" Dim i As Long If IsArray(vRanking) Then For i = 0 To UBound(vRanking) Debug.Print " " & (i + 1) & ". " & vRanking(i) Next End If ' Get leaderboard (with scores) vRanking = oRedis.ZRange(sLeaderboard, 0, -1, True) Debug.Print vbCrLf & "Leaderboard (with scores):" If IsArray(vRanking) Then For i = 0 To UBound(vRanking) Step 2 If i + 1 <= UBound(vRanking) Then Debug.Print " " & vRanking(i) & ": " & vRanking(i + 1) & " points" End If Next End If ' Get top 3 vRanking = oRedis.ZRange(sLeaderboard, 0, 2, True) Debug.Print vbCrLf & "Top 3:" If IsArray(vRanking) Then For i = 0 To UBound(vRanking) Step 2 If i + 1 <= UBound(vRanking) Then Debug.Print " Rank " & (i / 2 + 1) & ": " & vRanking(i) & " (" & vRanking(i + 1) & " points)" End If Next End If ' Update player score oRedis.ZAdd sLeaderboard, 2500, "Player A" Debug.Print vbCrLf & "After updating Player A score:" vRanking = oRedis.ZRange(sLeaderboard, -1, -1, True) If IsArray(vRanking) Then Debug.Print " First place: " & vRanking(0) & " (" & vRanking(1) & " points)" End If oRedis.DisConnect End Sub ``` ### 2. Timeline ```vb Sub Timeline() Dim oRedis As New cRedisClient If Not oRedis.Connect() Then Exit Sub Dim sTimeline As String sTimeline = "timeline:events" ' Add events (use timestamp as score) oRedis.ZAdd sTimeline, 1640995200, "Event 1: Project started" oRedis.ZAdd sTimeline, 1640995800, "Event 2: Requirements analysis" oRedis.ZAdd sTimeline, 1640996400, "Event 3: Design completed" oRedis.ZAdd sTimeline, 1640997000, "Event 4: Development started" oRedis.ZAdd sTimeline, 1640997600, "Event 5: Testing phase" ' Get events sorted by time Dim vEvents As Variant vEvents = oRedis.ZRange(sTimeline, 0, -1, True) Debug.Print "Timeline:" Dim i As Long If IsArray(vEvents) Then For i = 0 To UBound(vEvents) Step 2 If i + 1 <= UBound(vEvents) Then Dim lTimestamp As Long lTimestamp = CLng(vEvents(i + 1)) Debug.Print " " & FormatDateTime(lTimestamp) & " - " & vEvents(i) End If Next End If oRedis.DisConnect End Sub Function FormatDateTime(ByVal lTimestamp As Long) As String ' Convert Unix timestamp to datetime string Dim dtDate As Date dtDate = DateAdd("s", lTimestamp, #1/1/1970#) FormatDateTime = Format(dtDate, "yyyy-mm-dd hh:nn:ss") End Function ``` ### 3. Delayed Queue ```vb Sub DelayedQueue() Dim oRedis As New cRedisClient If Not oRedis.Connect() Then Exit Sub Dim sQueue As String sQueue = "queue:delayed" ' Add tasks (use execution time as score) Dim lNow As Long lNow = Timer ' Current seconds (simplified) oRedis.ZAdd sQueue, lNow + 60, "Task 1: Execute in 1 minute" oRedis.ZAdd sQueue, lNow + 120, "Task 2: Execute in 2 minutes" oRedis.ZAdd sQueue, lNow + 30, "Task 3: Execute in 30 seconds" ' Simulate time passing Dim i As Long For i = 1 To 5 lNow = Timer ' Get expired tasks Dim vTasks As Variant vTasks = oRedis.ZRange(sQueue, 0, 0, True) If IsArray(vTasks) And UBound(vTasks) >= 1 Then Dim lTaskTime As Long lTaskTime = CLng(vTasks(1)) If lTaskTime <= lNow Then Debug.Print "Execute task: " & vTasks(0) oRedis.ZRem sQueue, vTasks(0) End If End If ' Wait one second Application.Wait (Now + TimeValue("0:00:01")) Next oRedis.DisConnect End Sub ``` ### 4. Popularity Ranking ```vb Sub HotArticles() Dim oRedis As New cRedisClient If Not oRedis.Connect() Then Exit Sub Dim sHotKey As String sHotKey = "hot:articles" ' Simulate article view counts oRedis.ZAdd sHotKey, 1000, "article:1" oRedis.ZAdd sHotKey, 2500, "article:2" oRedis.ZAdd sHotKey, 800, "article:3" oRedis.ZAdd sHotKey, 3000, "article:4" oRedis.ZAdd sHotKey, 1500, "article:5" ' Get top 10 hot articles Dim vHotArticles As Variant vHotArticles = oRedis.ZRange(sHotKey, -10, -1, True) Debug.Print "Hot Articles TOP 10:" Dim i As Long, lIndex As Long lIndex = 1 If IsArray(vHotArticles) Then For i = UBound(vHotArticles) To 0 Step -2 If i - 1 >= 0 Then Debug.Print " " & lIndex & ". " & vHotArticles(i - 1) & " (" & vHotArticles(i) & " views)" lIndex = lIndex + 1 End If Next End If ' Article viewed, increase popularity Dim sArticle As String sArticle = "article:1" ' Get current score Dim lCurrentScore As Long lCurrentScore = CLng(oRedis.Get_(sArticle)) lCurrentScore = lCurrentScore + 1 ' Update score oRedis.ZAdd sHotKey, lCurrentScore, sArticle Debug.Print vbCrLf & "Article " & sArticle & " popularity updated after view" oRedis.DisConnect End Sub ``` ### 5. Priority Queue ```vb Sub PriorityQueue() Dim oRedis As New cRedisClient If Not oRedis.Connect() Then Exit Sub Dim sQueue As String sQueue = "queue:priority" ' Add tasks (use priority as score, higher priority has lower score) oRedis.ZAdd sQueue, 1, "Urgent task: Fix production bug" oRedis.ZAdd sQueue, 3, "Normal task: Write documentation" oRedis.ZAdd sQueue, 2, "Important task: Code review" oRedis.ZAdd sQueue, 1, "Urgent task: Database maintenance" ' Get highest priority task Dim vTask As Variant vTask = oRedis.ZRange(sQueue, 0, 0) If IsArray(vTask) Then Debug.Print "Highest priority task: " & vTask(0) End If ' Process tasks Debug.Print vbCrLf & "Processing order:" While oRedis.ZCard(sQueue) > 0 vTask = oRedis.ZRange(sQueue, 0, 0) If IsArray(vTask) Then Debug.Print " " & vTask(0) oRedis.ZRem sQueue, vTask(0) End If Wend oRedis.DisConnect End Sub ``` ### 6. Rating System ```vb Sub RatingSystem() Dim oRedis As New cRedisClient If Not oRedis.Connect() Then Exit Sub Dim sProductId As String sProductId = "product:1001" ' User ratings oRedis.ZAdd sProductId & ":ratings", 5, "user:1" oRedis.ZAdd sProductId & ":ratings", 4, "user:2" oRedis.ZAdd sProductId & ":ratings", 5, "user:3" oRedis.ZAdd sProductId & ":ratings", 3, "user:4" oRedis.ZAdd sProductId & ":ratings", 4, "user:5" ' Get all ratings Dim vRatings As Variant vRatings = oRedis.ZRange(sProductId & ":ratings", 0, -1, True) Debug.Print "All ratings:" Dim i As Long Dim dSum As Double dSum = 0 If IsArray(vRatings) Then For i = 0 To UBound(vRatings) Step 2 If i + 1 <= UBound(vRatings) Then Dim lRating As Long lRating = CLng(vRatings(i + 1)) Debug.Print " " & vRatings(i) & ": " & lRating & " stars" dSum = dSum + lRating End If Next End If ' Calculate average rating Dim lCount As Long lCount = oRedis.ZCard(sProductId & ":ratings") Dim dAverage As Double dAverage = dSum / lCount Debug.Print vbCrLf & "Average rating: " & Format(dAverage, "0.00") & " stars (" & lCount & " ratings)" oRedis.DisConnect End Sub ``` ## Complete Example ```vb Sub Example_SortedSets() Dim oRedis As New cRedisClient If Not oRedis.Connect() Then Debug.Print "Connection failed: " & oRedis.LastError Exit Sub End If ' Use Sorted Set to store leaderboard oRedis.ZAdd "leaderboard", 1000, "Player A" oRedis.ZAdd "leaderboard", 1500, "Player B" oRedis.ZAdd "leaderboard", 800, "Player C" oRedis.ZAdd "leaderboard", 2000, "Player D" Debug.Print "Leaderboard (sorted by score ascending):" Dim vPlayers As Variant vPlayers = oRedis.ZRange("leaderboard", 0, -1) Dim i As Long If IsArray(vPlayers) Then For i = 0 To UBound(vPlayers) Debug.Print " " & (i + 1) & ". " & vPlayers(i) Next End If Debug.Print vbCrLf & "Leaderboard (with scores):" vPlayers = oRedis.ZRange("leaderboard", 0, -1, True) If IsArray(vPlayers) Then For i = 0 To UBound(vPlayers) Step 2 If i + 1 <= UBound(vPlayers) Then Debug.Print " " & vPlayers(i) & ": " & vPlayers(i + 1) & " points" End If Next End If ' Get sorted set member count Debug.Print vbCrLf & "Player count: " & oRedis.ZCard("leaderboard") oRedis.DisConnect End Sub ``` ## Sorted Set Features 1. **Ordered**: Automatically sorted by score 2. **Unique**: Members are unique, but scores can be the same 3. **Updateable**: Can update member scores 4. **Range queries**: Supports querying members within score range 5. **High performance**: Insert and query operations have O(log N) complexity ## Usage Recommendations 1. **Leaderboard**: Use scores to store ratings, `ZRange` to get rankings 2. **Timeline**: Use timestamp as score 3. **Priority queue**: Use priority as score 4. **Range queries**: Can query members within specific score range --- --- url: /en/packages/vbccr/text/spinbox.md description: >- SpinBox Control - VBCCR Development Manual, complete API reference based on source code --- # SpinBox Control Provides a numeric spin control with an edit box, supporting hexadecimal display, thousands separator, accelerated increment, and OLE drag-and-drop. ## Enumerations ### SpbNumberStyleConstants Number display style constants. | Constant | Value | Description | |----------|-------|-------------| | SpbNumberStyleDecimal | 0 | Decimal | | SpbNumberStyleHexadecimal | 1 | Hexadecimal | ## Properties ### Name ```vb Public Property Get Name() As String ``` Returns the name used to identify the object in code. ### Tag ```vb Public Property Get Tag() As String Public Property Let Tag(ByVal Value As String) ``` Stores extra data needed by the program. ### Parent ```vb Public Property Get Parent() As Object ``` Returns the object that contains the object. ### Container ```vb Public Property Get Container() As Object Public Property Set Container(ByVal Value As Object) ``` Returns/sets the container of the object. ### Left ```vb Public Property Get Left() As Single Public Property Let Left(ByVal Value As Single) ``` Returns/sets the distance between the internal left edge of the object and the left edge of its container. ### Top ```vb Public Property Get Top() As Single Public Property Let Top(ByVal Value As Single) ``` Returns/sets the distance between the internal top edge of the object and the top edge of its container. ### Width ```vb Public Property Get Width() As Single Public Property Let Width(ByVal Value As Single) ``` Returns/sets the width of the object. ### Height ```vb Public Property Get Height() As Single Public Property Let Height(ByVal Value As Single) ``` Returns/sets the height of the object. ### Visible ```vb Public Property Get Visible() As Boolean Public Property Let Visible(ByVal Value As Boolean) ``` Returns/sets whether the object is visible. ### ToolTipText ```vb Public Property Get ToolTipText() As String Public Property Let ToolTipText(ByVal Value As String) ``` Returns/sets the tooltip text displayed when the mouse hovers. ### HelpContextID ```vb Public Property Get HelpContextID() As Long Public Property Let HelpContextID(ByVal Value As Long) ``` Returns/sets the associated context help ID. ### WhatsThisHelpID ```vb Public Property Get WhatsThisHelpID() As Long Public Property Let WhatsThisHelpID(ByVal Value As Long) ``` Returns/sets the associated context help ID. ### DragIcon ```vb Public Property Get DragIcon() As IPictureDisp Public Property Let DragIcon(ByVal Value As IPictureDisp) Public Property Set DragIcon(ByVal Value As IPictureDisp) ``` Returns/sets the icon displayed during drag-and-drop operations. ### DragMode ```vb Public Property Get DragMode() As Integer Public Property Let DragMode(ByVal Value As Integer) ``` Returns/sets the drag mode. ### hWnd ```vb Public Property Get hWnd() As LongPtr ``` Returns the control handle. ### hWndUserControl ```vb Public Property Get hWndUserControl() As LongPtr ``` Returns the UserControl handle. ### hWndEdit ```vb Public Property Get hWndEdit() As LongPtr ``` Returns the embedded edit box handle. ### Font ```vb Public Property Get Font() As StdFont Public Property Let Font(ByVal NewFont As StdFont) Public Property Set Font(ByVal NewFont As StdFont) ``` Returns/sets the font. ### VisualStyles ```vb Public Property Get VisualStyles() As Boolean Public Property Let VisualStyles(ByVal Value As Boolean) ``` Returns/sets whether visual styles are enabled. Requires comctl32.dll version 6.0 or later. ### BackColor ```vb Public Property Get BackColor() As OLE_COLOR Public Property Let BackColor(ByVal Value As OLE_COLOR) ``` Returns/sets the background color. ### ForeColor ```vb Public Property Get ForeColor() As OLE_COLOR Public Property Let ForeColor(ByVal Value As OLE_COLOR) ``` Returns/sets the foreground color. ### Enabled ```vb Public Property Get Enabled() As Boolean Public Property Let Enabled(ByVal Value As Boolean) ``` Returns/sets whether the object can respond to user events. ### OLEDropMode ```vb Public Property Get OLEDropMode() As OLEDropModeConstants Public Property Let OLEDropMode(ByVal Value As OLEDropModeConstants) ``` Returns/sets whether the object can act as an OLE drop target. ### MousePointer ```vb Public Property Get MousePointer() As CCMousePointerConstants Public Property Let MousePointer(ByVal Value As CCMousePointerConstants) ``` Returns/sets the type of mouse pointer displayed when the mouse hovers. See common enumerations. ### MouseIcon ```vb Public Property Get MouseIcon() As IPictureDisp Public Property Let MouseIcon(ByVal Value As IPictureDisp) Public Property Set MouseIcon(ByVal Value As IPictureDisp) ``` Returns/sets the custom mouse icon. ### MouseTrack ```vb Public Property Get MouseTrack() As Boolean Public Property Let MouseTrack(ByVal Value As Boolean) ``` Returns/sets whether events are triggered when the mouse enters or leaves the control. ### RightToLeft ```vb Public Property Get RightToLeft() As Boolean Public Property Let RightToLeft(ByVal Value As Boolean) ``` Returns/sets the right-to-left display direction. ### RightToLeftMode ```vb Public Property Get RightToLeftMode() As CCRightToLeftModeConstants Public Property Let RightToLeftMode(ByVal Value As CCRightToLeftModeConstants) ``` Returns/sets the right-to-left mode. See common enumerations. ### Min ```vb Public Property Get Min() As Long Public Property Let Min(ByVal Value As Long) ``` Returns/sets the minimum value. ### Max ```vb Public Property Get Max() As Long Public Property Let Max(ByVal Value As Long) ``` Returns/sets the maximum value. ### Value ```vb Public Property Get Value() As Long Public Property Let Value(ByVal NewValue As Long) ``` Returns/sets the current value. ### Increment ```vb Public Property Get Increment() As Long Public Property Let Increment(ByVal Value As Long) ``` Returns/sets the increment/decrement amount per click. ### Wrap ```vb Public Property Get Wrap() As Boolean Public Property Let Wrap(ByVal Value As Boolean) ``` Returns/sets whether the value wraps around. When True, exceeding the maximum value returns to the minimum, and vice versa. ### HotTracking ```vb Public Property Get HotTracking() As Boolean Public Property Let HotTracking(ByVal Value As Boolean) ``` Returns/sets whether hot tracking is enabled. ### Alignment ```vb Public Property Get Alignment() As CCLeftRightAlignmentConstants Public Property Let Alignment(ByVal Value As CCLeftRightAlignmentConstants) ``` Returns/sets the alignment of the up/down buttons. See common enumerations. ### ThousandsSeparator ```vb Public Property Get ThousandsSeparator() As Boolean Public Property Let ThousandsSeparator(ByVal Value As Boolean) ``` Returns/sets whether the thousands separator is displayed. ### NumberStyle ```vb Public Property Get NumberStyle() As SpbNumberStyleConstants Public Property Let NumberStyle(ByVal Value As SpbNumberStyleConstants) ``` Returns/sets the number display style. ### ArrowKeysChange ```vb Public Property Get ArrowKeysChange() As Boolean Public Property Let ArrowKeysChange(ByVal Value As Boolean) ``` Returns/sets whether arrow keys can change the value. ### AllowOnlyNumbers ```vb Public Property Get AllowOnlyNumbers() As Boolean Public Property Let AllowOnlyNumbers(ByVal Value As Boolean) ``` Returns/sets whether only numeric input is allowed. ### TextAlignment ```vb Public Property Get TextAlignment() As VBRUN.AlignmentConstants Public Property Let TextAlignment(ByVal Value As VBRUN.AlignmentConstants) ``` Returns/sets the text alignment. ### Locked ```vb Public Property Get Locked() As Boolean Public Property Let Locked(ByVal Value As Boolean) ``` Returns/sets whether the edit box content is locked and non-editable. ### HideSelection ```vb Public Property Get HideSelection() As Boolean Public Property Let HideSelection(ByVal Value As Boolean) ``` Returns/sets whether the selection is hidden when the control loses focus. ### Text ```vb Public Property Get Text() As String Public Property Let Text(ByVal Value As String) ``` Returns/sets the text in the edit box. ### SelStart ```vb Public Property Get SelStart() As Long Public Property Let SelStart(ByVal Value As Long) ``` Returns/sets the starting position of the selected text. ### SelLength ```vb Public Property Get SelLength() As Long Public Property Let SelLength(ByVal Value As Long) ``` Returns/sets the length of the selected text. ### SelText ```vb Public Property Get SelText() As String Public Property Let SelText(ByVal Value As String) ``` Returns/sets the selected text. ## Methods ### Refresh ```vb Public Sub Refresh() ``` Forces a complete repaint of the object. ### SetAcceleration ```vb Public Sub SetAcceleration(ByVal Delays As Variant, ByVal Increments As Variant) ``` Sets accelerated increment parameters. Delays and Increments are arrays specifying delay times and increment amounts. ### ValidateText ```vb Public Sub ValidateText() ``` Validates whether the text in the edit box is a valid numeric value. ### OLEDrag ```vb Public Sub OLEDrag() ``` Initiates an OLE drag-and-drop operation. ### Drag ```vb Public Sub Drag(Optional ByRef Action As Variant) ``` Starts, ends, or cancels a drag operation. ### SetFocus ```vb Public Sub SetFocus() ``` Moves the focus to the control. ### ZOrder ```vb Public Sub ZOrder(Optional ByRef Position As Variant) ``` Sets the Z-order. ## Events ### DownClick ```vb Public Event DownClick() ``` Occurs when the down button is clicked. ### UpClick ```vb Public Event UpClick() ``` Occurs when the up button is clicked. ### BeforeChange ```vb Public Event BeforeChange(ByVal Value As Long, ByRef Delta As Long) ``` Occurs before the value is about to change. Value is the current value, Delta is the expected change amount; modifying Delta controls the actual change. ### Change ```vb Public Event Change() ``` Occurs after the value has changed. ### TextChange ```vb Public Event TextChange() ``` Occurs after the edit box text has changed. ### ContextMenu ```vb Public Event ContextMenu(ByRef Handled As Boolean, ByVal X As Single, ByVal Y As Single) ``` Occurs when the control is right-clicked. Set Handled to True to prevent the default context menu. ### PreviewKeyDown ```vb Public Event PreviewKeyDown(ByVal KeyCode As Integer, ByRef IsInputKey As Boolean) ``` Preview before key press. IsInputKey being True indicates the key is an input key. ### PreviewKeyUp ```vb Public Event PreviewKeyUp(ByVal KeyCode As Integer, ByRef IsInputKey As Boolean) ``` Preview before key release. ### KeyDown ```vb Public Event KeyDown(KeyCode As Integer, Shift As Integer) ``` Occurs when a keyboard key is pressed. ### KeyUp ```vb Public Event KeyUp(KeyCode As Integer, Shift As Integer) ``` Occurs when a keyboard key is released. ### KeyPress ```vb Public Event KeyPress(KeyChar As Integer) ``` Occurs when an ANSI key is pressed and released. ### MouseDown ```vb Public Event MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` Occurs when a mouse button is pressed. ### MouseMove ```vb Public Event MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` Occurs when the mouse is moved. ### MouseUp ```vb Public Event MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` Occurs when a mouse button is released. ### MouseEnter ```vb Public Event MouseEnter() ``` Occurs when the mouse enters the control area. ### MouseLeave ```vb Public Event MouseLeave() ``` Occurs when the mouse leaves the control area. ### OLECompleteDrag ```vb Public Event OLECompleteDrag(Effect As Long) ``` Occurs when an OLE drag-and-drop operation is completed. ### OLEDragDrop ```vb Public Event OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single) ``` Occurs when data is dropped during an OLE drag-and-drop operation. ### OLEDragOver ```vb Public Event OLEDragOver(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single, State As Integer) ``` Occurs when data is dragged over the control during an OLE drag-and-drop operation. ### OLEGiveFeedback ```vb Public Event OLEGiveFeedback(Effect As Long, DefaultCursors As Boolean) ``` Occurs during an OLE drag-and-drop operation to provide feedback. ### OLESetData ```vb Public Event OLESetData(Data As DataObject, DataFormat As Integer) ``` Occurs when data is set during an OLE drag-and-drop operation. ### OLEStartDrag ```vb Public Event OLEStartDrag(Data As DataObject, AllowedEffects As Long) ``` Occurs when an OLE drag-and-drop operation starts. ## Code Examples ### Basic Usage ```vb ' Set up the SpinBox control With SpinBox1 .Min = 0 .Max = 1000 .Value = 100 .Increment = 10 .Wrap = True .HotTracking = True .ThousandsSeparator = True End With ' Set accelerated increment Dim Delays(0 To 2) As Long, Increments(0 To 2) As Long Delays(0) = 500: Increments(0) = 10 Delays(1) = 300: Increments(1) = 50 Delays(2) = 100: Increments(2) = 100 SpinBox1.SetAcceleration Delays, Increments ' Limit value change range Private Sub SpinBox1_BeforeChange(ByVal Value As Long, ByRef Delta As Long) If Value + Delta > 1000 Then Delta = 1000 - Value End Sub ``` --- --- url: /zh/vbman/httpserver/sse-server.md --- # SSE 服务器端实时推送 ## 简介 HttpServer 内置 SSE (Server-Sent Events) 支持，可实现服务器向客户端实时推送消息。适用于： * 实时通知 * 在线聊天 * 数据监控 * 进度推送 ## 客户端请求 客户端使用 `cSSEClient` 连接： ```vb Private WithEvents SSE As cSSEClient Private Sub Connect() Set SSE = New cSSEClient SSE.Connect "http://localhost:8080/events" End Sub Private Sub SSE_OnMessage(EventName As String, Data As String, Id As String) Debug.Print "收到: " & EventName & " = " & Data End Sub ``` ## 服务端实现 ### 基础推送 ```vb ' 在控制器中推送消息 Public Sub Events(ctx As cHttpServerContext) ' 使用 SendPack 快捷发送 ctx.SSE.SendPack "message", "Hello World", ctx.ClientInfo.hSocket ' 发送 JSON 数据 Dim data As New Dictionary data("time") = Now data("status") = "ok" ctx.SSE.SendPack "data", Json.Encode(data), ctx.ClientInfo.hSocket ' 使用 Data + Send 自定义数据结构 ctx.SSE.Data.Add "type", "alert" ctx.SSE.Data.Add "message", "系统维护通知" ctx.SSE.Send ctx.ClientInfo.hSocket End Sub ``` ### 广播消息 ```vb ' cNotificationController.cls ' 发送给所有连接（不传 hSocket 即广播） Public Sub Broadcast(ctx As cHttpServerContext) Dim msg As String msg = ctx.Request.Form("message") ' 广播到所有 SSE 客户端 ctx.SSE.SendPack "notification", msg ctx.Response.Json Nothing, 0, "已广播" End Sub ' 发送给指定用户 Public Sub SendToUser(ctx As cHttpServerContext) Dim userId As String, msg As String userId = ctx.Request.Form("user_id") msg = ctx.Request.Form("message") ' 通过链式调用发送给指定用户 ctx.SSE.ToUser(userId).SendPack "private", msg ctx.Response.Json Nothing, 0, "已发送" End Sub ``` ### 实时数据流 > **注意**: SSE 是事件驱动模式，不适合在控制器中使用 `Do While` 循环轮询。 > 应使用定时器（如 cTimer）定期推送数据，而非阻塞式循环。 ```vb ' cMonitorController.cls ' 由定时器触发推送（推荐方式） Public Sub PushStats(ctx As cHttpServerContext) ' 收集系统数据 Dim data As New Dictionary data("cpu") = GetCPUUsage() data("memory") = GetMemoryUsage() data("time") = Now ' 推送给所有在线 SSE 客户端 ctx.SSE.SendPack "stats", Json.Encode(data) End Sub ``` ### 进度推送 ```vb ' cTaskController.cls ' 由定时器或回调触发推送进度 Public Sub PushProgress(ctx As cHttpServerContext) Dim taskId As String taskId = ctx.Request.Form("task_id") Dim percent As Long percent = CLng(ctx.Request.Form("percent")) Dim progress As New Dictionary progress("percent") = percent progress("task_id") = taskId ' 推送给请求的客户端 ctx.SSE.SendPack "progress", Json.Encode(progress), ctx.ClientInfo.hSocket End Sub Public Sub PushComplete(ctx As cHttpServerContext) ctx.SSE.SendPack "complete", "{\"status\":\"done\"}", ctx.ClientInfo.hSocket End Sub ``` ## 完整聊天示例 ```vb ' ========== 服务端 ========== ' cChatController.cls Option Explicit ' GET /chat/stream Public Sub Stream(ctx As cHttpServerContext) ' 检查登录 If Not ctx.Session.Exists("user_id") Then ctx.Response.State401 "请先登录" Exit Sub End If ' 注册到聊天室（SSE 连接由框架自动管理，无需手动设置头） Dim userId As String, username As String userId = ctx.Session("user_id") username = ctx.Session("username") ' 绑定用户（后续可按用户名推送） ctx.SSE.BindUser ctx.ClientInfo.hSocket, userId ' 发送欢迎消息 ctx.SSE.SendPack "system", "{\"msg\":\"欢迎 " & username & " 加入聊天室\"}", ctx.ClientInfo.hSocket End Sub ' POST /chat/send Public Sub SendMsg(ctx As cHttpServerContext) Dim msg As String msg = ctx.Request.Form("message") Dim username As String username = ctx.Session("username") ' 广播给所有用户（不传 hSocket 即广播） Dim data As String data = "{\"user\":\"" & username & "\",\"msg\":\"" & msg & "\"}" ctx.SSE.SendPack "message", data ctx.Response.Json Nothing, 0, "已发送" End Sub ' ========== 客户端 ========== Private WithEvents SSE As cSSEClient Private Sub JoinChat() Set SSE = New cSSEClient SSE.Connect "http://localhost:8080/chat/stream" End Sub Private Sub SendMessage(msg As String) Dim http As New cHttpClient http.RequestDataForm("message") = msg http.SendPost "http://localhost:8080/chat/send" End Sub Private Sub SSE_OnMessage(EventName As String, Data As String, Id As String) Select Case EventName Case "system" ' 显示系统消息 ShowSystemMessage Data Case "message" ' 显示聊天消息 ShowChatMessage Data End Select End Sub ``` ## 服务端 API 参考 ### Start 启动 SSE 服务，绑定路径和事件处理器。 > **注意**: `Start` 是 `cSSE` 类的方法，仅在服务启动时调用。控制器中通过 `ctx.SSE`（cSSEContext）无法调用此方法。 ```vb Public Function Start(Optional MatchPath As String, Optional EventsHandler As Object) As Boolean ``` **参数**: * `MatchPath` - 匹配的请求路径（为空则匹配所有） * `EventsHandler` - 事件处理器对象，需实现 `OnConnect(Context)` 和 `OnClose(Context)` 方法 **示例**: ```vb ' 启动 SSE，监听 /events 路径 Set SSE = New cSSE SSE.Start "/events", Me ' Me 实现了 OnConnect/OnClose ' 在事件处理器中 Public Sub OnConnect(ctx As cHttpServerContext) Debug.Print "SSE 客户端连接: " & ctx.ClientInfo.IP End Sub Public Sub OnClose(ctx As cHttpServerContext) Debug.Print "SSE 客户端断开: " & ctx.ClientInfo.IP End Sub ``` *** ### Send / SendPack 发送消息给 SSE 客户端。 ```vb ' 自定义数据发送 Public Function Send(Optional ByVal hSocket As Long) As Boolean ' 快捷打包发送（action + content 格式） Public Function SendPack(Action As String, Content As Variant, Optional hSocket As Long) As Boolean ``` **说明**: `Send` 使用共享 `Data` 字典构建消息体，`SendPack` 自动封装 `{"action":..., "content":...}` 格式。两者都支持指定 `hSocket` 发送给特定客户端，或省略（由 `ToUser`/`ToGroup` 链式设定目标）。 **Send 重入安全**: `Send` 方法在编码前会将共享 `Data` 快照到局部变量，发送过程中即使触发重入调用也不会导致数据错乱。 **示例**: ```vb ' 使用 Send 发送自定义数据 SSE.Data.Add "type", "alert" SSE.Data.Add "message", "系统维护通知" SSE.Send hSocket ' 使用 SendPack 快捷发送 SSE.SendPack "notification", "您有新消息", hSocket ' 链式调用发送给指定用户 SSE.ToUser("admin").SendPack "private", "欢迎回来" ``` *** ### CloseClient 关闭指定 SSE 客户端连接。 ```vb Public Function CloseClient(Optional ByVal hSocket As Long) As Boolean ``` **说明**: 无论通过参数还是 `ToUser` 链式调用，都会执行完整清理流程： 1. 触发 `OnClose` 用户事件 2. 清除 SSE 上下文引用 3. 从 Clients 字典移除 4. 清理用户/分组映射 5. **关闭 Socket 连接**，触发 cClientCallback 的完整清理流程 **示例**: ```vb ' 关闭指定客户端 SSE.CloseClient hSocket ' 链式关闭指定用户 SSE.ToUser("admin").CloseClient ``` *** ### BindUser / GetUser / GetClientByUser 管理用户与 Socket 的映射关系。 ```vb Public Function BindUser(ByVal hSocket As Long, ByVal User As String) As Boolean Public Function GetUser(ByVal hSocket As Long) As String Public Function GetClientByUser(ByVal User As String) As Long ``` **示例**: ```vb ' 绑定用户 SSE.BindUser hSocket, "user_123" ' 根据用户名查找 Socket Dim sock As Long sock = SSE.GetClientByUser("user_123") ' 根据 Socket 查找用户名 Dim user As String user = SSE.GetUser(hSocket) ``` *** ### ToUser / ToGroup 链式调用指定发送目标。 ```vb Public Function ToUser(ByVal User As String) As cSSEContext Public Function ToGroup(ByVal Name As String) As cSSEContext ``` **说明**: 返回 cSSEContext 自身，同时设置内部目标 hSocket。后续调用 `Send`/`SendPack`/`CloseClient` 时无需再传 hSocket。 **示例**: ```vb ' 发送给指定用户 ctx.SSE.ToUser("admin").SendPack "msg", "Hello Admin" ' 关闭指定用户连接 ctx.SSE.ToUser("admin").CloseClient ``` *** ### ClientCount 当前在线 SSE 客户端数量（只读）。 ```vb Public Property Get ClientCount() As Long ``` **示例**: ```vb Debug.Print "在线 SSE 客户端: " & SSE.ClientCount ``` *** **最后更新**: 2026-06-13 --- --- url: /en/vbman/httpserver/sse-server.md --- # SSE Server-Side Real-time Push ## Overview HttpServer has built-in SSE (Server-Sent Events) support, enabling server-to-client real-time message push. Suitable for: * Real-time notifications * Online chat * Data monitoring * Progress push ## Client Request Client connects using `cSSEClient`: ```vb Private WithEvents SSE As cSSEClient Private Sub Connect() Set SSE = New cSSEClient SSE.Connect "http://localhost:8080/events" End Sub Private Sub SSE_OnMessage(EventName As String, Data As String, Id As String) Debug.Print "Received: " & EventName & " = " & Data End Sub ``` ## Server Implementation ### Basic Push ```vb ' Push message in controller Public Sub Events(ctx As cHttpServerContext) ' Use SendPack for quick send ctx.SSE.SendPack "message", "Hello World", ctx.ClientInfo.hSocket ' Send JSON data Dim data As New Dictionary data("time") = Now data("status") = "ok" ctx.SSE.SendPack "data", Json.Encode(data), ctx.ClientInfo.hSocket ' Use Data + Send for custom data structure ctx.SSE.Data.Add "type", "alert" ctx.SSE.Data.Add "message", "System maintenance notice" ctx.SSE.Send ctx.ClientInfo.hSocket End Sub ``` ### Broadcast Message ```vb ' cNotificationController.cls ' Send to all connections (omit hSocket for broadcast) Public Sub Broadcast(ctx As cHttpServerContext) Dim msg As String msg = ctx.Request.Form("message") ' Broadcast to all SSE clients ctx.SSE.SendPack "notification", msg ctx.Response.Json Nothing, 0, "Broadcast sent" End Sub ' Send to specific user Public Sub SendToUser(ctx As cHttpServerContext) Dim userId As String, msg As String userId = ctx.Request.Form("user_id") msg = ctx.Request.Form("message") ' Chain call to send to specific user ctx.SSE.ToUser(userId).SendPack "private", msg ctx.Response.Json Nothing, 0, "Sent" End Sub ``` ### Real-time Data Stream > **Note**: SSE is an event-driven model, not suitable for `Do While` polling loops in controllers. > Use a timer (e.g., cTimer) to periodically push data instead of blocking loops. ```vb ' cMonitorController.cls ' Push triggered by timer (recommended approach) Public Sub PushStats(ctx As cHttpServerContext) ' Collect system data Dim data As New Dictionary data("cpu") = GetCPUUsage() data("memory") = GetMemoryUsage() data("time") = Now ' Push to all online SSE clients ctx.SSE.SendPack "stats", Json.Encode(data) End Sub ``` ### Progress Push ```vb ' cTaskController.cls ' Push progress triggered by timer or callback Public Sub PushProgress(ctx As cHttpServerContext) Dim taskId As String taskId = ctx.Request.Form("task_id") Dim percent As Long percent = CLng(ctx.Request.Form("percent")) Dim progress As New Dictionary progress("percent") = percent progress("task_id") = taskId ' Push to requesting client ctx.SSE.SendPack "progress", Json.Encode(progress), ctx.ClientInfo.hSocket End Sub Public Sub PushComplete(ctx As cHttpServerContext) ctx.SSE.SendPack "complete", "{\"status\":\"done\"}", ctx.ClientInfo.hSocket End Sub ``` ## Complete Chat Example ```vb ' ========== Server ========== ' cChatController.cls Option Explicit ' GET /chat/stream Public Sub Stream(ctx As cHttpServerContext) ' Check login If Not ctx.Session.Exists("user_id") Then ctx.Response.State401 "Please login first" Exit Sub End If ' Register to chat room (SSE connection managed by framework, no manual headers needed) Dim userId As String, username As String userId = ctx.Session("user_id") username = ctx.Session("username") ' Bind user (can push by username later) ctx.SSE.BindUser ctx.ClientInfo.hSocket, userId ' Send welcome message ctx.SSE.SendPack "system", "{\"msg\":\"Welcome " & username & " to the chat room\"}", ctx.ClientInfo.hSocket End Sub ' POST /chat/send Public Sub SendMsg(ctx As cHttpServerContext) Dim msg As String msg = ctx.Request.Form("message") Dim username As String username = ctx.Session("username") ' Broadcast to all users (omit hSocket for broadcast) Dim data As String data = "{\"user\":\"" & username & "\",\"msg\":\"" & msg & "\"}" ctx.SSE.SendPack "message", data ctx.Response.Json Nothing, 0, "Sent" End Sub ' ========== Client ========== Private WithEvents SSE As cSSEClient Private Sub JoinChat() Set SSE = New cSSEClient SSE.Connect "http://localhost:8080/chat/stream" End Sub Private Sub SendMessage(msg As String) Dim http As New cHttpClient http.RequestDataForm("message") = msg http.SendPost "http://localhost:8080/chat/send" End Sub Private Sub SSE_OnMessage(EventName As String, Data As String, Id As String) Select Case EventName Case "system" ' Show system message ShowSystemMessage Data Case "message" ' Show chat message ShowChatMessage Data End Select End Sub ``` ## Server API Reference ### Start Start SSE service, bind path and event handler. > **Note**: `Start` is a method of the `cSSE` class, only called during service startup. It cannot be called via `ctx.SSE` (cSSEContext) in controllers. ```vb Public Function Start(Optional MatchPath As String, Optional EventsHandler As Object) As Boolean ``` **Parameters**: * `MatchPath` - Request path to match (empty matches all) * `EventsHandler` - Event handler object, must implement `OnConnect(Context)` and `OnClose(Context)` methods **Example**: ```vb ' Start SSE, listen on /events path Set SSE = New cSSE SSE.Start "/events", Me ' Me implements OnConnect/OnClose ' In event handler Public Sub OnConnect(ctx As cHttpServerContext) Debug.Print "SSE client connected: " & ctx.ClientInfo.IP End Sub Public Sub OnClose(ctx As cHttpServerContext) Debug.Print "SSE client disconnected: " & ctx.ClientInfo.IP End Sub ``` *** ### Send / SendPack Send message to SSE client. ```vb ' Custom data send Public Function Send(Optional ByVal hSocket As Long) As Boolean ' Quick pack send (action + content format) Public Function SendPack(Action As String, Content As Variant, Optional hSocket As Long) As Boolean ``` **Description**: `Send` uses the shared `Data` dictionary to build message body, `SendPack` auto-wraps `{"action":..., "content":...}` format. Both support specifying `hSocket` to send to a specific client, or omit (target set by `ToUser`/`ToGroup` chain). **Send Reentry Safety**: The `Send` method snapshots the shared `Data` to a local variable before encoding, so even if reentry calls are triggered during sending, data corruption will not occur. **Example**: ```vb ' Use Send for custom data SSE.Data.Add "type", "alert" SSE.Data.Add "message", "System maintenance notice" SSE.Send hSocket ' Use SendPack for quick send SSE.SendPack "notification", "You have a new message", hSocket ' Chain call to send to specific user SSE.ToUser("admin").SendPack "private", "Welcome back" ``` *** ### CloseClient Close specified SSE client connection. ```vb Public Function CloseClient(Optional ByVal hSocket As Long) As Boolean ``` **Description**: Whether called via parameter or `ToUser` chain, performs complete cleanup: 1. Trigger `OnClose` user event 2. Clear SSE context references 3. Remove from Clients dictionary 4. Clean up user/group mappings 5. **Close Socket connection**, triggering cClientCallback's complete cleanup flow **Example**: ```vb ' Close specified client SSE.CloseClient hSocket ' Chain close specified user SSE.ToUser("admin").CloseClient ``` *** ### BindUser / GetUser / GetClientByUser Manage user-to-Socket mapping. ```vb Public Function BindUser(ByVal hSocket As Long, ByVal User As String) As Boolean Public Function GetUser(ByVal hSocket As Long) As String Public Function GetClientByUser(ByVal User As String) As Long ``` **Example**: ```vb ' Bind user SSE.BindUser hSocket, "user_123" ' Find socket by username Dim sock As Long sock = SSE.GetClientByUser("user_123") ' Find username by socket Dim user As String user = SSE.GetUser(hSocket) ``` *** ### ToUser / ToGroup Chain call to specify send target. ```vb Public Function ToUser(ByVal User As String) As cSSEContext Public Function ToGroup(ByVal Name As String) As cSSEContext ``` **Description**: Returns cSSEContext itself while setting the internal target hSocket. Subsequent calls to `Send`/`SendPack`/`CloseClient` don't need to pass hSocket. **Example**: ```vb ' Send to specific user ctx.SSE.ToUser("admin").SendPack "msg", "Hello Admin" ' Close specific user connection ctx.SSE.ToUser("admin").CloseClient ``` *** ### ClientCount Current online SSE client count (read-only). ```vb Public Property Get ClientCount() As Long ``` **Example**: ```vb Debug.Print "Online SSE clients: " & SSE.ClientCount ``` *** **Last Updated**: 2026-06-13 --- --- url: /en/vbman/httpserver/static-files.md --- # Static File Serving ## Overview HttpServer has built-in static file serving. When `WebRoot` is configured, it automatically handles static resource requests without writing controllers. :::: warning Version Change Notice Starting from **vbman 1.0.0.419**, `WebRoot` has been separated from the `Start()` method into a chained function. The old syntax `Server.Start 8080, "C:\WebRoot"` is no longer supported. Please use `Server.WebRoot("C:\WebRoot").Start 8080` instead. :::: ## Quick Configuration ```vb Private Sub Form_Load() Set Server = New cHttpServer ' Configure static file root directory Server.WebRoot("C:\WebRoot").Start 8080 Debug.Print "Static file service: http://localhost:8080/" End Sub ``` ## Directory Structure Example ``` C:\WebRoot\ ├── index.html # Home page ├── favicon.ico # Site icon ├── css\ │ ├── style.css │ └── theme.css ├── js\ │ ├── app.js │ └── utils.js ├── images\ │ ├── logo.png │ └── banner.jpg └── upload\ └── avatar.png ``` ## Request Mapping | Request URL | Maps to File | | ------------------ | ---------------------------- | | `/` | `C:\WebRoot\index.html` | | `/css/style.css` | `C:\WebRoot\css\style.css` | | `/js/app.js` | `C:\WebRoot\js\app.js` | | `/images/logo.png` | `C:\WebRoot\images\logo.png` | ## Supported MIME Types ```vb ' System automatically identifies Content-Type for the following file types ' Text types text/html -> .html, .htm text/css -> .css text/javascript -> .js text/plain -> .txt ' Image types image/png -> .png image/jpeg -> .jpg, .jpeg gif/image -> .gif image/svg+xml -> .svg image/x-icon -> .ico ' Application types application/json -> .json application/xml -> .xml application/pdf -> .pdf ' Font types font/woff2 -> .woff2 font/woff -> .woff ``` ## Default Document Mechanism When the request path corresponds to a directory (e.g., accessing root path `/`), HttpServer automatically searches for default documents in priority order: | Priority | Default Document | | -------- | ---------------- | | 1 | `index.html` | | 2 | `index.htm` | | 3 | `default.html` | | 4 | `default.htm` | ### Processing Flow ``` Request "/" or "/subdir/" │ ▼ Check if WebRoot + path is a directory │ ├─> Is directory → Iterate default document list │ ├─> index.html exists? → Return file ✅ │ ├─> index.htm exists? → Return file ✅ │ ├─> default.html exists? → Return file ✅ │ ├─> default.htm exists? → Return file ✅ │ └─> None exist → Return 403 "Directory listing not allowed" 🔒 │ └─> Not directory → Return 404 ``` ### Adding Custom Default Documents ```vb Private Sub Form_Load() Set Server = New cHttpServer ' Add custom default document (e.g., home.html) Server.AddDefaultDocument "home.html" ' Duplicate additions are automatically ignored Server.WebRoot("C:\WebRoot").Start 8080 End Sub ``` After adding, the default document search order becomes: `index.html → index.htm → default.html → default.htm → home.html` ### Directory Redirect When the request path corresponds to a physical directory but doesn't end with `/`, HttpServer automatically 302 redirects to the path with `/`: ``` Request /subdir (corresponds to physical directory) → 302 redirect to /subdir/ → Then search for default documents like /subdir/index.html ``` > **Note**: Root path `/` doesn't need redirect, directly enters default document search. ### Priority Relationship with Routes If a manual route is registered for root path `/`, the route executes first and won't enter default document search: ```vb ' Route priority: root path handled by controller Call Server.Router.Add("/", "Home@Index") ' Now accessing "/" → Calls Home.Index, doesn't search for index.html ``` ## Priority Explanation Static files take priority over route matching: ``` Request /index.html │ ├──> Check if C:\WebRoot\index.html exists │ ├─> Exists -> Return static file │ └─> Does not exist -> Go to route matching │ └──> Match route /index.html ``` ## Mixed Mode (Static Files + API) ```vb Private Sub Form_Load() Set Server = New cHttpServer ' ========== Configure Routes ========== ' API controllers Call Server.Router.Reg("Api", New cApiController) Call Server.Router.Add("/api/users", "Api@Users", OnlyGet) Call Server.Router.Add("/api/data", "Api@Data", OnlyGet) ' Business controllers Call Server.Router.Reg("User", New cUserController) Call Server.Router.Add("/user/login", "User@Login", OnlyPost) ' ========== Start Service ========== ' WebRoot for static files, API requests go to routing Server.WebRoot("C:\WebRoot").Start 8080 Debug.Print "Service started successfully" Debug.Print " Frontend: http://localhost:8080/" Debug.Print " API: http://localhost:8080/api/users" End Sub ``` ## Single Page Application (SPA) Support For React/Vue/Angular SPAs, configure all routes to return index.html: ```vb ' cSpaController.cls Public Sub Index(ctx As cHttpServerContext) ' Return index.html for frontend routing ctx.Response.File "/index.html" End Sub ' Register routes Private Sub Form_Load() Set Server = New cHttpServer ' API routes Call Server.Router.Reg("Api", New cApiController) Call Server.Router.Add("/api/*", "Api@Handle") ' SPA routes: All non-API requests return index.html Call Server.Router.Reg("Spa", New cSpaController) Call Server.Router.Add("/*", "Spa@Index") Server.WebRoot("C:\WebRoot").Start 8080 End Sub ``` ## File Upload Directory ```vb ' Upload files to static directory Public Sub Upload(ctx As cHttpServerContext) ' Save uploaded file Dim savePath As String savePath = ctx.Server.WebRoot & "\upload\" & filename Call SaveUploadFile(ctx.Request.RawBodyBin, savePath) ' Return accessible URL Dim result As New Dictionary result("url") = "/upload/" & filename ctx.Response.Json result End Sub ``` ## Cache Control ### Built-in Lazy Cache + ETag + 304 HttpServer has a three-layer cache mechanism that automatically senses file updates, no manual intervention needed: ``` Request /css/style.css │ ▼ 1. Calculate ETag (file modification time + size, only FSO metadata, no content read) │ ├─> Browser sends If-None-Match and matches → 304 Not Modified ✅ │ (Zero transfer, browser uses local cache) │ ├─> Cache hit and ETag unchanged → Memory output (skip disk I/O) ✅ │ ├─> Cache hit but ETag changed → Re-read + update cache 🔄 │ └─> No cache → Disk read + lazy cache (only add if size ≤ limit) 📥 ``` **Lazy Cache Rules**: * No files are cached by default * On first access, if file size ≤ `MaxCacheFileSize`, it's automatically added to memory cache * Files exceeding size limit (e.g., videos, large images) are always read from disk, but still enjoy ETag/304 negotiated cache * When files are updated on disk, ETag auto-changes and old cache auto-invalidates and re-reads ### Cache Configuration ```vb Private Sub Form_Load() Set Server = New cHttpServer ' Cache configuration (can be modified before Start or at runtime) Server.MaxCacheFileSize = 1048576 ' Single file cache limit: 1MB (default) Server.CacheTTLSeconds = 300 ' Cache TTL: 5 minutes (default) ' Set to 0 to disable content cache (keep ETag/304 negotiated cache only) Server.MaxCacheFileSize = 0 Server.WebRoot("C:\WebRoot").Start 8080 End Sub ``` | Configuration | Default | Description | | ------------------ | ------------- | ------------------------------------------------------------------------------- | | `MaxCacheFileSize` | 1048576 (1MB) | Single file cache limit in bytes, 0=disable content cache | | `CacheTTLSeconds` | 300 (5min) | Cache TTL in seconds, check ETag after expiry to decide refresh, 0=never expire | ### Manual Cache Refresh After deploying new files, you can manually refresh directory structure cache and content cache: ```vb ' Refresh directory structure cache (call after adding/deleting files) ' Does not affect content cache, content cache senses file updates via ETag Server.RefreshCache ' Clear all file content cache (force re-read from disk) Server.ClearFileCache ``` > **Best Practice**: In most scenarios, only `RefreshCache` is needed, content cache senses file updates via ETag automatically. Use `ClearFileCache` only when you need to force release memory. ### Custom Middleware Cache Headers ```vb ' cCacheMiddleware.cls Public Sub Entry(ctx As cHttpServerContext) ' Add browser cache headers for static files If IsStaticFile(ctx.Request.PathInfo) Then ' Cache for 1 hour ctx.Response.Header("Cache-Control") = "public, max-age=3600" End If End Sub Private Function IsStaticFile(path As String) As Boolean Dim ext As String ext = LCase(Mid(path, InStrRev(path, "."))) IsStaticFile = (ext = ".css" Or ext = ".js" Or ext = ".png" Or _ ext = ".jpg" Or ext = ".gif" Or ext = ".ico") End Function ``` *** **Last Updated**: 2026-06-22 --- --- url: /en/packages/vbccr/bars/statusbar.md description: >- StatusBar Control - VBCCR Developer Reference, complete API documentation based on source code --- # StatusBar Control Provides a customizable status bar, supporting panel collections, simple/normal modes, a sizing grip, and OLE drag-and-drop. Cannot receive focus. ## Enumerations ### SbrStyleConstants Status bar style constants. | Constant | Value | Description | |----------|-------|-------------| | SbrStyleNormal | 0 | Normal mode (displays panels) | | SbrStyleSimple | 1 | Simple mode (displays SimpleText only) | ### SbrPanelStyleConstants Panel style constants. | Constant | Value | Description | |----------|-------|-------------| | SbrPanelStyleText | 0 | Text panel | | SbrPanelStyleCaps | 1 | Caps Lock state | | SbrPanelStyleNum | 2 | Num Lock state | | SbrPanelStyleIns | 3 | Insert state | | SbrPanelStyleScrl | 4 | Scroll Lock state | | SbrPanelStyleTime | 5 | Time | | SbrPanelStyleDate | 6 | Date | | SbrPanelStyleKana | 7 | Kana state | | SbrPanelStyleHangul | 8 | Hangul state | | SbrPanelStyleJunja | 9 | Junja state | | SbrPanelStyleFinal | 10 | Final state | | SbrPanelStyleKanji | 11 | Kanji state | | SbrPanelStyleHanja | 12 | Hanja state | ### SbrPanelBevelConstants Panel bevel style constants. | Constant | Value | Description | |----------|-------|-------------| | SbrPanelBevelFlat | 0 | Flat | | SbrPanelBevelInset | 1 | Inset | | SbrPanelBevelRaised | 2 | Raised | ### SbrPanelAutoSizeConstants Panel auto-size constants. | Constant | Value | Description | |----------|-------|-------------| | SbrPanelAutoSizeNone | 0 | No auto-size | | SbrPanelAutoSizeSpring | 1 | Spring (fills remaining space) | | SbrPanelAutoSizeContent | 2 | Size to content | ### SbrPanelAlignmentConstants Panel alignment constants. | Constant | Value | Description | |----------|-------|-------------| | SbrPanelAlignmentLeft | 0 | Left aligned | | SbrPanelAlignmentCenter | 1 | Center aligned | | SbrPanelAlignmentRight | 2 | Right aligned | | SbrPanelAlignmentLeftRight | 3 | Left-to-right aligned (RTL support) | ### SbrPanelDTFormatConstants Panel date/time format constants. | Constant | Value | Description | |----------|-------|-------------| | SbrPanelDTFormatShort | 0 | Short format | | SbrPanelDTFormatLong | 1 | Long format | ## Properties ### Name ```vb Public Property Get Name() As String ``` Returns the name used to identify the object in code. ### Tag ```vb Public Property Get Tag() As String Public Property Let Tag(ByVal Value As String) ``` Stores extra data needed by the program. ### Parent ```vb Public Property Get Parent() As Object ``` Returns the object that contains this object. ### Container ```vb Public Property Get Container() As Object Public Property Set Container(ByVal Value As Object) ``` Returns/sets the object's container. ### Left ```vb Public Property Get Left() As Single Public Property Let Left(ByVal Value As Single) ``` Returns/sets the distance between the object and the left edge of its container. ### Top ```vb Public Property Get Top() As Single Public Property Let Top(ByVal Value As Single) ``` Returns/sets the distance between the object and the top edge of its container. ### Width ```vb Public Property Get Width() As Single Public Property Let Width(ByVal Value As Single) ``` Returns/sets the width of the object. ### Height ```vb Public Property Get Height() As Single Public Property Let Height(ByVal Value As Single) ``` Returns/sets the height of the object. ### Visible ```vb Public Property Get Visible() As Boolean Public Property Let Visible(ByVal Value As Boolean) ``` Returns/sets whether the object is visible. ### ToolTipText ```vb Public Property Get ToolTipText() As String Public Property Let ToolTipText(ByVal Value As String) ``` Returns/sets the tooltip text displayed when the mouse hovers over the control. ### WhatsThisHelpID ```vb Public Property Get WhatsThisHelpID() As Long Public Property Let WhatsThisHelpID(ByVal Value As Long) ``` Returns/sets the associated context-sensitive help ID. ### Align ```vb Public Property Get Align() As Integer Public Property Let Align(ByVal Value As Integer) ``` Returns/sets the alignment of the control on its form. ### DragIcon ```vb Public Property Get DragIcon() As IPictureDisp Public Property Let DragIcon(ByVal Value As IPictureDisp) Public Property Set DragIcon(ByVal Value As IPictureDisp) ``` Returns/sets the icon displayed during a drag-and-drop operation. ### DragMode ```vb Public Property Get DragMode() As Integer Public Property Let DragMode(ByVal Value As Integer) ``` Returns/sets the drag mode. ### hWnd ```vb Public Property Get hWnd() As LongPtr ``` Returns the control handle. ### hWndUserControl ```vb Public Property Get hWndUserControl() As LongPtr ``` Returns the UserControl handle. ### Font ```vb Public Property Get Font() As StdFont Public Property Let Font(ByVal NewFont As StdFont) Public Property Set Font(ByVal NewFont As StdFont) ``` Returns/sets the font. ### VisualStyles ```vb Public Property Get VisualStyles() As Boolean Public Property Let VisualStyles(ByVal Value As Boolean) ``` Returns/sets whether visual styles are enabled. Requires comctl32.dll 6.0 or later. ### Enabled ```vb Public Property Get Enabled() As Boolean Public Property Let Enabled(ByVal Value As Boolean) ``` Returns/sets whether the object can respond to user-generated events. ### OLEDropMode ```vb Public Property Get OLEDropMode() As OLEDropModeConstants Public Property Let OLEDropMode(ByVal Value As OLEDropModeConstants) ``` Returns/sets whether the object can act as an OLE drop target. ### MousePointer ```vb Public Property Get MousePointer() As CCMousePointerConstants Public Property Let MousePointer(ByVal Value As CCMousePointerConstants) ``` Returns/sets the pointer type displayed when the mouse hovers over the control. See common enumerations. ### MouseIcon ```vb Public Property Get MouseIcon() As IPictureDisp Public Property Let MouseIcon(ByVal Value As IPictureDisp) Public Property Set MouseIcon(ByVal Value As IPictureDisp) ``` Returns/sets the custom mouse icon. ### MouseTrack ```vb Public Property Get MouseTrack() As Boolean Public Property Let MouseTrack(ByVal Value As Boolean) ``` Returns/sets whether events are raised when the mouse enters or leaves the control. ### RightToLeft ```vb Public Property Get RightToLeft() As Boolean Public Property Let RightToLeft(ByVal Value As Boolean) ``` Returns/sets the right-to-left display direction. ### RightToLeftLayout ```vb Public Property Get RightToLeftLayout() As Boolean Public Property Let RightToLeftLayout(ByVal Value As Boolean) ``` Returns/sets the right-to-left layout. ### RightToLeftMode ```vb Public Property Get RightToLeftMode() As CCRightToLeftModeConstants Public Property Let RightToLeftMode(ByVal Value As CCRightToLeftModeConstants) ``` Returns/sets the right-to-left mode. See common enumerations. ### Style ```vb Public Property Get Style() As SbrStyleConstants Public Property Let Style(ByVal Value As SbrStyleConstants) ``` Returns/sets the status bar style. ### SimpleText ```vb Public Property Get SimpleText() As String Public Property Let SimpleText(ByVal Value As String) ``` Returns/sets the text displayed in simple mode. ### AllowSizeGrip ```vb Public Property Get AllowSizeGrip() As Boolean Public Property Let AllowSizeGrip(ByVal Value As Boolean) ``` Returns/sets whether the sizing grip is displayed. ### ShowTips ```vb Public Property Get ShowTips() As Boolean Public Property Let ShowTips(ByVal Value As Boolean) ``` Returns/sets whether tooltips are displayed. ### BackColor ```vb Public Property Get BackColor() As OLE_COLOR Public Property Let BackColor(ByVal Value As OLE_COLOR) ``` Returns/sets the background color. ### DoubleBuffer ```vb Public Property Get DoubleBuffer() As Boolean Public Property Let DoubleBuffer(ByVal Value As Boolean) ``` Returns/sets whether double-buffered drawing is enabled. ### Panels ```vb Public Property Get Panels() As SbrPanels ``` Returns the panels collection. ## Methods ### Refresh ```vb Public Sub Refresh() ``` Forces a complete redraw of the object. ### IncludesSizeGrip ```vb Public Function IncludesSizeGrip() As Boolean ``` Determines whether the status bar includes a sizing grip. ### HitTest ```vb Public Function HitTest(ByVal X As Single, ByVal Y As Single) As SbrPanel ``` Returns the panel at the specified coordinates. ### OLEDrag ```vb Public Sub OLEDrag() ``` Initiates an OLE drag-and-drop operation. ### Drag ```vb Public Sub Drag(Optional ByRef Action As Variant) ``` Starts, ends, or cancels a drag operation. ### ZOrder ```vb Public Sub ZOrder(Optional ByRef Position As Variant) ``` Sets the Z-order. ## Events ### Click ```vb Public Event Click() ``` Raised when the user clicks the control. ### DblClick ```vb Public Event DblClick() ``` Raised when the user double-clicks the control. ### StyleChange ```vb Public Event StyleChange() ``` Raised when the status bar style changes. ### PanelClick ```vb Public Event PanelClick(ByVal Panel As SbrPanel, ByVal Button As Integer) ``` Raised when the user clicks a panel. ### PanelDblClick ```vb Public Event PanelDblClick(ByVal Panel As SbrPanel, ByVal Button As Integer) ``` Raised when the user double-clicks a panel. ### MouseDown ```vb Public Event MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` Raised when a mouse button is pressed. ### MouseMove ```vb Public Event MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` Raised when the mouse is moved. ### MouseUp ```vb Public Event MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` Raised when a mouse button is released. ### MouseEnter ```vb Public Event MouseEnter() ``` Raised when the mouse enters the control area. ### MouseLeave ```vb Public Event MouseLeave() ``` Raised when the mouse leaves the control area. ### OLECompleteDrag ```vb Public Event OLECompleteDrag(Effect As Long) ``` Raised when an OLE drag-and-drop operation is completed. ### OLEDragDrop ```vb Public Event OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single) ``` Raised when an OLE drag-and-drop operation is dropped. ### OLEDragOver ```vb Public Event OLEDragOver(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single, State As Integer) ``` Raised during an OLE drag-and-drop hover. ### OLEGiveFeedback ```vb Public Event OLEGiveFeedback(Effect As Long, DefaultCursors As Boolean) ``` Raised when OLE drag-and-drop gives feedback. ### OLESetData ```vb Public Event OLESetData(Data As DataObject, DataFormat As Integer) ``` Raised when OLE drag-and-drop sets data. ### OLEStartDrag ```vb Public Event OLEStartDrag(Data As DataObject, AllowedEffects As Long) ``` Raised when an OLE drag-and-drop operation starts. ## Sub-Objects ### SbrPanel Class Status bar panel object. #### SbrPanel Properties #### Index ```vb Public Property Get Index() As Long ``` The index of the panel in the collection. #### Key ```vb Public Property Get Key() As String Public Property Let Key(ByVal Value As String) ``` The panel's unique identifier key. #### Tag ```vb Public Property Get Tag() As Variant Public Property Let Tag(ByVal Value As Variant) Public Property Set Tag(ByVal Value As Variant) ``` Extra data. #### Text ```vb Public Property Get Text() As String Public Property Let Text(ByVal Value As String) ``` Panel text. #### ToolTipText ```vb Public Property Get ToolTipText() As String Public Property Let ToolTipText(ByVal Value As String) ``` ToolTip text. #### Style ```vb Public Property Get Style() As SbrPanelStyleConstants Public Property Let Style(ByVal Value As SbrPanelStyleConstants) ``` Panel style. #### Bevel ```vb Public Property Get Bevel() As SbrPanelBevelConstants Public Property Let Bevel(ByVal Value As SbrPanelBevelConstants) ``` Panel bevel style. #### AutoSize ```vb Public Property Get AutoSize() As SbrPanelAutoSizeConstants Public Property Let AutoSize(ByVal Value As SbrPanelAutoSizeConstants) ``` Panel auto-size behavior. #### Alignment ```vb Public Property Get Alignment() As SbrPanelAlignmentConstants Public Property Let Alignment(ByVal Value As SbrPanelAlignmentConstants) ``` Panel alignment. #### DTFormat ```vb Public Property Get DTFormat() As SbrPanelDTFormatConstants Public Property Let DTFormat(ByVal Value As SbrPanelDTFormatConstants) ``` Panel date/time format. #### ForeColor ```vb Public Property Get ForeColor() As OLE_COLOR Public Property Let ForeColor(ByVal Value As OLE_COLOR) ``` Foreground color. #### MinWidth ```vb Public Property Get MinWidth() As Single Public Property Let MinWidth(ByVal Value As Single) ``` Minimum width. #### Picture ```vb Public Property Get Picture() As IPictureDisp Public Property Let Picture(ByVal Value As IPictureDisp) Public Property Set Picture(ByVal Value As IPictureDisp) ``` Panel picture. #### Enabled ```vb Public Property Get Enabled() As Boolean Public Property Let Enabled(ByVal Value As Boolean) ``` Whether enabled. #### Visible ```vb Public Property Get Visible() As Boolean Public Property Let Visible(ByVal Value As Boolean) ``` Whether visible. #### Bold ```vb Public Property Get Bold() As Boolean Public Property Let Bold(ByVal Value As Boolean) ``` Whether text is displayed in bold. #### PictureOnRight ```vb Public Property Get PictureOnRight() As Boolean Public Property Let PictureOnRight(ByVal Value As Boolean) ``` Whether the picture is displayed on the right side. #### Left ```vb Public Property Get Left() As Single ``` Panel left edge distance (read-only). #### Width ```vb Public Property Get Width() As Single Public Property Let Width(ByVal Value As Single) ``` Panel width. ### SbrPanels Class Status bar panels collection. #### SbrPanels Members #### NewEnum ```vb Public Function NewEnum() As IEnumVARIANT ``` Enumerator (hidden). #### Add ```vb Public Function Add(Optional ByVal Index As Long, Optional ByVal Key As String, Optional ByVal Text As String, Optional ByVal Style As SbrPanelStyleConstants) As SbrPanel ``` Adds a panel. #### Item ```vb Public Property Get Item(ByVal Index As Variant) As SbrPanel ``` Gets a panel (default member). #### Exists ```vb Public Function Exists(ByVal Index As Variant) As Boolean ``` Checks if a panel exists. #### Count ```vb Public Property Get Count() As Long ``` Panel count. #### Clear ```vb Public Sub Clear() ``` Clears all panels. #### Remove ```vb Public Sub Remove(ByVal Index As Variant) ``` Removes a panel. ### SbrPanelProperties Class Internal panel properties object. #### SbrPanelProperties Properties #### ForeColor ```vb Public Property Get ForeColor() As OLE_COLOR Public Property Let ForeColor(ByVal Value As OLE_COLOR) ``` Foreground color. ## Code Examples ### Basic Usage ```vb ' Add status bar panels With StatusBar1.Panels .Add , "Status", "Ready", sbrText .Add , "Caps", , sbrCaps .Add , "Time", , sbrTime End With ' Customize panel style With StatusBar1.Panels(1) .AutoSize = sbrSpring .Bevel = sbrInset End With ' Switch to simple mode StatusBar1.Style = sbrSimple StatusBar1.SimpleText = "Loading data..." ' Handle panel click Private Sub StatusBar1_PanelClick(ByVal Panel As SbrPanel, ByVal Button As Integer) Debug.Print "Panel clicked: " & Panel.Key End Sub ``` --- --- url: /zh/vbman/redis/string-operations.md --- # String 操作 Redis String 是最简单的数据类型，可以存储字符串、整数或浮点数。 ## Set\_ - 设置键值 ### 基本设置 ```vb oRedis.Set_ "name", "张三" oRedis.Set_ "age", "25" oRedis.Set_ "city", "北京" ``` ### 设置过期时间 ```vb ' 设置过期时间（秒） oRedis.Set_ "session", "abc123", , 3600 ' 1小时后过期 ' 设置过期时间（毫秒） oRedis.Set_ "token", "xyz789", , 60000 ' 1分钟后过期 ``` ## Get\_ - 获取键值 ```vb Dim sValue As String sValue = oRedis.Get_("name") Debug.Print sValue ' 输出: 张三 ``` ## Incr - 自增 将键中的数值加 1： ```vb ' 初始化计数器 oRedis.Set_ "counter", "10" ' 自增 Dim lValue As Long lValue = oRedis.Incr("counter") Debug.Print lValue ' 输出: 11 ' 再次自增 lValue = oRedis.Incr("counter") Debug.Print lValue ' 输出: 12 ``` **用途：** * 计数器 * ID 生成 * 访问统计 ## Decr - 自减 将键中的数值减 1： ```vb ' 自减 lValue = oRedis.Decr("counter") Debug.Print lValue ' 输出: 10 ``` ## MGet - 批量获取 同时获取多个键的值： ```vb ' 同时获取多个键 Dim vValues As Variant vValues = oRedis.MGet("name", "age", "city") If IsArray(vValues) Then Dim i As Long For i = 0 To UBound(vValues) Debug.Print vValues(i) Next End If ``` **返回值说明：** * 键存在时，返回对应的值 * 键不存在时，返回空字符串 ## MSet - 批量设置 批量设置多个键值对： ```vb ' 批量设置键值对 oRedis.MSet "name", "李四", "age", "25", "city", "北京" ``` ## 应用场景 ### 1. 用户会话管理 ```vb Sub UserSession() Dim oRedis As New cRedisClient If Not oRedis.Connect() Then Exit Sub Dim sUserId As String sUserId = "user:12345" ' 创建会话 oRedis.Set_ sUserId & ":name", "张三" oRedis.Set_ sUserId & ":email", "zhangsan@example.com" oRedis.Set_ sUserId & ":login_time", CStr(Now()) ' 设置会话过期时间为 30 分钟 oRedis.Expire sUserId & ":name", 1800 oRedis.Expire sUserId & ":email", 1800 oRedis.Expire sUserId & ":login_time", 1800 ' 获取会话信息 Dim vSession As Variant vSession = oRedis.MGet(sUserId & ":name", sUserId & ":email") If IsArray(vSession) Then Debug.Print "用户: " & vSession(0) Debug.Print "邮箱: " & vSession(1) Debug.Print "剩余时间: " & oRedis.TTL(sUserId & ":name") & " 秒" End If oRedis.DisConnect End Sub ``` ### 2. 计数器 ```vb Sub CounterExample() Dim oRedis As New cRedisClient If Not oRedis.Connect() Then Exit Sub ' 页面访问计数 Dim sPage As String sPage = "page:/home" ' 增加访问次数 Dim lCount As Long lCount = oRedis.Incr(sPage) Debug.Print "页面访问次数: " & lCount ' 文章点赞计数 oRedis.Incr "article:1001:likes" oRedis.Incr "article:1001:likes" oRedis.Incr "article:1001:likes" Debug.Print "文章点赞数: " & oRedis.Get_("article:1001:likes") oRedis.DisConnect End Sub ``` ### 3. 分布式 ID 生成 ```vb Function GenerateId(ByVal sPrefix As String) As String Static oRedis As cRedisClient If oRedis Is Nothing Then Set oRedis = New cRedisClient If Not oRedis.Connect() Then Debug.Print "连接失败" Exit Function End If End If Dim lId As Long lId = oRedis.Incr("id:" & sPrefix) GenerateId = sPrefix & ":" & lId End Function Sub TestIdGeneration() Debug.Print GenerateId("order") ' 输出: order:1 Debug.Print GenerateId("order") ' 输出: order:2 Debug.Print GenerateId("user") ' 输出: user:1 Debug.Print GenerateId("order") ' 输出: order:3 End Sub ``` ### 4. 限流器 ```vb Function RateLimit(ByVal sUserId As String, ByVal lLimit As Long) As Boolean Static oRedis As cRedisClient If oRedis Is Nothing Then Set oRedis = New cRedisClient If Not oRedis.Connect() Then Exit Function End If End If Dim sKey As String sKey = "ratelimit:" & sUserId Dim lCount As Long lCount = oRedis.Incr(sKey) ' 第一次请求时设置过期时间（1分钟） If lCount = 1 Then oRedis.Expire sKey, 60 End If ' 检查是否超过限制 If lCount > lLimit Then Debug.Print "超过限制，当前请求: " & lCount RateLimit = False Else RateLimit = True End If End Function Sub TestRateLimit() Dim i As Long For i = 1 To 12 Debug.Print "请求 " & i & ": " & IIf(RateLimit("user123", 10), "允许", "拒绝") Next i End Sub ``` ### 5. 缓存管理 ```vb Function GetCachedData(ByVal sKey As String, ByVal sDefault As String) As String Static oRedis As cRedisClient If oRedis Is Nothing Then Set oRedis = New cRedisClient oRedis.Connect End If Dim sValue As String sValue = oRedis.Get_(sKey) If sValue = "" Then ' 缓存不存在，返回默认值 GetCachedData = sDefault ' 将默认值存入缓存，过期时间 1 小时 oRedis.Set_ sKey, sDefault, , 3600 Else GetCachedData = sValue End If End Function Sub TestCache() Debug.Print "第一次获取: " & GetCachedData("config:appname", "MyApp") Debug.Print "第二次获取: " & GetCachedData("config:appname", "MyApp") End Sub ``` ## 完整示例 ```vb Sub Example_StringOperations() Dim oRedis As New cRedisClient If Not oRedis.Connect() Then Debug.Print "连接失败: " & oRedis.LastError Exit Sub End If ' 设置值 oRedis.Set_ "name", "张三" oRedis.Set_ "age", "25" ' 获取值 Debug.Print "姓名: " & oRedis.Get_("name") Debug.Print "年龄: " & oRedis.Get_("age") ' 设置过期时间 oRedis.Expire "name", 300 ' 检查剩余时间 Debug.Print "name 的剩余生存时间: " & oRedis.TTL("name") & " 秒" ' 计数器示例 oRedis.Set_ "counter", "10" Debug.Print "初始值: " & oRedis.Get_("counter") Debug.Print "自增后: " & oRedis.Incr("counter") Debug.Print "再自增: " & oRedis.Incr("counter") Debug.Print "自减: " & oRedis.Decr("counter") ' 批量操作 oRedis.MSet "user:1", "张三", "user:2", "李四", "user:3", "王五" Dim vUsers As Variant vUsers = oRedis.MGet("user:1", "user:2", "user:3") Debug.Print vbCrLf & "批量获取结果:" Dim i As Long If IsArray(vUsers) Then For i = 0 To UBound(vUsers) Debug.Print " 用户" & (i + 1) & ": " & vUsers(i) Next End If oRedis.DisConnect End Sub ``` --- --- url: /en/vbman/redis/string-operations.md --- # String Operations Redis String is the simplest data type, capable of storing strings, integers, or floating-point numbers. ## Set\_ - Set Key-Value ### Basic Setting ```vb oRedis.Set_ "name", "Zhang San" oRedis.Set_ "age", "25" oRedis.Set_ "city", "Beijing" ``` ### Set with Expiration ```vb ' Set expiration time (seconds) oRedis.Set_ "session", "abc123", , 3600 ' Expire in 1 hour ' Set expiration time (milliseconds) oRedis.Set_ "token", "xyz789", , 60000 ' Expire in 1 minute ``` ## Get\_ - Get Key Value ```vb Dim sValue As String sValue = oRedis.Get_("name") Debug.Print sValue ' Output: Zhang San ``` ## Incr - Increment Increment the numeric value in the key by 1: ```vb ' Initialize counter oRedis.Set_ "counter", "10" ' Increment Dim lValue As Long lValue = oRedis.Incr("counter") Debug.Print lValue ' Output: 11 ' Increment again lValue = oRedis.Incr("counter") Debug.Print lValue ' Output: 12 ``` **Use Cases:** * Counters * ID generation * Access statistics ## Decr - Decrement Decrement the numeric value in the key by 1: ```vb ' Decrement lValue = oRedis.Decr("counter") Debug.Print lValue ' Output: 10 ``` ## MGet - Batch Get Get values of multiple keys simultaneously: ```vb ' Get multiple keys at once Dim vValues As Variant vValues = oRedis.MGet("name", "age", "city") If IsArray(vValues) Then Dim i As Long For i = 0 To UBound(vValues) Debug.Print vValues(i) Next End If ``` **Return Value Explanation:** * Returns corresponding value if key exists * Returns empty string if key does not exist ## MSet - Batch Set Batch set multiple key-value pairs: ```vb ' Batch set key-value pairs oRedis.MSet "name", "Li Si", "age", "25", "city", "Beijing" ``` ## Use Cases ### 1. User Session Management ```vb Sub UserSession() Dim oRedis As New cRedisClient If Not oRedis.Connect() Then Exit Sub Dim sUserId As String sUserId = "user:12345" ' Create session oRedis.Set_ sUserId & ":name", "Zhang San" oRedis.Set_ sUserId & ":email", "zhangsan@example.com" oRedis.Set_ sUserId & ":login_time", CStr(Now()) ' Set session expiration time to 30 minutes oRedis.Expire sUserId & ":name", 1800 oRedis.Expire sUserId & ":email", 1800 oRedis.Expire sUserId & ":login_time", 1800 ' Get session information Dim vSession As Variant vSession = oRedis.MGet(sUserId & ":name", sUserId & ":email") If IsArray(vSession) Then Debug.Print "User: " & vSession(0) Debug.Print "Email: " & vSession(1) Debug.Print "Remaining time: " & oRedis.TTL(sUserId & ":name") & " seconds" End If oRedis.DisConnect End Sub ``` ### 2. Counter ```vb Sub CounterExample() Dim oRedis As New cRedisClient If Not oRedis.Connect() Then Exit Sub ' Page visit count Dim sPage As String sPage = "page:/home" ' Increment visit count Dim lCount As Long lCount = oRedis.Incr(sPage) Debug.Print "Page visit count: " & lCount ' Article like count oRedis.Incr "article:1001:likes" oRedis.Incr "article:1001:likes" oRedis.Incr "article:1001:likes" Debug.Print "Article likes: " & oRedis.Get_("article:1001:likes") oRedis.DisConnect End Sub ``` ### 3. Distributed ID Generation ```vb Function GenerateId(ByVal sPrefix As String) As String Static oRedis As cRedisClient If oRedis Is Nothing Then Set oRedis = New cRedisClient If Not oRedis.Connect() Then Debug.Print "Connection failed" Exit Function End If End If Dim lId As Long lId = oRedis.Incr("id:" & sPrefix) GenerateId = sPrefix & ":" & lId End Function Sub TestIdGeneration() Debug.Print GenerateId("order") ' Output: order:1 Debug.Print GenerateId("order") ' Output: order:2 Debug.Print GenerateId("user") ' Output: user:1 Debug.Print GenerateId("order") ' Output: order:3 End Sub ``` ### 4. Rate Limiter ```vb Function RateLimit(ByVal sUserId As String, ByVal lLimit As Long) As Boolean Static oRedis As cRedisClient If oRedis Is Nothing Then Set oRedis = New cRedisClient If Not oRedis.Connect() Then Exit Function End If End If Dim sKey As String sKey = "ratelimit:" & sUserId Dim lCount As Long lCount = oRedis.Incr(sKey) ' Set expiration time on first request (1 minute) If lCount = 1 Then oRedis.Expire sKey, 60 End If ' Check if limit exceeded If lCount > lLimit Then Debug.Print "Limit exceeded, current requests: " & lCount RateLimit = False Else RateLimit = True End If End Function Sub TestRateLimit() Dim i As Long For i = 1 To 12 Debug.Print "Request " & i & ": " & IIf(RateLimit("user123", 10), "Allowed", "Denied") Next i End Sub ``` ### 5. Cache Management ```vb Function GetCachedData(ByVal sKey As String, ByVal sDefault As String) As String Static oRedis As cRedisClient If oRedis Is Nothing Then Set oRedis = New cRedisClient oRedis.Connect End If Dim sValue As String sValue = oRedis.Get_(sKey) If sValue = "" Then ' Cache miss, return default value GetCachedData = sDefault ' Store default value in cache with 1 hour expiration oRedis.Set_ sKey, sDefault, , 3600 Else GetCachedData = sValue End If End Function Sub TestCache() Debug.Print "First fetch: " & GetCachedData("config:appname", "MyApp") Debug.Print "Second fetch: " & GetCachedData("config:appname", "MyApp") End Sub ``` ## Complete Example ```vb Sub Example_StringOperations() Dim oRedis As New cRedisClient If Not oRedis.Connect() Then Debug.Print "Connection failed: " & oRedis.LastError Exit Sub End If ' Set values oRedis.Set_ "name", "Zhang San" oRedis.Set_ "age", "25" ' Get values Debug.Print "Name: " & oRedis.Get_("name") Debug.Print "Age: " & oRedis.Get_("age") ' Set expiration time oRedis.Expire "name", 300 ' Check remaining time Debug.Print "name remaining TTL: " & oRedis.TTL("name") & " seconds" ' Counter example oRedis.Set_ "counter", "10" Debug.Print "Initial value: " & oRedis.Get_("counter") Debug.Print "After increment: " & oRedis.Incr("counter") Debug.Print "Increment again: " & oRedis.Incr("counter") Debug.Print "After decrement: " & oRedis.Decr("counter") ' Batch operations oRedis.MSet "user:1", "Zhang San", "user:2", "Li Si", "user:3", "Wang Wu" Dim vUsers As Variant vUsers = oRedis.MGet("user:1", "user:2", "user:3") Debug.Print vbCrLf & "Batch fetch results:" Dim i As Long If IsArray(vUsers) Then For i = 0 To UBound(vUsers) Debug.Print " User" & (i + 1) & ": " & vUsers(i) Next End If oRedis.DisConnect End Sub ``` --- --- url: /en/packages/vbccr/system/sysinfo.md description: >- SysInfo Control - VBCCR Development Manual, Complete API Reference Based on Source Code --- # SysInfo Control Provides system event monitoring, including notifications for device changes, power status, display setting changes, and theme changes. Invisible at runtime. ## Enumerations ### SysDeviceTypeConstants Device type constants. | Constant | Value | Description | |------|-----|------| | SysDeviceTypeOEM | DBT\_DEVTYP\_OEM | OEM device | | SysDeviceTypeDevNode | DBT\_DEVTYP\_DEVNODE | Device node | | SysDeviceTypeVolume | DBT\_DEVTYP\_VOLUME | Volume device | | SysDeviceTypePort | DBT\_DEVTYP\_PORT | Port device | | SysDeviceTypeDevInterface | DBT\_DEVTYP\_DEVICEINTERFACE | Device interface | ### SysACStatusConstants AC power status constants. | Constant | Value | Description | |------|-----|------| | SysACStatusOffline | 0 | Offline (on battery) | | SysACStatusOnline | 1 | Online (on AC power) | | SysACStatusUnknown | 255 | Unknown | ### SysBatteryStatusConstants Battery status constants. | Constant | Value | Description | |------|-----|------| | SysBatteryStatusHigh | 1 | Battery high | | SysBatteryStatusLow | 2 | Battery low | | SysBatteryStatusCritical | 4 | Battery critically low | | SysBatteryStatusCharging | 8 | Battery charging | | SysBatteryStatusNone | 128 | No battery | | SysBatteryStatusUnknown | 255 | Unknown | ## Properties ### Name ```vb Public Property Get Name() As String ``` Returns the name used to identify the object in code. ### Tag ```vb Public Property Get Tag() As String Public Property Let Tag(ByVal Value As String) ``` Stores extra data needed by the program. ### Parent ```vb Public Property Get Parent() As Object ``` Returns the object that contains the object. ### hMain ```vb Public Property Get hMain() As LongPtr ``` Returns the main window handle. ### ACStatus ```vb Public Property Get ACStatus() As SysACStatusConstants ``` Returns the AC power status. ### BatteryFullTime ```vb Public Property Get BatteryFullTime() As Long ``` Returns the time remaining for the battery to be fully charged (seconds). ### BatteryLifePercent ```vb Public Property Get BatteryLifePercent() As Integer ``` Returns the remaining battery life percentage. ### BatteryLifeTime ```vb Public Property Get BatteryLifeTime() As Long ``` Returns the remaining battery life (seconds). ### BatteryStatus ```vb Public Property Get BatteryStatus() As SysBatteryStatusConstants ``` Returns the battery status. ### WorkAreaLeft ```vb Public Property Get WorkAreaLeft() As Single ``` Returns the left margin of the work area. ### WorkAreaTop ```vb Public Property Get WorkAreaTop() As Single ``` Returns the top margin of the work area. ### WorkAreaWidth ```vb Public Property Get WorkAreaWidth() As Single ``` Returns the width of the work area. ### WorkAreaHeight ```vb Public Property Get WorkAreaHeight() As Single ``` Returns the height of the work area. ### ScrollBarSize ```vb Public Property Get ScrollBarSize() As Single ``` Returns the scrollbar size. ## Events ### SysColorsChanged ```vb Public Event SysColorsChanged() ``` Fired when system colors change. ### SettingChanged ```vb Public Event SettingChanged(ByVal Item As Long, ByVal Section As String) ``` Fired when a system setting changes. Item is the setting item, Section is the setting section. ### DevModeChanged ```vb Public Event DevModeChanged() ``` Fired when device mode changes. ### TimeChanged ```vb Public Event TimeChanged() ``` Fired when the system time changes. ### FontChanged ```vb Public Event FontChanged() ``` Fired when the system font changes. ### DisplayChanged ```vb Public Event DisplayChanged(ByVal NewColorDepth As Long, ByVal NewWidth As Single, ByVal NewHeight As Single) ``` Fired when display settings change. NewColorDepth is the new color depth, NewWidth/NewHeight is the new resolution. ### DeviceArrival ```vb Public Event DeviceArrival(ByVal DeviceType As SysDeviceTypeConstants, ByVal DeviceID As Long, ByVal DeviceName As String, ByVal DeviceData As Long) ``` Fired when a device is inserted. ### DeviceQueryRemove ```vb Public Event DeviceQueryRemove(ByVal DeviceType As SysDeviceTypeConstants, ByVal DeviceID As Long, ByVal DeviceName As String, ByVal DeviceData As Long, ByRef Cancel As Boolean) ``` Fired when a device is about to be removed. Set Cancel to True to prevent removal. ### DeviceQueryRemoveFailed ```vb Public Event DeviceQueryRemoveFailed(ByVal DeviceType As SysDeviceTypeConstants, ByVal DeviceID As Long, ByVal DeviceName As String, ByVal DeviceData As Long) ``` Fired when a device removal query fails. ### DeviceRemoveComplete ```vb Public Event DeviceRemoveComplete(ByVal DeviceType As SysDeviceTypeConstants, ByVal DeviceID As Long, ByVal DeviceName As String, ByVal DeviceData As Long) ``` Fired when a device removal is completed. ### DeviceRemovePending ```vb Public Event DeviceRemovePending(ByVal DeviceType As SysDeviceTypeConstants, ByVal DeviceID As Long, ByVal DeviceName As String, ByVal DeviceData As Long) ``` Fired when a device is about to be removed. ### DevNodesChanged ```vb Public Event DevNodesChanged() ``` Fired when device nodes change. ### QueryChangeConfig ```vb Public Event QueryChangeConfig(ByRef Cancel As Boolean) ``` Fired when the configuration is about to change. Set Cancel to True to prevent the change. ### ConfigChangeCancelled ```vb Public Event ConfigChangeCancelled() ``` Fired when a configuration change is cancelled. ### ConfigChanged ```vb Public Event ConfigChanged() ``` Fired when a configuration change is completed. ### PowerQuerySuspend ```vb Public Event PowerQuerySuspend(ByRef Cancel As Boolean) ``` Fired when the system is about to suspend. Set Cancel to True to prevent suspension. ### PowerQuerySuspendFailed ```vb Public Event PowerQuerySuspendFailed() ``` Fired when a system suspend request fails. ### PowerResume ```vb Public Event PowerResume() ``` Fired when the system resumes from suspension. ### PowerStatusChanged ```vb Public Event PowerStatusChanged() ``` Fired when power status changes. ### PowerSuspend ```vb Public Event PowerSuspend() ``` Fired when the system is about to suspend. ### ThemeChanged ```vb Public Event ThemeChanged() ``` Fired when the system theme changes. ## Code Examples ### Basic Usage ```vb ' Monitor power status Private Sub SysInfo1_PowerStatusChanged() Select Case SysInfo1.ACStatus Case SysACStatusOnline Debug.Print "On AC power" Case SysACStatusOffline Debug.Print "On battery, remaining: " & SysInfo1.BatteryLifePercent & "%" End Select End Sub ' Monitor device changes Private Sub SysInfo1_DeviceArrival(ByVal DeviceType As SysDeviceTypeConstants, _ ByVal DeviceID As Long, ByVal DeviceName As String, ByVal DeviceData As Long) Debug.Print "Device inserted: " & DeviceName End Sub ' Monitor display setting changes Private Sub SysInfo1_DisplayChanged(ByVal NewColorDepth As Long, _ ByVal NewWidth As Single, ByVal NewHeight As Single) Debug.Print "Resolution: " & NewWidth & "x" & NewHeight & " Color depth: " & NewColorDepth End Sub ``` --- --- url: /en/packages/vbccr/views/tabstrip.md description: >- TabStrip Control - VBCCR Developer Reference, complete API documentation based on source code --- # TabStrip Control Provides a customizable tab container, supporting multiple placement positions, multi-row tabs, separators, owner-draw, and OLE drag-and-drop. ## Enumerations ### TbsPlacementConstants Tab placement position constants. | Constant | Value | Description | |----------|-------|-------------| | TbsPlacementTop | 0 | Top placement | | TbsPlacementBottom | 1 | Bottom placement | | TbsPlacementLeft | 2 | Left placement | | TbsPlacementRight | 3 | Right placement | ### TbsStyleConstants Tab control style constants. | Constant | Value | Description | |----------|-------|-------------| | TbsStyleTab | 0 | Standard tab style | | TbsStyleButton | 1 | Button style | | TbsStyleFlatButton | 2 | Flat button style | ### TbsTabStyleConstants Tab label style constants. | Constant | Value | Description | |----------|-------|-------------| | TbsTabStyleTab | 0 | Standard label style | | TbsTabStyleButton | 1 | Button label style | ### TbsTabWidthStyleConstants Tab width style constants. | Constant | Value | Description | |----------|-------|-------------| | TbsTabWidthStyleJustified | 0 | Auto size to label width | | TbsTabWidthStyleFixed | 1 | Fixed width | | TbsTabWidthStyleVariable | 2 | Variable width | ### TbsTabAlignmentConstants Tab label alignment constants. | Constant | Value | Description | |----------|-------|-------------| | TbsTabAlignmentNear | 0 | Aligned near the leading edge | | TbsTabAlignmentCenter | 1 | Center aligned | | TbsTabAlignmentFar | 2 | Aligned near the trailing edge | ### TbsHitResultConstants Hit test result constants. | Constant | Value | Description | |----------|-------|-------------| | TbsHitNowhere | 0 | No tab hit | | TbsHitTab | 1 | Tab hit | | TbsHitDivider | 2 | Divider hit | | TbsHitDisplay | 3 | Display area hit | ### TbsDrawModeConstants Owner-draw mode constants. | Constant | Value | Description | |----------|-------|-------------| | TbsDrawModeNormal | 0 | Normal drawing | | TbsDrawModeOwnerDraw | 1 | Owner-draw mode | ## Properties ### Name ```vb Public Property Get Name() As String ``` Returns the name used to identify the object in code. ### Tag ```vb Public Property Get Tag() As String Public Property Let Tag(ByVal Value As String) ``` Stores extra data needed by the program. ### Parent ```vb Public Property Get Parent() As Object ``` Returns the object that contains this object. ### Container ```vb Public Property Get Container() As Object Public Property Set Container(ByVal Value As Object) ``` Returns/sets the object's container. ### Left ```vb Public Property Get Left() As Single Public Property Let Left(ByVal Value As Single) ``` Returns/sets the distance between the object and the left edge of its container. ### Top ```vb Public Property Get Top() As Single Public Property Let Top(ByVal Value As Single) ``` Returns/sets the distance between the object and the top edge of its container. ### Width ```vb Public Property Get Width() As Single Public Property Let Width(ByVal Value As Single) ``` Returns/sets the width of the object. ### Height ```vb Public Property Get Height() As Single Public Property Let Height(ByVal Value As Single) ``` Returns/sets the height of the object. ### Visible ```vb Public Property Get Visible() As Boolean Public Property Let Visible(ByVal Value As Boolean) ``` Returns/sets whether the object is visible. ### ToolTipText ```vb Public Property Get ToolTipText() As String Public Property Let ToolTipText(ByVal Value As String) ``` Returns/sets the tooltip text displayed when the mouse hovers over the control. ### WhatsThisHelpID ```vb Public Property Get WhatsThisHelpID() As Long Public Property Let WhatsThisHelpID(ByVal Value As Long) ``` Returns/sets the associated context-sensitive help ID. ### DragIcon ```vb Public Property Get DragIcon() As IPictureDisp Public Property Let DragIcon(ByVal Value As IPictureDisp) Public Property Set DragIcon(ByVal Value As IPictureDisp) ``` Returns/sets the icon displayed during a drag-and-drop operation. ### DragMode ```vb Public Property Get DragMode() As Integer Public Property Let DragMode(ByVal Value As Integer) ``` Returns/sets the drag mode (manual or automatic). ### hWnd ```vb Public Property Get hWnd() As LongPtr ``` Returns the control handle. ### hWndUserControl ```vb Public Property Get hWndUserControl() As LongPtr ``` Returns the UserControl handle. ### Font ```vb Public Property Get Font() As StdFont Public Property Let Font(ByVal NewFont As StdFont) Public Property Set Font(ByVal NewFont As StdFont) ``` Returns/sets the font. ### VisualStyles ```vb Public Property Get VisualStyles() As Boolean Public Property Let VisualStyles(ByVal Value As Boolean) ``` Returns/sets whether visual styles are enabled. Requires comctl32.dll 6.0 or later. ### Enabled ```vb Public Property Get Enabled() As Boolean Public Property Let Enabled(ByVal Value As Boolean) ``` Returns/sets whether the object can respond to user-generated events. ### OLEDropMode ```vb Public Property Get OLEDropMode() As OLEDropModeConstants Public Property Let OLEDropMode(ByVal Value As OLEDropModeConstants) ``` Returns/sets whether the object can act as an OLE drop target. ### MousePointer ```vb Public Property Get MousePointer() As CCMousePointerConstants Public Property Let MousePointer(ByVal Value As CCMousePointerConstants) ``` Returns/sets the pointer type displayed when the mouse hovers over the control. See common enumerations. ### MouseIcon ```vb Public Property Get MouseIcon() As IPictureDisp Public Property Let MouseIcon(ByVal Value As IPictureDisp) Public Property Set MouseIcon(ByVal Value As IPictureDisp) ``` Returns/sets the custom mouse icon. ### MouseTrack ```vb Public Property Get MouseTrack() As Boolean Public Property Let MouseTrack(ByVal Value As Boolean) ``` Returns/sets whether events are raised when the mouse enters or leaves the control. ### RightToLeft ```vb Public Property Get RightToLeft() As Boolean Public Property Let RightToLeft(ByVal Value As Boolean) ``` Returns/sets the right-to-left display direction. ### RightToLeftLayout ```vb Public Property Get RightToLeftLayout() As Boolean Public Property Let RightToLeftLayout(ByVal Value As Boolean) ``` Returns/sets the right-to-left layout. ### RightToLeftMode ```vb Public Property Get RightToLeftMode() As CCRightToLeftModeConstants Public Property Let RightToLeftMode(ByVal Value As CCRightToLeftModeConstants) ``` Returns/sets the right-to-left mode. See common enumerations. ### BackColor ```vb Public Property Get BackColor() As OLE_COLOR Public Property Let BackColor(ByVal Value As OLE_COLOR) ``` Returns/sets the background color. ### ImageList ```vb Public Property Get ImageList() As Variant Public Property Let ImageList(ByVal Value As Variant) Public Property Set ImageList(ByVal Value As Variant) ``` Returns/sets the associated ImageList control. Can be an object reference, a string key name, or a LongPtr handle. ### Placement ```vb Public Property Get Placement() As TbsPlacementConstants Public Property Let Placement(ByVal Value As TbsPlacementConstants) ``` Returns/sets the tab placement position. ### MultiRow ```vb Public Property Get MultiRow() As Boolean Public Property Let MultiRow(ByVal Value As Boolean) ``` Returns/sets whether multiple rows of tabs are allowed. ### MultiSelect ```vb Public Property Get MultiSelect() As Boolean Public Property Let MultiSelect(ByVal Value As Boolean) ``` Returns/sets whether multiple tabs can be selected. ### HotTracking ```vb Public Property Get HotTracking() As Boolean Public Property Let HotTracking(ByVal Value As Boolean) ``` Returns/sets whether hot tracking is enabled. ### Style ```vb Public Property Get Style() As TbsStyleConstants Public Property Let Style(ByVal Value As TbsStyleConstants) ``` Returns/sets the tab control style. ### TabStyle ```vb Public Property Get TabStyle() As TbsTabStyleConstants Public Property Let TabStyle(ByVal Value As TbsTabStyleConstants) ``` Returns/sets the tab label style. ### TabWidthStyle ```vb Public Property Get TabWidthStyle() As TbsTabWidthStyleConstants Public Property Let TabWidthStyle(ByVal Value As TbsTabWidthStyleConstants) ``` Returns/sets the tab width style. ### TabFixedWidth ```vb Public Property Get TabFixedWidth() As Single Public Property Let TabFixedWidth(ByVal Value As Single) ``` Returns/sets the tab width in fixed width style. ### TabFixedHeight ```vb Public Property Get TabFixedHeight() As Single Public Property Let TabFixedHeight(ByVal Value As Single) ``` Returns/sets the tab height in fixed height style. ### TabMinWidth ```vb Public Property Get TabMinWidth() As Single Public Property Let TabMinWidth(ByVal Value As Single) ``` Returns/sets the minimum tab width. ### TabAlignment ```vb Public Property Get TabAlignment() As TbsTabAlignmentConstants Public Property Let TabAlignment(ByVal Value As TbsTabAlignmentConstants) ``` Returns/sets the tab label alignment. ### Separators ```vb Public Property Get Separators() As Boolean Public Property Let Separators(ByVal Value As Boolean) ``` Returns/sets whether separators are displayed between tabs. ### ShowTips ```vb Public Property Get ShowTips() As Boolean Public Property Let ShowTips(ByVal Value As Boolean) ``` Returns/sets whether tooltips are displayed. ### DrawMode ```vb Public Property Get DrawMode() As TbsDrawModeConstants Public Property Let DrawMode(ByVal Value As TbsDrawModeConstants) ``` Returns/sets the draw mode. ### TabScrollWheel ```vb Public Property Get TabScrollWheel() As Boolean Public Property Let TabScrollWheel(ByVal Value As Boolean) ``` Returns/sets whether the mouse scroll wheel can be used to switch tabs. ### DoubleBuffer ```vb Public Property Get DoubleBuffer() As Boolean Public Property Let DoubleBuffer(ByVal Value As Boolean) ``` Returns/sets whether double-buffered drawing is enabled. ### Transparent ```vb Public Property Get Transparent() As Boolean Public Property Let Transparent(ByVal Value As Boolean) ``` Returns/sets whether the tab control is transparent. ### Tabs ```vb Public Property Get Tabs() As TbsTabs ``` Returns the tabs collection. ### ClientLeft ```vb Public Property Get ClientLeft() As Single ``` Returns the left edge distance of the client area. ### ClientTop ```vb Public Property Get ClientTop() As Single ``` Returns the top edge distance of the client area. ### ClientWidth ```vb Public Property Get ClientWidth() As Single ``` Returns the width of the client area. ### ClientHeight ```vb Public Property Get ClientHeight() As Single ``` Returns the height of the client area. ### SelectedItem ```vb Public Property Get SelectedItem() As TbsTab Public Property Let SelectedItem(ByVal Value As TbsTab) ``` Returns/sets the currently selected tab. ### RowCount ```vb Public Property Get RowCount() As Long ``` Returns the number of tab rows. ## Methods ### Refresh ```vb Public Sub Refresh() ``` Forces a complete redraw of the object. ### DeselectAll ```vb Public Sub DeselectAll() ``` Deselects all tabs. ### HitTest ```vb Public Function HitTest(ByVal X As Single, ByVal Y As Single) As TbsHitResultConstants ``` Performs a hit test at the specified coordinates and returns the hit result. ### DrawBackground ```vb Public Sub DrawBackground(ByVal hdc As LongPtr, ByVal Left As Long, ByVal Top As Long, ByVal Right As Long, ByVal Bottom As Long) ``` Draws the tab control background in the specified device context. ### OLEDrag ```vb Public Sub OLEDrag() ``` Initiates an OLE drag-and-drop operation. ### Drag ```vb Public Sub Drag(Optional ByRef Action As Variant) ``` Starts, ends, or cancels a drag operation. ### SetFocus ```vb Public Sub SetFocus() ``` Sets focus to the control. ### ZOrder ```vb Public Sub ZOrder(Optional ByRef Position As Variant) ``` Sets the Z-order. ## Events ### TabBeforeClick ```vb Public Event TabBeforeClick(ByVal Tab As TbsTab, ByRef Cancel As Boolean) ``` Raised before a tab is about to be clicked. Set Cancel to True to prevent the switch. ### TabClick ```vb Public Event TabClick(ByVal Tab As TbsTab) ``` Raised when a tab is clicked. ### ItemDraw ```vb Public Event ItemDraw(ByVal Index As Long, ByVal ItemData As Long, ByVal hdc As LongPtr, ByVal Left As Long, ByVal Top As Long, ByVal Right As Long, ByVal Bottom As Long) ``` Raised when a tab is drawn in owner-draw mode. ### PreviewKeyDown ```vb Public Event PreviewKeyDown(KeyCode As Integer, Shift As Integer) ``` Raised before the KeyDown event, for preprocessing keyboard input. ### PreviewKeyUp ```vb Public Event PreviewKeyUp(KeyCode As Integer, Shift As Integer) ``` Raised before the KeyUp event. ### KeyDown ```vb Public Event KeyDown(KeyCode As Integer, Shift As Integer) ``` Raised when a keyboard key is pressed. ### KeyUp ```vb Public Event KeyUp(KeyCode As Integer, Shift As Integer) ``` Raised when a keyboard key is released. ### KeyPress ```vb Public Event KeyPress(KeyAscii As Integer) ``` Raised when an ANSI key is pressed and released. ### MouseDown ```vb Public Event MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` Raised when a mouse button is pressed. ### MouseMove ```vb Public Event MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` Raised when the mouse is moved. ### MouseUp ```vb Public Event MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` Raised when a mouse button is released. ### MouseEnter ```vb Public Event MouseEnter() ``` Raised when the mouse enters the control area. ### MouseLeave ```vb Public Event MouseLeave() ``` Raised when the mouse leaves the control area. ### OLECompleteDrag ```vb Public Event OLECompleteDrag(Effect As Long) ``` Raised when an OLE drag-and-drop operation is completed. ### OLEDragDrop ```vb Public Event OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single) ``` Raised when an OLE drag-and-drop operation is dropped. ### OLEDragOver ```vb Public Event OLEDragOver(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single, State As Integer) ``` Raised during an OLE drag-and-drop hover. ### OLEGiveFeedback ```vb Public Event OLEGiveFeedback(Effect As Long, DefaultCursors As Boolean) ``` Raised when OLE drag-and-drop gives feedback. ### OLESetData ```vb Public Event OLESetData(Data As DataObject, DataFormat As Integer) ``` Raised when OLE drag-and-drop sets data. ### OLEStartDrag ```vb Public Event OLEStartDrag(Data As DataObject, AllowedEffects As Long) ``` Raised when an OLE drag-and-drop operation starts. ## Sub-Objects ### TbsTab Class Tab object. #### TbsTab Properties #### Index ```vb Public Property Get Index() As Long ``` The index of the tab in the collection. #### Key ```vb Public Property Get Key() As String Public Property Let Key(ByVal Value As String) ``` The tab's unique identifier key. #### Tag ```vb Public Property Get Tag() As Variant Public Property Let Tag(ByVal Value As Variant) ``` Extra data. #### Caption ```vb Public Property Get Caption() As String Public Property Let Caption(ByVal Value As String) ``` Tab caption. #### ToolTipText ```vb Public Property Get ToolTipText() As String Public Property Let ToolTipText(ByVal Value As String) ``` ToolTip text. #### Image ```vb Public Property Get Image() As Variant Public Property Let Image(ByVal Value As Variant) ``` Tab image. #### ImageIndex ```vb Public Property Get ImageIndex() As Long ``` Image index. #### Selected ```vb Public Property Get Selected() As Boolean Public Property Let Selected(ByVal Value As Boolean) ``` Whether selected. #### Pressed ```vb Public Property Get Pressed() As Boolean Public Property Let Pressed(ByVal Value As Boolean) ``` Whether pressed. #### HighLighted ```vb Public Property Get HighLighted() As Boolean Public Property Let HighLighted(ByVal Value As Boolean) ``` Whether highlighted. #### Left ```vb Public Property Get Left() As Single ``` Tab left edge distance. #### Top ```vb Public Property Get Top() As Single ``` Tab top edge distance. #### Width ```vb Public Property Get Width() As Single ``` Tab width. #### Height ```vb Public Property Get Height() As Single ``` Tab height. ### TbsTabs Class Tabs collection. #### TbsTabs Members #### NewEnum ```vb Public Function NewEnum() As IUnknown ``` Enumerator (hidden). #### Add ```vb Public Function Add(Optional ByVal Index As Variant, Optional ByVal Key As Variant, Optional ByVal Caption As Variant, Optional ByVal Image As Variant) As TbsTab ``` Adds a tab. #### Item ```vb Public Function Item(ByVal Index As Variant) As TbsTab ``` Gets a tab (default member). #### Exists ```vb Public Function Exists(ByVal Index As Variant) As Boolean ``` Checks if a tab exists. #### Count ```vb Public Property Get Count() As Long ``` Tab count. #### Clear ```vb Public Sub Clear() ``` Clears all tabs. #### Remove ```vb Public Sub Remove(ByVal Index As Variant) ``` Removes a tab. ## Code Examples ### Basic Usage ```vb ' Create tabs With TabStrip1.Tabs .Add , "Tab1", "General" .Add , "Tab2", "Advanced" .Add , "Tab3", "About" End With ' Set tab style TabStrip1.Placement = TbsPlacementTop TabStrip1.Style = TbsStyleTab TabStrip1.TabWidthStyle = TbsTabWidthStyleFixed TabStrip1.TabFixedWidth = 80 TabStrip1.MultiRow = False TabStrip1.HotTracking = True ' Handle tab switching Private Sub TabStrip1_TabBeforeClick(ByVal Tab As TbsTab, ByRef Cancel As Boolean) If Tab.Key = "Tab3" Then Cancel = True MsgBox "This tab is disabled" End If End Sub Private Sub TabStrip1_TabClick(ByVal Tab As TbsTab) MsgBox "Selected tab: " & Tab.Caption End Sub ' Use client area to position child controls Private Sub TabStrip1_TabClick(ByVal Tab As TbsTab) Dim l As Single, t As Single l = TabStrip1.ClientLeft t = TabStrip1.ClientTop Frame1.Move l, t, TabStrip1.ClientWidth, TabStrip1.ClientHeight End Sub ``` --- --- url: /en/vbman/Toast/technical.md --- # Technical Details Internal implementation principles and technical details of cToast. ## Table of Contents * [Internal Architecture](#internal-architecture) * [Form Implementation](#form-implementation) * [Stacking Algorithm](#stacking-algorithm) * [Event Mechanism](#event-mechanism) * [Lifecycle Management](#lifecycle-management) * [Performance Optimization](#performance-optimization) * [Extension Suggestions](#extension-suggestions) ## Internal Architecture ### Class Structure ``` cToast (Main class) ├── Private members │ ├── m_ePos ' Current position │ ├── m_eState ' Current state │ ├── m_eTheme ' Current theme │ ├── m_lIndex ' Stack index │ ├── m_sTagName ' Unique identifier │ └── m_colToasts ' Collection of all popups │ ├── Public methods (chain call) │ ├── Pos() │ ├── State() │ ├── Theme() │ ├── InstIndex() │ ├── Tag() │ └── Show() │ ├── Management methods │ ├── CloseMe() │ ├── CloseAll() │ └── Exists() │ └── Properties ├── Count ├── ActiveKeys └── Events ├── OnToastCountChange └── OnCloseAll ``` ### Data Flow ``` User Call → Set Properties → Check Tag → Calculate Index → Create Form → Display → Timer Countdown → Close → Remove from Collection ``` ## Form Implementation ### FToastCenter - Center Form **Used Positions**: Center, CenterTop, CenterBottom **Key Features**: * Center display mode * Bottom color bar indicating state * Simple and clean design * Suitable for important notifications **Technical Implementation**: ```vb ' Form properties .BorderStyle = 0 ' No border .Caption = "" ' No title .ControlBox = False ' No control box .Moveable = False ' Non-movable .ShowInTaskbar = False ' Not shown in taskbar .StartUpPosition = 0 ' Manual positioning ' Shadow effect (using cShadow component) Set Shadow = New cShadow Shadow.Add Me ``` **Display Algorithm**: 1. Calculate screen center position 2. Apply vertical offset based on stack index 3. CenterTop: Positive offset (stack down) 4. CenterBottom: Negative offset (stack up) 5. Center: No offset (overlay mode) ### FToastDrawer - Side Form **Used Positions**: LeftTop, LeftBottom, LeftCenter, RightTop, RightBottom, RightCenter **Key Features**: * Side drawer style * Side color bar indicating state * Contains title and content two lines * Suitable for stacking multiple messages **Technical Implementation**: ```vb ' Form properties .BorderStyle = 0 ' No border .Caption = "" ' No title .ControlBox = False ' No control box .Moveable = False ' Non-movable .ShowInTaskbar = False ' Not shown in taskbar .StartUpPosition = 0 ' Manual positioning ' Layout ' Left side: Color bar (based on state) ' Right side: Title and content ``` **Display Algorithm**: 1. Calculate screen edge position 2. Apply horizontal/vertical offset based on stack index 3. Top positions: Positive vertical offset (stack down) 4. Bottom positions: Negative vertical offset (stack up) 5. Center positions: No vertical offset (overlay mode) ## Stacking Algorithm ### Auto Stack Index Calculation ```vb Private Function GetNextIndex() As Long ' Get all popups with current position Dim colPos As Collection Set colPos = GetToastsByPosition(m_ePos) ' Return current count as new index GetNextIndex = colPos.Count End Function ``` ### Stack Order Rules **Top Positions (CenterTop, LeftTop, RightTop)**: * Index 0: Topmost * Index increases downward * New popups appear at the bottom ``` Index 0 ━━━━━━━━━━━ Index 1 ━━━━━━━━━━━ Index 2 ━━━━━━━━━━━ (Newest) ``` **Bottom Positions (CenterBottom, LeftBottom, RightBottom)**: * Index 0: Bottommost * Index increases upward * New popups appear at the top ``` Index 2 ━━━━━━━━━━━ (Newest) Index 1 ━━━━━━━━━━━ Index 0 ━━━━━━━━━━━ ``` **Center Positions (Center, LeftCenter, RightCenter)**: * Overlay mode, only one popup visible * New popups overlay old ones * Index calculation exists but does not affect display ### Offset Calculation ```vb Private Sub CalculatePosition() Dim x As Long, y As Long Dim offset As Long ' Base position based on position type Select Case m_ePos Case CenterTop x = Screen.Width / 2 - Me.Width / 2 offset = m_lIndex * (Me.Height + 10) y = 10 + offset Case CenterBottom x = Screen.Width / 2 - Me.Width / 2 offset = m_lIndex * (Me.Height + 10) y = Screen.Height - Me.Height - 10 - offset Case LeftTop x = 10 offset = m_lIndex * (Me.Height + 10) y = 10 + offset Case LeftBottom x = 10 offset = m_lIndex * (Me.Height + 10) y = Screen.Height - Me.Height - 10 - offset Case RightTop x = Screen.Width - Me.Width - 10 offset = m_lIndex * (Me.Height + 10) y = 10 + offset Case RightBottom x = Screen.Width - Me.Width - 10 offset = m_lIndex * (Me.Height + 10) y = Screen.Height - Me.Height - 10 - offset ' Center positions - no offset Case Center x = Screen.Width / 2 - Me.Width / 2 y = Screen.Height / 2 - Me.Height / 2 Case LeftCenter x = 10 y = Screen.Height / 2 - Me.Height / 2 Case RightCenter x = Screen.Width - Me.Width - 10 y = Screen.Height / 2 - Me.Height / 2 End Select Me.Move x, y End Sub ``` ## Event Mechanism ### Event Declaration ```vb Public Event OnToastCountChange(ByVal TagName As String, _ ByVal IsDelete As Boolean, _ ByVal CurrentCount As Long) Public Event OnCloseAll(ByVal ClosedCount As Long) ``` ### Event Trigger Timing **OnToastCountChange**: 1. Triggered when a new popup is created 2. Triggered when a popup is closed 3. Provides change details (add/delete, current count) **OnCloseAll**: 1. Triggered after all popups are closed by CloseAll 2. Only triggered once for batch operations 3. Provides total number of popups closed ### Event Implementation in Form ```vb ' In FToastCenter and FToastDrawer forms Private Sub Form_Unload(Cancel As Integer) ' Notify parent class when form closes On Error Resume Next RaiseEvent OnClose On Error GoTo 0 End Sub ' cToast handles event Private Sub HandlePopupClose() m_colToasts.Remove m_sTagName RaiseEvent OnToastCountChange(m_sTagName, True, m_colToasts.Count) End Sub ``` ### Event Best Practices ```vb ' In user code Private WithEvents Toast As cToast Private Sub Toast_OnToastCountChange(ByVal TagName As String, _ ByVal IsDelete As Boolean, _ ByVal CurrentCount As Long) ' Update UI UpdateCountLabel CurrentCount ' Log If IsDelete Then Log "Popup " & TagName & " closed" End If End Sub ``` ## Lifecycle Management ### Creation Lifecycle ``` 1. User calls .Show() ↓ 2. Check if Tag exists ↓ 3. If exists, return (no duplicate creation) ↓ 4. If not exists, calculate position and index ↓ 5. Create form (FToastCenter or FToastDrawer) ↓ 6. Set form properties and content ↓ 7. Add to collection ↓ 8. Trigger OnToastCountChange event ↓ 9. Start timer countdown ↓ 10. Display form ``` ### Display Lifecycle ``` 1. Form displayed ↓ 2. Timer starts countdown ↓ 3. User can hover to pause countdown ↓ 4. Countdown completes or user manually closes ↓ 5. Form starts unload ↓ 6. Remove from collection ↓ 7. Trigger OnToastCountChange event ↓ 8. Form completely unloaded ``` ### Resource Cleanup ```vb ' cToast cleanup Public Sub CloseAll() Dim i As Long Dim count As Long count = m_colToasts.Count ' Close all popups For i = count To 1 Step -1 On Error Resume Next Dim frm As Object Set frm = m_colToasts(i) Unload frm On Error GoTo 0 Next i ' Clear collection Set m_colToasts = New Collection ' Trigger event RaiseEvent OnCloseAll(count) End Sub ' Form cleanup Private Sub Form_Unload(Cancel As Integer) ' Release shadow object If Not Shadow Is Nothing Then Set Shadow = Nothing End If ' Release other resources ' ... End Sub ``` ## Performance Optimization ### Memory Management 1. **Prompt Resource Release** ```vb ' User code should release object references promptly Set Toast = Nothing ``` 2. **Avoid Memory Leaks** ```vb ' Check if exists before creating If Not Toast.Exists("msg1") Then Toast.Tag("msg1").Show "Message", 0 End If ``` 3. **Collection Management** ```vb ' Forms are automatically removed from collection on unload ' No manual intervention needed ``` ### Display Performance 1. **Delay Loading** ```vb ' Forms are only created when needed ' Not pre-loaded at program start ``` 2. **Optimized Drawing** ```vb ' Use simple controls ' Avoid complex graphics operations ' Ensure smooth animations ``` 3. **Timer Optimization** ```vb ' Each form has its own timer ' No shared timer conflicts ``` ### Event Optimization 1. **Avoid Frequent Triggers** ```vb ' OnCloseAll only triggers once for batch operations ' Avoids excessive event triggers ``` 2. **Event Debouncing** ```vb ' User can implement their own debouncing logic Private Sub Toast_OnToastCountChange(...) Static lastTime As Long Dim currentTime As Long currentTime = GetTickCount() If currentTime - lastTime < 100 Then Exit Sub lastTime = currentTime ' Process event End Sub ``` ## Extension Suggestions ### Custom Theme Extension ```vb ' Add custom theme enumeration Public Enum EnumCustomTheme CustomLight = 0 CustomDark = 1 CustomBlue = 2 CustomGreen = 3 End Enum ' Extend Theme method to support custom themes Public Function ThemeCustom(ByVal eTheme As EnumCustomTheme) As cToast ' Set custom theme ' ... Set ThemeCustom = Me End Function ``` ### Custom Icon Extension ```vb ' Add custom icon support Public Function Icon(ByVal IconPath As String) As cToast ' Set custom icon m_sIconPath = IconPath Set Icon = Me End Function ``` ### Animation Extension ```vb ' Add animation effect Public Enum EnumAnimation None = 0 FadeIn = 1 SlideIn = 2 ScaleIn = 3 End Enum Public Function Animation(ByVal eAnim As EnumAnimation) As cToast ' Set animation type m_eAnimation = eAnim Set Animation = Me End Function ``` ### Sound Extension ```vb ' Add sound notification Public Function Sound(ByVal SoundFile As String) As cToast ' Play sound on show PlaySound SoundFile Set Sound = Me End Function ``` ### Click Action Extension ```vb ' Add click action Public Sub OnClick(ByVal Action As String) m_sClickAction = Action End Sub ' Handle form click event Private Sub Form_Click() ' Execute action ExecuteAction m_sClickAction End Sub ``` ### Progress Bar Extension ```vb ' Add progress bar support Public Function Progress(ByVal Value As Long, ByVal Max As Long) As cToast ' Show progress bar m_lProgress = Value m_lProgressMax = Max UpdateProgressBar Set Progress = Me End Function ``` ### Multi-Line Content Extension ```vb ' Support for richer text formatting Public Function RichText(ByVal HTML As String) As cToast ' Support HTML or RTF format m_sRichContent = HTML Set RichText = Me End Function ``` ### Auto Dismiss on Click Extension ```vb ' Click to close Public Function DismissOnClick() As cToast m_bDismissOnClick = True Set DismissOnClick = Me End Function ' Handle form click Private Sub Form_Click() If m_bDismissOnClick Then Unload Me End If End Sub ``` ## Security Considerations ### Content Injection Prevention ```vb ' Validate user input before displaying Private Function ValidateContent(ByVal Content As String) As String ' Remove dangerous characters ' Prevent XSS injection ' ... ValidateContent = Sanitize(Content) End Function ``` ### Tag Name Security ```vb ' Prevent malicious Tag names Private Function ValidateTagName(ByVal TagName As String) As Boolean ' Check length If Len(TagName) > 100 Then Exit Function ' Check for illegal characters If InStr(TagName, "|") > 0 Then Exit Function If InStr(TagName, ";") > 0 Then Exit Function ValidateTagName = True End Function ``` ## Compatibility Notes ### VB6 Version Compatibility * Minimum required: VB6 SP6 * Recommended: VB6 SP6 with latest updates ### Windows Version Compatibility * Windows XP and later * Best performance on Windows 7 and later ### Dependency Components * cShadow (for shadow effects) * Standard VB6 runtime libraries ## Debugging Tips ### Enable Debug Output ```vb ' Add debug logging Private Sub DebugLog(ByVal msg As String) Debug.Print "[cToast] " & msg End Sub ' Log at key points DebugLog "Creating popup: " & TagName DebugLog "Closing popup: " & TagName ``` ### Check Popup Status ```vb ' List all active popups Sub ListActiveToasts() Dim Toast As New cToast Dim Keys As Collection Dim Key As Variant Set Keys = Toast.ActiveKeys Debug.Print "Active popups: " & Toast.Count For Each Key In Keys Debug.Print " - " & CStr(Key) Next Key End Sub ``` ### Monitor Event Triggers ```vb Private WithEvents Toast As cToast Private Sub Toast_OnToastCountChange(ByVal TagName As String, _ ByVal IsDelete As Boolean, _ ByVal CurrentCount As Long) Debug.Print "Event: " & TagName & " " & _ IIf(IsDelete, "Deleted", "Added") & _ ", Count: " & CurrentCount End Sub ``` ## Known Limitations 1. **Maximum Number of Popups**: Limited by system resources, recommended not to exceed 50 2. **Display Position**: 9 preset positions only, does not support arbitrary positioning 3. **Content Length**: Extremely long text may affect display效果 4. **Multi-Monitor Support**: Default is primary monitor, multi-monitor support requires modification 5. **Form Style**: Cannot modify basic form properties (borderless, no control box) --- --- url: /en/packages/vbccr/text/textboxw.md description: >- TextBoxW Control - VBCCR Development Manual, complete API reference based on source code --- # TextBoxW Control Provides an enhanced text box with support for Unicode, password characters, balloon tips, network address validation, drag-and-drop files, and OLE drag-and-drop. ## Enumerations ### TxtCharacterCasingConstants Character casing constants. | Constant | Value | Description | |----------|-------|-------------| | TxtCharacterCasingNormal | 0 | Normal (no case conversion) | | TxtCharacterCasingUpper | 1 | Convert to uppercase | | TxtCharacterCasingLower | 2 | Convert to lowercase | ### TxtIconConstants Balloon tip icon constants. | Constant | Value | Description | |----------|-------|-------------| | TxtIconNone | 0 | No icon | | TxtIconInfo | 1 | Information icon | | TxtIconWarning | 2 | Warning icon | | TxtIconError | 3 | Error icon | ### TxtNetAddressFormatConstants Network address format constants. | Constant | Value | Description | |----------|-------|-------------| | TxtNetAddressFormatString | 0 | String format | | TxtNetAddressFormatHostName | 1 | Host name format | | TxtNetAddressFormatIPv4 | 2 | IPv4 format | | TxtNetAddressFormatIPv6 | 3 | IPv6 format | ### TxtNetAddressTypeConstants Network address type constants. | Constant | Value | Description | |----------|-------|-------------| | TxtNetAddressTypeNone | 0 | None | | TxtNetAddressTypeIPv4 | 1 | IPv4 address | | TxtNetAddressTypeIPv6 | 2 | IPv6 address | | TxtNetAddressTypeIPv6WithScope | 3 | IPv6 address with scope | | TxtNetAddressTypeDNS | 4 | DNS name | | TxtNetAddressTypeNetBIOS | 5 | NetBIOS name | | TxtNetAddressTypeUnspecified | 6 | Unspecified type | | TxtNetAddressTypeNamedPipe | 7 | Named pipe | | TxtNetAddressTypeEmailAddress | 8 | Email address | | TxtNetAddressTypeURL | 9 | URL address | | TxtNetAddressTypeURLKnownSuffix | 10 | URL with known suffix | | TxtNetAddressTypeFriendlyDNS | 11 | Friendly DNS name | | TxtNetAddressTypeDNSSimpleLabel | 12 | Single-label DNS name | | TxtNetAddressTypeAddressMask | 13 | Address mask | | TxtNetAddressTypeFileName | 14 | File name | | TxtNetAddressTypeAny | 15 | Any address | | TxtNetAddressTypeAnyLocal | 16 | Any local address | | TxtNetAddressTypeIPv4MappedIPv6 | 17 | IPv4-mapped IPv6 address | | TxtNetAddressTypeIPv4TranslatedIPv6 | 18 | IPv4-translated IPv6 address | | TxtNetAddressTypeIPv4TeredoIPv6 | 19 | Teredo IPv6 address | ## Properties ### Name ```vb Public Property Get Name() As String ``` Returns the name used to identify the object in code. ### Tag ```vb Public Property Get Tag() As String Public Property Let Tag(ByVal Value As String) ``` Stores extra data needed by the program. ### Parent ```vb Public Property Get Parent() As Object ``` Returns the object that contains the object. ### Container ```vb Public Property Get Container() As Object Public Property Set Container(ByVal Value As Object) ``` Returns/sets the container of the object. ### Left ```vb Public Property Get Left() As Single Public Property Let Left(ByVal Value As Single) ``` Returns/sets the distance between the internal left edge of the object and the left edge of its container. ### Top ```vb Public Property Get Top() As Single Public Property Let Top(ByVal Value As Single) ``` Returns/sets the distance between the internal top edge of the object and the top edge of its container. ### Width ```vb Public Property Get Width() As Single Public Property Let Width(ByVal Value As Single) ``` Returns/sets the width of the object. ### Height ```vb Public Property Get Height() As Single Public Property Let Height(ByVal Value As Single) ``` Returns/sets the height of the object. ### Visible ```vb Public Property Get Visible() As Boolean Public Property Let Visible(ByVal Value As Boolean) ``` Returns/sets whether the object is visible. ### ToolTipText ```vb Public Property Get ToolTipText() As String Public Property Let ToolTipText(ByVal Value As String) ``` Returns/sets the tooltip text displayed when the mouse hovers. ### WhatsThisHelpID ```vb Public Property Get WhatsThisHelpID() As Long Public Property Let WhatsThisHelpID(ByVal Value As Long) ``` Returns/sets the associated context help ID. ### DragIcon ```vb Public Property Get DragIcon() As IPictureDisp Public Property Let DragIcon(ByVal Value As IPictureDisp) Public Property Set DragIcon(ByVal Value As IPictureDisp) ``` Returns/sets the icon displayed during drag-and-drop operations. ### DragMode ```vb Public Property Get DragMode() As Integer Public Property Let DragMode(ByVal Value As Integer) ``` Returns/sets the drag mode (manual or automatic). ### hWnd ```vb Public Property Get hWnd() As LongPtr ``` Returns the control handle. ### hWndUserControl ```vb Public Property Get hWndUserControl() As LongPtr ``` Returns the UserControl handle. ### Font ```vb Public Property Get Font() As StdFont Public Property Let Font(ByVal NewFont As StdFont) Public Property Set Font(ByVal NewFont As StdFont) ``` Returns/sets the font. ### VisualStyles ```vb Public Property Get VisualStyles() As Boolean Public Property Let VisualStyles(ByVal Value As Boolean) ``` Returns/sets whether visual styles are enabled. Requires comctl32.dll version 6.0 or later. ### BackColor ```vb Public Property Get BackColor() As OLE_COLOR Public Property Let BackColor(ByVal Value As OLE_COLOR) ``` Returns/sets the background color. ### ForeColor ```vb Public Property Get ForeColor() As OLE_COLOR Public Property Let ForeColor(ByVal Value As OLE_COLOR) ``` Returns/sets the foreground color. ### Enabled ```vb Public Property Get Enabled() As Boolean Public Property Let Enabled(ByVal Value As Boolean) ``` Returns/sets whether the object can respond to user events. ### AllowDropFiles ```vb Public Property Get AllowDropFiles() As Boolean Public Property Let AllowDropFiles(ByVal Value As Boolean) ``` Returns/sets whether drag-and-drop files are allowed. ### OLEDragMode ```vb Public Property Get OLEDragMode() As Integer Public Property Let OLEDragMode(ByVal Value As Integer) ``` Returns/sets the OLE drag mode. ### OLEDragDropScroll ```vb Public Property Get OLEDragDropScroll() As Boolean Public Property Let OLEDragDropScroll(ByVal Value As Boolean) ``` Returns/sets whether auto-scrolling is enabled during OLE drag-and-drop. ### OLEDropMode ```vb Public Property Get OLEDropMode() As OLEDropModeConstants Public Property Let OLEDropMode(ByVal Value As OLEDropModeConstants) ``` Returns/sets whether the object can act as an OLE drop target. ### MousePointer ```vb Public Property Get MousePointer() As CCMousePointerConstants Public Property Let MousePointer(ByVal Value As CCMousePointerConstants) ``` Returns/sets the type of mouse pointer displayed when the mouse hovers. See common enumerations. ### MouseIcon ```vb Public Property Get MouseIcon() As IPictureDisp Public Property Let MouseIcon(ByVal Value As IPictureDisp) Public Property Set MouseIcon(ByVal Value As IPictureDisp) ``` Returns/sets the custom mouse icon. ### MouseTrack ```vb Public Property Get MouseTrack() As Boolean Public Property Let MouseTrack(ByVal Value As Boolean) ``` Returns/sets whether events are triggered when the mouse enters or leaves the control. ### RightToLeft ```vb Public Property Get RightToLeft() As Boolean Public Property Let RightToLeft(ByVal Value As Boolean) ``` Returns/sets the right-to-left display direction. ### RightToLeftMode ```vb Public Property Get RightToLeftMode() As CCRightToLeftModeConstants Public Property Let RightToLeftMode(ByVal Value As CCRightToLeftModeConstants) ``` Returns/sets the right-to-left mode. See common enumerations. ### BorderStyle ```vb Public Property Get BorderStyle() As Integer Public Property Let BorderStyle(ByVal Value As Integer) ``` Returns/sets the border style. ### Text ```vb Public Property Get Text() As String Public Property Let Text(ByVal Value As String) ``` Returns/sets the text content. ### Default ```vb Public Property Get Default() As Boolean Public Property Let Default(ByVal Value As Boolean) ``` Returns/sets whether this is the default button (activated by pressing Enter). ### Alignment ```vb Public Property Get Alignment() As AlignmentConstants Public Property Let Alignment(ByVal Value As AlignmentConstants) ``` Returns/sets the text alignment. ### AllowOnlyNumbers ```vb Public Property Get AllowOnlyNumbers() As Boolean Public Property Let AllowOnlyNumbers(ByVal Value As Boolean) ``` Returns/sets whether only numeric input is allowed. ### Locked ```vb Public Property Get Locked() As Boolean Public Property Let Locked(ByVal Value As Boolean) ``` Returns/sets whether editing is locked (scrolling and selection are still allowed). ### HideSelection ```vb Public Property Get HideSelection() As Boolean Public Property Let HideSelection(ByVal Value As Boolean) ``` Returns/sets whether the highlight of the selected text is hidden when the control loses focus. ### PasswordChar ```vb Public Property Get PasswordChar() As String Public Property Let PasswordChar(ByVal Value As String) ``` Returns/sets the password masking character. ### UseSystemPasswordChar ```vb Public Property Get UseSystemPasswordChar() As Boolean Public Property Let UseSystemPasswordChar(ByVal Value As Boolean) ``` Returns/sets whether to use the system default password character. ### MultiLine ```vb Public Property Get MultiLine() As Boolean Public Property Let MultiLine(ByVal Value As Boolean) ``` Returns/sets whether multi-line text input is accepted. ### MaxLength ```vb Public Property Get MaxLength() As Long Public Property Let MaxLength(ByVal Value As Long) ``` Returns/sets the maximum number of characters. 0 means no limit. ### ScrollBars ```vb Public Property Get ScrollBars() As Integer Public Property Let ScrollBars(ByVal Value As Integer) ``` Returns/sets the scroll bar style. ### CueBanner ```vb Public Property Get CueBanner() As String Public Property Let CueBanner(ByVal Value As String) ``` Returns/sets the cue banner text (displayed when the control is empty). ### CueBannerAlways ```vb Public Property Get CueBannerAlways() As Boolean Public Property Let CueBannerAlways(ByVal Value As Boolean) ``` Returns/sets whether the cue banner is always displayed (even when the control has focus). ### CharacterCasing ```vb Public Property Get CharacterCasing() As TxtCharacterCasingConstants Public Property Let CharacterCasing(ByVal Value As TxtCharacterCasingConstants) ``` Returns/sets the character casing conversion mode. ### WantReturn ```vb Public Property Get WantReturn() As Boolean Public Property Let WantReturn(ByVal Value As Boolean) ``` Returns/sets whether pressing Enter in a multi-line text box inserts a line break. ### IMEMode ```vb Public Property Get IMEMode() As CCIMEModeConstants Public Property Let IMEMode(ByVal Value As CCIMEModeConstants) ``` Returns/sets the Input Method Editor (IME) mode. See common enumerations. ### NetAddressValidator ```vb Public Property Get NetAddressValidator() As Boolean Public Property Let NetAddressValidator(ByVal Value As Boolean) ``` Returns/sets whether network address validation is enabled. ### NetAddressType ```vb Public Property Get NetAddressType() As TxtNetAddressTypeConstants Public Property Let NetAddressType(ByVal Value As TxtNetAddressTypeConstants) ``` Returns/sets the type of network address validation. ### AllowOverType ```vb Public Property Get AllowOverType() As Boolean Public Property Let AllowOverType(ByVal Value As Boolean) ``` Returns/sets whether overtype mode is allowed. ### OverTypeMode ```vb Public Property Get OverTypeMode() As Boolean Public Property Let OverTypeMode(ByVal Value As Boolean) ``` Returns/sets whether overtype mode is active. ### Modified ```vb Public Property Get Modified() As Boolean Public Property Let Modified(ByVal Value As Boolean) ``` Returns/sets whether the text has been modified. ### TextLength ```vb Public Property Get TextLength() As Long ``` Returns the text length. ### SelStart ```vb Public Property Get SelStart() As Long Public Property Let SelStart(ByVal Value As Long) ``` Returns/sets the starting position of the selection. ### SelLength ```vb Public Property Get SelLength() As Long Public Property Let SelLength(ByVal Value As Long) ``` Returns/sets the length of the selection. ### SelText ```vb Public Property Get SelText() As String Public Property Let SelText(ByVal Value As String) ``` Returns/sets the text of the selection. ### LeftMargin ```vb Public Property Get LeftMargin() As Long Public Property Let LeftMargin(ByVal Value As Long) ``` Returns/sets the left margin. ### RightMargin ```vb Public Property Get RightMargin() As Long Public Property Let RightMargin(ByVal Value As Long) ``` Returns/sets the right margin. ## Methods ### Refresh ```vb Public Sub Refresh() ``` Forces a complete repaint of the object. ### Copy ```vb Public Sub Copy() ``` Copies the selection to the clipboard. ### Cut ```vb Public Sub Cut() ``` Cuts the selection to the clipboard. ### Paste ```vb Public Sub Paste() ``` Pastes the clipboard contents into the control. ### Clear ```vb Public Sub Clear() ``` Clears all text. ### Undo ```vb Public Sub Undo() ``` Undoes the last operation. ### CanUndo ```vb Public Function CanUndo() As Boolean ``` Returns whether an undo operation is available. ### ResetUndoQueue ```vb Public Sub ResetUndoQueue() ``` Resets the undo queue. ### OLEDrag ```vb Public Sub OLEDrag() ``` Initiates an OLE drag-and-drop operation. ### GetLine ```vb Public Function GetLine(ByVal LineIndex As Long) As String ``` Gets the text content of the specified line. ### GetLineCount ```vb Public Function GetLineCount() As Long ``` Gets the number of text lines. ### ScrollToLine ```vb Public Sub ScrollToLine(ByVal LineIndex As Long) ``` Scrolls to the specified line. ### ScrollToCaret ```vb Public Sub ScrollToCaret() ``` Scrolls to the caret position. ### CharFromPos ```vb Public Function CharFromPos(ByVal X As Long, ByVal Y As Long) As Long ``` Gets the character index from coordinates. ### GetLineFromChar ```vb Public Function GetLineFromChar(ByVal CharIndex As Long) As Long ``` Gets the line number from a character index. ### ShowBalloonTip ```vb Public Sub ShowBalloonTip(ByVal Title As String, ByVal Text As String, ByVal Icon As TxtIconConstants) ``` Displays a balloon tip. ### HideBalloonTip ```vb Public Sub HideBalloonTip() ``` Hides the balloon tip. ### ValidateNetAddress ```vb Public Function ValidateNetAddress() As Long ``` Validates the network address. Returns 0 if valid. ### ShowNetAddressErrorTip ```vb Public Sub ShowNetAddressErrorTip() ``` Displays a network address error tip based on the validation result. ### NetAddressFormat ```vb Public Property Get NetAddressFormat() As TxtNetAddressFormatConstants ``` Returns the network address format. ### NetAddressString ```vb Public Property Get NetAddressString() As String ``` Returns the network address string. ### NetAddressPortNumber ```vb Public Property Get NetAddressPortNumber() As Long ``` Returns the network address port number. ### NetAddressPrefixLength ```vb Public Property Get NetAddressPrefixLength() As Long ``` Returns the network address prefix length. ### Drag ```vb Public Sub Drag(Optional ByRef Action As Variant) ``` Starts, ends, or cancels a drag operation. ### SetFocus ```vb Public Sub SetFocus() ``` Moves the focus to the control. ### ZOrder ```vb Public Sub ZOrder(Optional ByRef Position As Variant) ``` Sets the Z-order. ## Events ### Click ```vb Public Event Click() ``` Occurs when the user clicks the control. ### DblClick ```vb Public Event DblClick() ``` Occurs when the user double-clicks the control. ### Change ```vb Public Event Change() ``` Occurs when the text content changes. ### MaxText ```vb Public Event MaxText() ``` Occurs when the entered text exceeds the MaxLength limit. ### DropFiles ```vb Public Event DropFiles(ByVal Files As Variant) ``` Occurs when files are dragged and dropped onto the control. Files is an array of file paths. ### Scroll ```vb Public Event Scroll() ``` Occurs when the text scrolls. ### ContextMenu ```vb Public Event ContextMenu(ByVal X As Single, ByVal Y As Single, ByRef Handled As Boolean) ``` Occurs when a context menu is requested. Set Handled to True to cancel the default menu. ### PreviewKeyDown ```vb Public Event PreviewKeyDown(KeyCode As Integer, Shift As Integer) ``` Occurs before the KeyDown event, for preprocessing keyboard input. ### PreviewKeyUp ```vb Public Event PreviewKeyUp(KeyCode As Integer, Shift As Integer) ``` Occurs before the KeyUp event. ### KeyDown ```vb Public Event KeyDown(KeyCode As Integer, Shift As Integer) ``` Occurs when a keyboard key is pressed. ### KeyUp ```vb Public Event KeyUp(KeyCode As Integer, Shift As Integer) ``` Occurs when a keyboard key is released. ### KeyPress ```vb Public Event KeyPress(KeyAscii As Integer) ``` Occurs when an ANSI key is pressed and released. ### MouseDown ```vb Public Event MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` Occurs when a mouse button is pressed. ### MouseMove ```vb Public Event MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` Occurs when the mouse is moved. ### MouseUp ```vb Public Event MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` Occurs when a mouse button is released. ### MouseEnter ```vb Public Event MouseEnter() ``` Occurs when the mouse enters the control area. ### MouseLeave ```vb Public Event MouseLeave() ``` Occurs when the mouse leaves the control area. ### OLECompleteDrag ```vb Public Event OLECompleteDrag(Effect As Long) ``` Occurs when an OLE drag-and-drop operation is completed. ### OLEDragDrop ```vb Public Event OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single) ``` Occurs when data is dropped during an OLE drag-and-drop operation. ### OLEDragOver ```vb Public Event OLEDragOver(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single, State As Integer) ``` Occurs when data is dragged over the control during an OLE drag-and-drop operation. ### OLEGiveFeedback ```vb Public Event OLEGiveFeedback(Effect As Long, DefaultCursors As Boolean) ``` Occurs during an OLE drag-and-drop operation to provide feedback. ### OLESetData ```vb Public Event OLESetData(Data As DataObject, DataFormat As Integer) ``` Occurs when data is set during an OLE drag-and-drop operation. ### OLEStartDrag ```vb Public Event OLEStartDrag(Data As DataObject, AllowedEffects As Long) ``` Occurs when an OLE drag-and-drop operation starts. ## Code Examples ### Basic Usage ```vb ' Set up a multi-line text box With TextBoxW1 .MultiLine = True .ScrollBars = 3 .MaxLength = 5000 .WantReturn = True .CueBanner = "Please enter content..." End With ' Use as a password box With TextBoxW1 .PasswordChar = "*" .UseSystemPasswordChar = True .MaxLength = 20 End With ' Network address validation TextBoxW1.NetAddressValidator = True TextBoxW1.NetAddressType = TxtNetAddressTypeURL Private Sub Command1_Click() If TextBoxW1.ValidateNetAddress() = 0 Then MsgBox "Address is valid: " & TextBoxW1.NetAddressString Else TextBoxW1.ShowNetAddressErrorTip End If End Sub ' Balloon tip TextBoxW1.ShowBalloonTip "Input Error", "Please enter a valid email address", TxtIconError ' Drag-and-drop files Private Sub TextBoxW1_DropFiles(ByVal Files As Variant) Dim i As Long For i = LBound(Files) To UBound(Files) Debug.Print "File: " & Files(i) Next i End Sub ``` --- --- url: /zh/vbman/tls/overview.md --- # TLS 证书配置总览 ## 概述 vbmanlib 的所有网络组件（cHttpServer、cWinsock、cWebSocketServer/Client）共享统一的 TLS 证书配置接口，通过**链式函数**风格调用，支持三种证书来源： | 证书模式 | 链式函数 | 适用场景 | 详见 | |----------|---------|---------|------| | **证书文件** | `TlsCertFile()` | 最常用，生产部署，PFX/PEM 文件 | [证书文件模式](./certfile.md) | | **Windows 证书存储** | `TlsCertSubject()` | 企业环境，IIS 共享证书，AD 证书 | [Windows 证书存储模式](./certsubject.md) | | **内存证书集合** | `TlsCertMemory()` | 动态生成，ACME 签发，嵌入式证书 | [内存证书集合模式](./certmemory.md) | ## 快速选择 ``` 我该用哪种证书模式？ │ ├─ 有 .pfx / .p12 / .pem 文件？ │ └─ ✅ TlsCertFile（最简单，推荐） │ ├─ 证书已安装在 Windows 系统（IIS 共用）？ │ └─ ✅ TlsCertSubject │ ├─ 需要程序运行时动态生成/加载证书？ │ └─ ✅ TlsCertMemory │ └─ 只需连接 TLS 服务器（客户端角色）？ └─ ✅ cWinsock.Tls()（无需本地证书） ``` ## 通用链式函数签名 各组件的 TLS 链式函数名称和参数完全一致，仅返回类型不同： ### PEM 证书（Let's Encrypt） ```vb ' ─── cHttpServer ─── Server.TlsCertFile("C:\certs\fullchain.pem|C:\certs\privkey.pem").WebRoot("C:\www").Start 443 ' ─── cWinsock（服务端） ─── svr.TlsCertFile("C:\certs\fullchain.pem|C:\certs\privkey.pem").Listen 443 ' ─── cWebSocketServer ─── wsSvr.TlsCertFile("C:\certs\fullchain.pem|C:\certs\privkey.pem").Listen 443 ``` ### PFX 带密码 ```vb ' ─── cHttpServer ─── Server.TlsCertFile("C:\certs\server.pfx", "my-password").WebRoot("C:\www").Start 443 ' ─── cWinsock（服务端） ─── svr.TlsCertFile("C:\certs\server.pfx", "my-password").Listen 443 ' ─── cWebSocketServer ─── wsSvr.TlsCertFile("C:\certs\server.pfx", "my-password").Listen 443 ``` ### Windows 证书存储 ```vb ' ─── cHttpServer ─── Server.TlsCertSubject("www.example.com").Start 443 ' ─── cWinsock（服务端） ─── svr.TlsCertSubject("www.example.com").Listen 443 ' ─── cWebSocketServer ─── wsSvr.TlsCertSubject("www.example.com").Listen 443 ``` ### 客户端模式（无需本地证书） ```vb ' ─── cWinsock（客户端） ─── cli.Tls.Connect "example.com", 443 ' ─── cWebSocketClient（wss:// 自动启用 TLS） ─── wsCli.Connect "wss://example.com/ws" ``` ### HTTP + HTTPS 双端口 ```vb Dim httpSvr As New cHttpServer httpSvr.WebRoot("C:\www").Start 80 Dim httpsSvr As New cHttpServer httpsSvr.TlsCertFile("C:\certs\server.pfx", "pwd").WebRoot("C:\www").Start 443 ``` ### 纯 HTTP（不调用任何 Tls 函数） ```vb Server.WebRoot("C:\www").Start 80 ``` ## ALPN 协议说明 | 组件 | 默认 AlpnProtocols | 说明 | |------|-------------------|------| | cHttpServer | `"http/1.1"` | 如需 HTTP/2 设为 `"h2,http/1.1"` | | cWinsock | `"http/1.1"` | 可根据应用协议自定义 | | cWebSocketServer | `""`（空） | WebSocket 有自己的升级机制，通常不需要 ALPN | ## 底层实现 所有组件最终通过 `cTlsSocket`（基于 OpenSSL）实现 TLS： ``` cHttpServer ───→ cTlsReMaster ───→ cTlsSocket ───→ OpenSSL cWinsock ─────────────────→ cTlsSocket ───→ OpenSSL cWebSocket ───→ cWinsock ───→ cTlsSocket ───→ OpenSSL ``` `InitServerTls` 按以下优先级检测证书来源： 1. 内存集合（`Certificates` + `PrivateKey`） 2. 证书文件（`CertFile`） 3. Windows 证书存储（`CertSubject`） ## 支持的 TLS 版本 * TLS 1.2 * TLS 1.3 ## 证书格式参考 | 格式 | 扩展名 | 特点 | 密码保护 | |------|--------|------|---------| | PKCS#12 | `.pfx` `.p12` | 二进制，含证书链+私钥 | 支持 | | PEM | `.pem` `.crt` `.key` | Base64 文本，可读 | 私钥可加密 | | DER | `.der` `.cer` | 二进制，单证书 | 不适用 | ## 各组件 TLS 文档 | 组件 | 文档 | |------|------| | cHttpServer | [TLS/HTTPS 支持](../httpserver/tls.md) | | cWinsock | [TLS/SSL 支持](../winsock/tls.md) | | cWebSocket | [TLS (wss://) 支持](../websocket/tls.md) | *** **最后更新**: 2026-06-09 --- --- url: /en/vbman/tls/overview.md --- # TLS Certificate Configuration Overview ## Overview All network components in vbmanlib (cHttpServer, cWinsock, cWebSocketServer/Client) share a unified TLS certificate configuration interface through **chained function** style calls, supporting three certificate sources: | Certificate Mode | Chained Function | Use Case | Details | |------------------|------------------|----------|---------| | **Certificate File** | `TlsCertFile()` | Most common, production deployment, PFX/PEM files | [Certificate File Mode](./certfile.md) | | **Windows Certificate Store** | `TlsCertSubject()` | Enterprise environments, IIS shared certificates, AD certificates | [Windows Certificate Store Mode](./certsubject.md) | | **Memory Certificate Collection** | `TlsCertMemory()` | Dynamic generation, ACME issuance, embedded certificates | [Memory Certificate Collection Mode](./certmemory.md) | ## Quick Selection Guide ``` Which certificate mode should I use? │ ├─ Have .pfx / .p12 / .pem files? │ └─ ✅ TlsCertFile (Simplest, recommended) │ ├─ Certificate already installed in Windows (shared with IIS)? │ └─ ✅ TlsCertSubject │ ├─ Need to dynamically generate/load certificates at runtime? │ └─ ✅ TlsCertMemory │ └─ Only need to connect to TLS server (client role)? └─ ✅ cWinsock.Tls() (No local certificate needed) ``` ## Universal Chained Function Signatures TLS chained function names and parameters are identical across all components, only return types differ: ### PEM Certificates (Let's Encrypt) ```vb ' ─── cHttpServer ─── Server.TlsCertFile("C:\certs\fullchain.pem|C:\certs\privkey.pem").WebRoot("C:\www").Start 443 ' ─── cWinsock (Server) ─── svr.TlsCertFile("C:\certs\fullchain.pem|C:\certs\privkey.pem").Listen 443 ' ─── cWebSocketServer ─── wsSvr.TlsCertFile("C:\certs\fullchain.pem|C:\certs\privkey.pem").Listen 443 ``` ### PFX with Password ```vb ' ─── cHttpServer ─── Server.TlsCertFile("C:\certs\server.pfx", "my-password").WebRoot("C:\www").Start 443 ' ─── cWinsock (Server) ─── svr.TlsCertFile("C:\certs\server.pfx", "my-password").Listen 443 ' ─── cWebSocketServer ─── wsSvr.TlsCertFile("C:\certs\server.pfx", "my-password").Listen 443 ``` ### Windows Certificate Store ```vb ' ─── cHttpServer ─── Server.TlsCertSubject("www.example.com").Start 443 ' ─── cWinsock (Server) ─── svr.TlsCertSubject("www.example.com").Listen 443 ' ─── cWebSocketServer ─── wsSvr.TlsCertSubject("www.example.com").Listen 443 ``` ### Client Mode (No Local Certificate Needed) ```vb ' ─── cWinsock (Client) ─── cli.Tls.Connect "example.com", 443 ' ─── cWebSocketClient (wss:// auto-enables TLS) ─── wsCli.Connect "wss://example.com/ws" ``` ### HTTP + HTTPS Dual Port ```vb Dim httpSvr As New cHttpServer httpSvr.WebRoot("C:\www").Start 80 Dim httpsSvr As New cHttpServer httpsSvr.TlsCertFile("C:\certs\server.pfx", "pwd").WebRoot("C:\www").Start 443 ``` ### Pure HTTP (Without Any Tls Function) ```vb Server.WebRoot("C:\www").Start 80 ``` ## ALPN Protocols | Component | Default AlpnProtocols | Description | |-----------|----------------------|-------------| | cHttpServer | `"http/1.1"` | Set to `"h2,http/1.1"` for HTTP/2 | | cWinsock | `"http/1.1"` | Can be customized based on application protocol | | cWebSocketServer | `""` (Empty) | WebSocket has its own upgrade mechanism, usually no ALPN needed | ## Underlying Implementation All components ultimately implement TLS through `cTlsSocket` (based on OpenSSL): ``` cHttpServer ───→ cTlsReMaster ───→ cTlsSocket ───→ OpenSSL cWinsock ─────────────────→ cTlsSocket ───→ OpenSSL cWebSocket ───→ cWinsock ───→ cTlsSocket ───→ OpenSSL ``` `InitServerTls` detects certificate sources in the following priority: 1. Memory collection (`Certificates` + `PrivateKey`) 2. Certificate file (`CertFile`) 3. Windows Certificate Store (`CertSubject`) ## Supported TLS Versions * TLS 1.2 * TLS 1.3 ## Certificate Format Reference | Format | Extension | Characteristics | Password Protection | |--------|-----------|-----------------|---------------------| | PKCS#12 | `.pfx` `.p12` | Binary, contains certificate chain + private key | Supported | | PEM | `.pem` `.crt` `.key` | Base64 text, human-readable | Private key can be encrypted | | DER | `.der` `.cer` | Binary, single certificate | Not applicable | ## Component TLS Documentation | Component | Documentation | |-----------|---------------| | cHttpServer | [TLS/HTTPS Support](../httpserver/tls.md) | | cWinsock | [TLS/SSL Support](../winsock/tls.md) | | cWebSocket | [TLS (wss://) Support](../websocket/tls.md) | *** **Last Updated**: 2026-06-09 --- --- url: /en/packages/vbccr/bars/toolbar.md description: >- ToolBar Control - VBCCR Developer Reference, complete API documentation based on source code --- # ToolBar Control Provides a customizable toolbar, supporting flat/standard styles, dropdown buttons, button menus, user customization, and OLE drag-and-drop. ## Enumerations ### TbrStyleConstants Toolbar style constants. | Constant | Value | Description | |----------|-------|-------------| | TbrStyleStandard | 0 | Standard toolbar style | | TbrStyleFlat | 1 | Flat toolbar style | ### TbrTextAlignConstants Button text alignment constants. | Constant | Value | Description | |----------|-------|-------------| | TbrTextAlignBottom | 0 | Text displayed at the bottom of the button | | TbrTextAlignRight | 1 | Text displayed to the right of the button | ### TbrOrientationConstants Toolbar orientation constants. | Constant | Value | Description | |----------|-------|-------------| | TbrOrientationHorizontal | 0 | Horizontal orientation | | TbrOrientationVertical | 1 | Vertical orientation | ### TbrButtonStyleConstants Button style constants. | Constant | Value | Description | |----------|-------|-------------| | TbrButtonDefault | 0 | Default button style | | TbrButtonCheck | 1 | Check button style | | TbrButtonCheckGroup | 2 | Check group button style (mutually exclusive within group) | | TbrButtonSeparator | 3 | Separator | | TbrButtonDropDown | 4 | Dropdown button style | | TbrButtonWholeDropDown | 5 | Whole dropdown button style | ### TbrButtonValueConstants Button state value constants. | Constant | Value | Description | |----------|-------|-------------| | TbrButtonUnpressed | 0 | Unpressed state | | TbrButtonPressed | 1 | Pressed state | ## Properties ### Name ```vb Public Property Get Name() As String ``` Returns the name used to identify the object in code. ### Tag ```vb Public Property Get Tag() As String Public Property Let Tag(ByVal Value As String) ``` Stores extra data needed by the program. ### Parent ```vb Public Property Get Parent() As Object ``` Returns the object that contains this object. ### Container ```vb Public Property Get Container() As Object Public Property Set Container(ByVal Value As Object) ``` Returns/sets the object's container. ### Left ```vb Public Property Get Left() As Single Public Property Let Left(ByVal Value As Single) ``` Returns/sets the distance between the object and the left edge of its container. ### Top ```vb Public Property Get Top() As Single Public Property Let Top(ByVal Value As Single) ``` Returns/sets the distance between the object and the top edge of its container. ### Width ```vb Public Property Get Width() As Single Public Property Let Width(ByVal Value As Single) ``` Returns/sets the width of the object. ### Height ```vb Public Property Get Height() As Single Public Property Let Height(ByVal Value As Single) ``` Returns/sets the height of the object. ### Visible ```vb Public Property Get Visible() As Boolean Public Property Let Visible(ByVal Value As Boolean) ``` Returns/sets whether the object is visible. ### ToolTipText ```vb Public Property Get ToolTipText() As String Public Property Let ToolTipText(ByVal Value As String) ``` Returns/sets the tooltip text displayed when the mouse hovers over the control. ### WhatsThisHelpID ```vb Public Property Get WhatsThisHelpID() As Long Public Property Let WhatsThisHelpID(ByVal Value As Long) ``` Returns/sets the associated context-sensitive help ID. ### Align ```vb Public Property Get Align() As Integer Public Property Let Align(ByVal Value As Integer) ``` Returns/sets the alignment of the control on its form. ### DragIcon ```vb Public Property Get DragIcon() As IPictureDisp Public Property Let DragIcon(ByVal Value As IPictureDisp) Public Property Set DragIcon(ByVal Value As IPictureDisp) ``` Returns/sets the icon displayed during a drag-and-drop operation. ### DragMode ```vb Public Property Get DragMode() As Integer Public Property Let DragMode(ByVal Value As Integer) ``` Returns/sets the drag mode (manual or automatic). ### hWnd ```vb Public Property Get hWnd() As LongPtr ``` Returns the control handle. ### hWndUserControl ```vb Public Property Get hWndUserControl() As LongPtr ``` Returns the UserControl handle. ### Font ```vb Public Property Get Font() As StdFont Public Property Let Font(ByVal NewFont As StdFont) Public Property Set Font(ByVal NewFont As StdFont) ``` Returns/sets the font. ### VisualStyles ```vb Public Property Get VisualStyles() As Boolean Public Property Let VisualStyles(ByVal Value As Boolean) ``` Returns/sets whether visual styles are enabled. Requires comctl32.dll 6.0 or later. ### Enabled ```vb Public Property Get Enabled() As Boolean Public Property Let Enabled(ByVal Value As Boolean) ``` Returns/sets whether the object can respond to user-generated events. ### OLEDropMode ```vb Public Property Get OLEDropMode() As OLEDropModeConstants Public Property Let OLEDropMode(ByVal Value As OLEDropModeConstants) ``` Returns/sets whether the object can act as an OLE drop target. ### MousePointer ```vb Public Property Get MousePointer() As CCMousePointerConstants Public Property Let MousePointer(ByVal Value As CCMousePointerConstants) ``` Returns/sets the pointer type displayed when the mouse hovers over the control. See common enumerations. ### MouseIcon ```vb Public Property Get MouseIcon() As IPictureDisp Public Property Let MouseIcon(ByVal Value As IPictureDisp) Public Property Set MouseIcon(ByVal Value As IPictureDisp) ``` Returns/sets the custom mouse icon. ### MouseTrack ```vb Public Property Get MouseTrack() As Boolean Public Property Let MouseTrack(ByVal Value As Boolean) ``` Returns/sets whether events are raised when the mouse enters or leaves the control. ### RightToLeft ```vb Public Property Get RightToLeft() As Boolean Public Property Let RightToLeft(ByVal Value As Boolean) ``` Returns/sets the right-to-left display direction. ### RightToLeftLayout ```vb Public Property Get RightToLeftLayout() As Boolean Public Property Let RightToLeftLayout(ByVal Value As Boolean) ``` Returns/sets the right-to-left layout. ### RightToLeftMode ```vb Public Property Get RightToLeftMode() As CCRightToLeftModeConstants Public Property Let RightToLeftMode(ByVal Value As CCRightToLeftModeConstants) ``` Returns/sets the right-to-left mode. See common enumerations. ### ImageList ```vb Public Property Get ImageList() As Variant Public Property Let ImageList(ByVal Value As Variant) Public Property Set ImageList(ByVal Value As Variant) ``` Returns/sets the associated ImageList control. Can be an object reference, a string key name, or a LongPtr handle. ### DisabledImageList ```vb Public Property Get DisabledImageList() As Variant Public Property Let DisabledImageList(ByVal Value As Variant) Public Property Set DisabledImageList(ByVal Value As Variant) ``` Returns/sets the ImageList control used for the disabled button state. ### HotImageList ```vb Public Property Get HotImageList() As Variant Public Property Let HotImageList(ByVal Value As Variant) Public Property Set HotImageList(ByVal Value As Variant) ``` Returns/sets the ImageList control used for the hot button state. ### PressedImageList ```vb Public Property Get PressedImageList() As Variant Public Property Let PressedImageList(ByVal Value As Variant) Public Property Set PressedImageList(ByVal Value As Variant) ``` Returns/sets the ImageList control used for the pressed button state. ### BackColor ```vb Public Property Get BackColor() As OLE_COLOR Public Property Let BackColor(ByVal Value As OLE_COLOR) ``` Returns/sets the background color. ### Style ```vb Public Property Get Style() As TbrStyleConstants Public Property Let Style(ByVal Value As TbrStyleConstants) ``` Returns/sets the toolbar style. ### TextAlignment ```vb Public Property Get TextAlignment() As TbrTextAlignConstants Public Property Let TextAlignment(ByVal Value As TbrTextAlignConstants) ``` Returns/sets the button text alignment. ### Orientation ```vb Public Property Get Orientation() As TbrOrientationConstants Public Property Let Orientation(ByVal Value As TbrOrientationConstants) ``` Returns/sets the toolbar orientation. ### Divider ```vb Public Property Get Divider() As Boolean Public Property Let Divider(ByVal Value As Boolean) ``` Returns/sets whether a divider line is displayed. ### ShowTips ```vb Public Property Get ShowTips() As Boolean Public Property Let ShowTips(ByVal Value As Boolean) ``` Returns/sets whether tooltips are displayed. ### Wrappable ```vb Public Property Get Wrappable() As Boolean Public Property Let Wrappable(ByVal Value As Boolean) ``` Returns/sets whether buttons wrap automatically. ### AllowCustomize ```vb Public Property Get AllowCustomize() As Boolean Public Property Let AllowCustomize(ByVal Value As Boolean) ``` Returns/sets whether the user can customize the toolbar. ### AltDrag ```vb Public Property Get AltDrag() As Boolean Public Property Let AltDrag(ByVal Value As Boolean) ``` Returns/sets whether Alt+drag is allowed to customize the toolbar. ### DoubleBuffer ```vb Public Property Get DoubleBuffer() As Boolean Public Property Let DoubleBuffer(ByVal Value As Boolean) ``` Returns/sets whether double-buffered drawing is enabled. ### ButtonHeight ```vb Public Property Get ButtonHeight() As Single Public Property Let ButtonHeight(ByVal Value As Single) ``` Returns/sets the button height. ### ButtonWidth ```vb Public Property Get ButtonWidth() As Single Public Property Let ButtonWidth(ByVal Value As Single) ``` Returns/sets the button width. ### MinButtonWidth ```vb Public Property Get MinButtonWidth() As Single Public Property Let MinButtonWidth(ByVal Value As Single) ``` Returns/sets the minimum button width. ### MaxButtonWidth ```vb Public Property Get MaxButtonWidth() As Single Public Property Let MaxButtonWidth(ByVal Value As Single) ``` Returns/sets the maximum button width. ### InsertMarkColor ```vb Public Property Get InsertMarkColor() As OLE_COLOR Public Property Let InsertMarkColor(ByVal Value As OLE_COLOR) ``` Returns/sets the insert mark color. ### Transparent ```vb Public Property Get Transparent() As Boolean Public Property Let Transparent(ByVal Value As Boolean) ``` Returns/sets whether the toolbar is transparent. ### HotTracking ```vb Public Property Get HotTracking() As Boolean Public Property Let HotTracking(ByVal Value As Boolean) ``` Returns/sets whether hot tracking is enabled. ### HideClippedButtons ```vb Public Property Get HideClippedButtons() As Boolean Public Property Let HideClippedButtons(ByVal Value As Boolean) ``` Returns/sets whether clipped buttons are hidden. ### AnchorHot ```vb Public Property Get AnchorHot() As Boolean Public Property Let AnchorHot(ByVal Value As Boolean) ``` Returns/sets whether hot items are anchored. ### MaxTextRows ```vb Public Property Get MaxTextRows() As Integer Public Property Let MaxTextRows(ByVal Value As Integer) ``` Returns/sets the maximum number of text rows. ### Buttons ```vb Public Property Get Buttons() As TbrButtons ``` Returns the buttons collection. ## Methods ### OLEDrag ```vb Public Sub OLEDrag() ``` Initiates an OLE drag-and-drop operation. ### Drag ```vb Public Sub Drag(Optional ByRef Action As Variant) ``` Starts, ends, or cancels a drag operation. ### ZOrder ```vb Public Sub ZOrder(Optional ByRef Position As Variant) ``` Sets the Z-order. ### Refresh ```vb Public Sub Refresh() ``` Forces a complete redraw of the object. ## Events ### Click ```vb Public Event Click() ``` Raised when the user clicks the control. ### DblClick ```vb Public Event DblClick() ``` Raised when the user double-clicks the control. ### Resize ```vb Public Event Resize() ``` Raised when the control is resized. ### BeginCustomization ```vb Public Event BeginCustomization() ``` Raised when toolbar customization begins. ### InitCustomizationDialog ```vb Public Event InitCustomizationDialog(ByVal hDlg As LongPtr, ByRef HideHelpButton As Boolean) ``` Raised when initializing the customization dialog. hDlg is the dialog handle; HideHelpButton controls whether the Help button is hidden. ### CustomizationChange ```vb Public Event CustomizationChange() ``` Raised when a toolbar customization change occurs. ### ResetCustomizations ```vb Public Event ResetCustomizations(ByRef CloseDialog As Boolean) ``` Raised when customizations are reset. CloseDialog controls whether the dialog is closed. ### CustomizationHelp ```vb Public Event CustomizationHelp() ``` Raised when the user clicks Help in the customization dialog. ### EndCustomization ```vb Public Event EndCustomization() ``` Raised when toolbar customization ends. ### ButtonClick ```vb Public Event ButtonClick(ByVal Button As TbrButton) ``` Raised when the user clicks a button. ### ButtonDrag ```vb Public Event ButtonDrag(ByVal Button As TbrButton, ByVal MouseButton As Integer) ``` Raised when the user drags a button. ### ButtonHotChanged ```vb Public Event ButtonHotChanged(ByVal Button As TbrButton, ByVal Hot As Boolean) ``` Raised when a button's hot state changes. ### ButtonDropDown ```vb Public Event ButtonDropDown(ByVal Button As TbrButton) ``` Raised when a dropdown button is clicked. ### ButtonMenuClick ```vb Public Event ButtonMenuClick(ByVal ButtonMenu As TbrButtonMenu) ``` Raised when a dropdown menu item is clicked. ### ButtonMenuClick2 ```vb Public Event ButtonMenuClick2(ByVal Button As TbrButton, ByVal ID As Long) ``` Raised when a dropdown menu item is clicked, providing both the parent button and the menu item ID. ### ButtonMouseEnter ```vb Public Event ButtonMouseEnter(ByVal Button As TbrButton) ``` Raised when the mouse enters a button area. ### ButtonMouseLeave ```vb Public Event ButtonMouseLeave(ByVal Button As TbrButton) ``` Raised when the mouse leaves a button area. ### MouseDown ```vb Public Event MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` Raised when a mouse button is pressed. ### MouseMove ```vb Public Event MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` Raised when the mouse is moved. ### MouseUp ```vb Public Event MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` Raised when a mouse button is released. ### MouseEnter ```vb Public Event MouseEnter() ``` Raised when the mouse enters the control area. ### MouseLeave ```vb Public Event MouseLeave() ``` Raised when the mouse leaves the control area. ### OLECompleteDrag ```vb Public Event OLECompleteDrag(Effect As Long) ``` Raised when an OLE drag-and-drop operation is completed. ### OLEDragDrop ```vb Public Event OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single) ``` Raised when an OLE drag-and-drop operation is dropped. ### OLEDragOver ```vb Public Event OLEDragOver(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single, State As Integer) ``` Raised during an OLE drag-and-drop hover. ### OLEGiveFeedback ```vb Public Event OLEGiveFeedback(Effect As Long, DefaultCursors As Boolean) ``` Raised when OLE drag-and-drop gives feedback. ### OLESetData ```vb Public Event OLESetData(Data As DataObject, DataFormat As Integer) ``` Raised when OLE drag-and-drop sets data. ### OLEStartDrag ```vb Public Event OLEStartDrag(Data As DataObject, AllowedEffects As Long) ``` Raised when an OLE drag-and-drop operation starts. ## Sub-Objects ### TbrButton Class Toolbar button object. #### TbrButton Properties #### Index ```vb Public Property Get Index() As Long ``` The index of the button in the collection. #### Key ```vb Public Property Get Key() As String Public Property Let Key(ByVal Value As String) ``` The button's unique identifier key. #### Tag ```vb Public Property Get Tag() As Variant Public Property Let Tag(ByVal Value As Variant) ``` Extra data. #### ID ```vb Public Property Get ID() As Long ``` Button ID. #### Caption ```vb Public Property Get Caption() As String Public Property Let Caption(ByVal Value As String) ``` Button caption. #### Style ```vb Public Property Get Style() As TbrButtonStyleConstants Public Property Let Style(ByVal Value As TbrButtonStyleConstants) ``` Button style. #### Image ```vb Public Property Get Image() As Variant Public Property Let Image(ByVal Value As Variant) ``` Button image. #### ImageIndex ```vb Public Property Get ImageIndex() As Long ``` Image index. #### ToolTipText ```vb Public Property Get ToolTipText() As String Public Property Let ToolTipText(ByVal Value As String) ``` ToolTip text. #### Description ```vb Public Property Get Description() As String Public Property Let Description(ByVal Value As String) ``` Button description. #### Value ```vb Public Property Get Value() As TbrButtonValueConstants Public Property Let Value(ByVal Value As TbrButtonValueConstants) ``` Button value (pressed/unpressed state). #### Enabled ```vb Public Property Get Enabled() As Boolean Public Property Let Enabled(ByVal Value As Boolean) ``` Whether enabled. #### Visible ```vb Public Property Get Visible() As Boolean Public Property Let Visible(ByVal Value As Boolean) ``` Whether visible. #### MixedState ```vb Public Property Get MixedState() As Boolean Public Property Let MixedState(ByVal Value As Boolean) ``` Whether in mixed state (tri-state checkbox). #### HighLighted ```vb Public Property Get HighLighted() As Boolean Public Property Let HighLighted(ByVal Value As Boolean) ``` Whether highlighted. #### NoImage ```vb Public Property Get NoImage() As Boolean Public Property Let NoImage(ByVal Value As Boolean) ``` Whether no image is displayed. #### NoPrefix ```vb Public Property Get NoPrefix() As Boolean Public Property Let NoPrefix(ByVal Value As Boolean) ``` Whether mnemonic prefix (&) is not processed. #### AutoSize ```vb Public Property Get AutoSize() As Boolean Public Property Let AutoSize(ByVal Value As Boolean) ``` Whether auto-sized. #### CustomWidth ```vb Public Property Get CustomWidth() As Single Public Property Let CustomWidth(ByVal Value As Single) ``` Custom width. #### ForeColor ```vb Public Property Get ForeColor() As OLE_COLOR Public Property Let ForeColor(ByVal Value As OLE_COLOR) ``` Foreground color. #### Position ```vb Public Property Get Position() As Long Public Property Let Position(ByVal Value As Long) ``` Button position. #### Hot ```vb Public Property Get Hot() As Boolean ``` Whether in hot state. #### Left ```vb Public Property Get Left() As Single ``` Button left edge distance. #### Top ```vb Public Property Get Top() As Single ``` Button top edge distance. #### Width ```vb Public Property Get Width() As Single ``` Button width. #### Height ```vb Public Property Get Height() As Single ``` Button height. #### ButtonMenus ```vb Public Property Get ButtonMenus() As TbrButtonMenus ``` Dropdown menu collection. #### hMenu ```vb Public Property Get hMenu() As LongPtr ``` Menu handle. ### TbrButtonMenu Class Button dropdown menu item object. #### TbrButtonMenu Properties #### Index ```vb Public Property Get Index() As Long ``` Menu item index. #### Key ```vb Public Property Get Key() As String Public Property Let Key(ByVal Value As String) ``` Unique identifier key. #### Tag ```vb Public Property Get Tag() As Variant Public Property Let Tag(ByVal Value As Variant) ``` Extra data. #### Text ```vb Public Property Get Text() As String Public Property Let Text(ByVal Value As String) ``` Menu item text. #### Enabled ```vb Public Property Get Enabled() As Boolean Public Property Let Enabled(ByVal Value As Boolean) ``` Whether enabled. #### Visible ```vb Public Property Get Visible() As Boolean Public Property Let Visible(ByVal Value As Boolean) ``` Whether visible. #### Checked ```vb Public Property Get Checked() As Boolean Public Property Let Checked(ByVal Value As Boolean) ``` Whether checked. #### Separator ```vb Public Property Get Separator() As Boolean Public Property Let Separator(ByVal Value As Boolean) ``` Whether it is a separator. #### Picture ```vb Public Property Get Picture() As IPictureDisp Public Property Set Picture(ByVal Value As IPictureDisp) ``` Menu item icon. #### Parent ```vb Public Property Get Parent() As TbrButton ``` Parent button. ### TbrButtonMenus Class Button dropdown menu item collection. #### TbrButtonMenus Members #### NewEnum ```vb Public Function NewEnum() As IUnknown ``` Enumerator (hidden). #### Add ```vb Public Function Add(Optional ByVal Index As Variant, Optional ByVal Key As Variant, Optional ByVal Text As Variant) As TbrButtonMenu ``` Adds a menu item. #### Item ```vb Public Function Item(ByVal Index As Variant) As TbrButtonMenu ``` Gets a menu item (default member). #### Exists ```vb Public Function Exists(ByVal Index As Variant) As Boolean ``` Checks if a menu item exists. #### Count ```vb Public Property Get Count() As Long ``` Menu item count. #### Clear ```vb Public Sub Clear() ``` Clears all menu items. #### Remove ```vb Public Sub Remove(ByVal Index As Variant) ``` Removes a menu item. ### TbrButtons Class Toolbar buttons collection. #### TbrButtons Members #### NewEnum ```vb Public Function NewEnum() As IUnknown ``` Enumerator (hidden). #### Add ```vb Public Function Add(Optional ByVal Index As Variant, Optional ByVal Key As Variant, Optional ByVal Caption As Variant, Optional ByVal Style As Variant, Optional ByVal Image As Variant) As TbrButton ``` Adds a button. #### Item ```vb Public Function Item(ByVal Index As Variant) As TbrButton ``` Gets a button (default member). #### Exists ```vb Public Function Exists(ByVal Index As Variant) As Boolean ``` Checks if a button exists. #### Count ```vb Public Property Get Count() As Long ``` Button count. #### Clear ```vb Public Sub Clear() ``` Clears all buttons. #### Remove ```vb Public Sub Remove(ByVal Index As Variant) ``` Removes a button. ### TbrButtonProperties Class Internal button properties object (Friend access). #### FInit ```vb Friend Property Get FInit() As Boolean Friend Property Let FInit(ByVal Value As Boolean) ``` Internal initialization flag. #### ForeColor ```vb Public Property Get ForeColor() As OLE_COLOR Public Property Let ForeColor(ByVal Value As OLE_COLOR) ``` Foreground color. ## Code Examples ### Basic Usage ```vb ' Create toolbar and add buttons With ToolBar1.Buttons .Add , "New", "New", tbrButtonDefault, 1 .Add , "Open", "Open", tbrButtonDefault, 2 .Add , , , tbrButtonSeparator .Add , "Bold", "Bold", tbrButtonCheck, 3 End With ' Add dropdown menu to a button Dim btn As TbrButton Set btn = ToolBar1.Buttons.Add(, "Font", "Font", tbrButtonDropDown, 4) With btn.ButtonMenus .Add , "Arial", "Arial" .Add , "Courier", "Courier New" .Add , , , , , True ' Separator .Add , "Tahoma", "Tahoma" End With ' Handle button click Private Sub ToolBar1_ButtonClick(ByVal Button As TbrButton) Select Case Button.Key Case "New": MsgBox "New file" Case "Open": MsgBox "Open file" Case "Bold": MsgBox "Bold: " & Button.Value End Select End Sub ' Handle dropdown menu click Private Sub ToolBar1_ButtonMenuClick(ByVal ButtonMenu As TbrButtonMenu) MsgBox "Selected font: " & ButtonMenu.Text End Sub ``` --- --- url: /zh/vbman/tools/window.md --- # Tools - 窗口工具类 ## cToolsWindow - 窗口操作工具 ### 概述 提供窗口置顶、窗口切换、强制获取焦点等功能。 ### 方法 #### TopMost 设置窗口置顶/取消置顶。 ```vb Public Sub TopMost(ByVal hWnd As Long, Optional Cancel As Boolean) ``` **参数：** | 参数名 | 类型 | 说明 | |--------|------|------| | `hWnd` | Long | 窗口句柄 | | `Cancel` | Boolean | 是否取消置顶（默认 False） | **示例：** ```vb ' 设置置顶 VBMAN.ToolsWindow.TopMost Me.hWnd ' 取消置顶 VBMAN.ToolsWindow.TopMost Me.hWnd, True ``` #### SwitchToThis 切换到指定窗口（模拟 Alt+Tab 效果）。 ```vb Public Sub SwitchToThis(ByVal hWnd As Long, Optional IsAltTab As Boolean = True) ``` **示例：** ```vb ' 切换到当前窗口 VBMAN.ToolsWindow.SwitchToThis Me.hWnd ``` #### ActiveForm 强制将窗口设置为前景窗口（绕过系统限制）。 ```vb Public Sub ActiveForm(ByVal hWnd As Long) ``` **说明：** 此方法通过模拟 Alt 键按下来绕过 Windows 对 SetForegroundWindow 的限制。建议在 `Form_LostFocus` 事件中调用，可以实现窗口永不失焦的效果。 **示例：** ```vb Private Sub Form_LostFocus() ' 强制获取焦点 VBMAN.ToolsWindow.ActiveForm Me.hWnd End Sub ``` ### 完整示例 ```vb Private Sub Form_Load() ' 窗口置顶 VBMAN.ToolsWindow.TopMost Me.hWnd ' 切换到本窗口 VBMAN.ToolsWindow.SwitchToThis Me.hWnd End Sub Private Sub cmdToggleTopmost_Click() Static IsTopmost As Boolean IsTopmost = Not IsTopmost VBMAN.ToolsWindow.TopMost Me.hWnd, Not IsTopmost cmdToggleTopmost.Caption = IIf(IsTopmost, "取消置顶", "置顶窗口") End Sub ``` ### 应用场景 | 场景 | 使用方法 | |------|----------| | **悬浮窗** | TopMost 保持窗口在最前 | | **弹窗提醒** | SwitchToThis 切换到提醒窗口 | | **模态对话框** | ActiveForm 确保对话框保持焦点 | | **全屏应用** | TopMost + ActiveForm 组合使用 | --- --- url: /zh/vbman/tools/password.md --- # Tools - 密码工具类 ## cPassword - 密码哈希工具 ### 概述 提供密码的哈希生成和验证功能，支持 MD5、SHA1、SHA256 等算法，支持自定义盐值。 ### 依赖 * `cCryptoHash` (src/Crypt/Hash) ### 属性 | 属性 | 类型 | 说明 | |------|------|------| | `Algorithm` | CryptoHashAlgorithm | 哈希算法（默认 MD5） | | `Salt` | String | 盐值（默认空） | | `Encoding` | CryptoStringEncoding | 字符串编码（默认 UTF8） | | `LastError` | String | 最后一次错误信息（只读） | ### 枚举值 #### CryptoHashAlgorithm ```vb HASH_ALG_MD5 = 0 HASH_ALG_SHA1 = 1 HASH_ALG_SHA256 = 2 ``` ### 方法 #### Create 创建密码哈希。 ```vb Public Function Create( _ ByVal Password As String, _ Optional ByRef Salt As Variant _ ) As String ``` **参数：** | 参数名 | 类型 | 说明 | |--------|------|------| | `Password` | String | 明文密码 | | `Salt` | Variant | 可选，盐值（不传则使用属性中的 Salt） | **返回值：** 返回十六进制格式的哈希字符串。 **示例：** ```vb Dim Pwd As New cPassword ' 使用默认 MD5 Dim Hash1 As String Hash1 = Pwd.Create("myPassword") Debug.Print Hash1 ' 输出: 34819d7beeabb9260a5c854bc85b3e44 ' 使用 SHA256 Pwd.Algorithm = HASH_ALG_SHA256 Dim Hash2 As String Hash2 = Pwd.Create("myPassword") Debug.Print Hash2 ' 使用随机盐值 Dim Salt As String Salt = VBMAN.CryptoRandom.GetString(16) ' 生成16位随机盐 Pwd.Salt = Salt Dim Hash3 As String Hash3 = Pwd.Create("myPassword") ``` #### Verify 验证密码是否匹配。 ```vb Public Function Verify( _ ByVal Password As String, _ ByVal Hash As String, _ Optional ByRef Salt As Variant _ ) As Boolean ``` **参数：** | 参数名 | 类型 | 说明 | |--------|------|------| | `Password` | String | 明文密码 | | `Hash` | String | 存储的哈希值 | | `Salt` | Variant | 可选，盐值 | **返回值：** * `True` - 密码匹配 * `False` - 密码不匹配 **示例：** ```vb Dim Pwd As New cPassword Pwd.Salt = "mysalt" ' 创建哈希 Dim StoredHash As String StoredHash = Pwd.Create("myPassword") ' 验证密码 If Pwd.Verify("myPassword", StoredHash) Then Debug.Print "密码正确" Else Debug.Print "密码错误" End If ``` ### 完整示例 ```vb Private Sub TestPassword() Dim Pwd As New cPassword ' 配置 Pwd.Algorithm = HASH_ALG_SHA256 Pwd.Salt = "AppSpecificSalt" Pwd.Encoding = ENCODING_UTF8 ' 用户注册时存储哈希 Dim UserHash As String UserHash = Pwd.Create(txtPassword.Text) SaveToDatabase txtUserName.Text, UserHash ' 用户登录时验证 Dim StoredHash As String StoredHash = GetHashFromDatabase(txtUserName.Text) If Pwd.Verify(txtPassword.Text, StoredHash) Then MsgBox "登录成功" Else MsgBox "密码错误" End If End Sub ``` ### 安全建议 1. **使用强哈希算法** - 优先使用 SHA256 2. **添加随机盐值** - 防止彩虹表攻击 3. **盐值唯一性** - 每个用户应使用不同的盐值 4. **盐值存储** - 盐值应与哈希一起存储 --- --- url: /zh/vbman/tools/datetime.md --- # Tools - 日期时间工具类 ## cToolsDateTime - 日期时间工具 ### 概述 提供 Unix 时间戳、ISO8601 格式、日期格式化等功能。 *** ## 时间戳获取 #### GetUnixTimestamp 获取当前时间的 Unix 时间戳（13位毫秒）。 ```vb Public Function GetUnixTimestamp() As Currency ``` **返回值：** 13位 Unix 时间戳（毫秒级）。 **示例：** ```vb Dim Ts As Currency Ts = VBMAN.ToolsDateTime.GetUnixTimestamp() Debug.Print Ts ' 输出: 1715904000000 ``` #### GetIso8601Timestamp 获取 ISO8601 格式的时间戳（UTC 时间）。 ```vb Public Function GetIso8601Timestamp() As String ``` **返回值：** 格式：`YYYY-MM-DDTHH:MM:SSZ` **示例：** ```vb Dim Iso As String Iso = VBMAN.ToolsDateTime.GetIso8601Timestamp() Debug.Print Iso ' 输出: 2024-05-17T08:00:00Z ``` #### GetUtcTimestamp 获取 UTC 时间戳（北京时间转 UTC）。 ```vb Public Function GetUtcTimestamp() As String ``` **返回值：** 格式：`YYYY-MM-DDTHH:MM:SSZ` **说明：** * 基于当前系统时间减去8小时计算 * 适合需要 UTC 时间的场景 **示例：** ```vb Dim Utc As String Utc = VBMAN.ToolsDateTime.GetUtcTimestamp() Debug.Print Utc ' 输出: 2024-05-17T08:00:00Z ``` *** ## 日期判断与格式化 #### IsDatePast 判断日期是否已经过去。 ```vb Public Function IsDatePast(targetDate As Variant) As Boolean ``` **参数：** | 参数名 | 类型 | 说明 | |--------|------|------| | `targetDate` | Variant | 目标日期（字符串或日期类型） | **返回值：** * `True` - 目标日期已过去 * `False` - 目标日期未到 * `"Invalid Date Format"` - 无效的日期格式 **示例：** ```vb ' 检查过期 If VBMAN.ToolsDateTime.IsDatePast("2023-12-31") Then Debug.Print "已过期" End If ' 检查许可证 If VBMAN.ToolsDateTime.IsDatePast(LicenseExpiryDate) Then MsgBox "许可证已过期，请续费" End If ``` #### FormatDateTime 格式化日期时间为指定格式。 ```vb Public Function FormatDateTime(Optional ByVal strFormat As String = "yyyy-mm-dd hh:nn:ss", Optional ByVal varDate As Variant) As String ``` **参数：** | 参数名 | 类型 | 说明 | |--------|------|------| | `strFormat` | String | 格式字符串（默认 "yyyy-mm-dd hh:nn:ss"） | | `varDate` | Variant | 要格式化的日期，省略则使用当前时间 | **常用格式：** | 格式 | 输出示例 | |------|----------| | `yyyy-mm-dd hh:nn:ss` | 2024-05-17 14:30:00 | | `yyyy年mm月dd日` | 2024年05月17日 | | `dd/mm/yyyy` | 17/05/2024 | | `hh:nn:ss AM/PM` | 02:30:00 PM | | `yyyy-mm-dd` | 2024-05-17 | **示例：** ```vb ' 当前时间 Debug.Print VBMAN.ToolsDateTime.FormatDateTime() ' 2024-05-17 14:30:00 ' 指定时间 Debug.Print VBMAN.ToolsDateTime.FormatDateTime("yyyy年mm月dd日", "2024-5-17") ' 输出: 2024年05月17日 ' 格式化当前时间 Debug.Print VBMAN.ToolsDateTime.FormatDateTime("今天是 yyyy年m月d日") ' 输出: 今天是 2024年5月17日 ``` *** ## cTimeUse - 耗时统计工具 ### 概述 简单的代码执行耗时统计工具，基于 GetTickCount API。 ### 方法 #### Start 开始计时。 ```vb Public Sub Start() ``` **说明：** * 记录当前时间戳作为起始时间 * 在需要统计耗时的代码前调用 **示例：** ```vb ' 开始计时 VBMAN.TimeUse.Start() ' 执行一些操作 For i = 1 To 1000000 ' 一些计算 Next i ' 显示耗时 Debug.Print VBMAN.TimeUse.Show() ``` #### Show 显示耗时。 ```vb Public Function Show(Optional Txt As String = "耗时：{*} 毫秒") As Variant ``` **参数：** | 参数名 | 类型 | 说明 | |--------|------|------| | `Txt` | String | 输出格式，`*` 会被替换为耗时毫秒数 | **返回值：** 格式化后的字符串。 **示例：** ```vb ' 开始计时 VBMAN.TimeUse.Start() ' 执行一些操作 For i = 1 To 1000000 ' 一些计算 Next i ' 显示耗时 Debug.Print VBMAN.TimeUse.Show() ' 输出: 耗时：50 毫秒 ' 自定义格式 Debug.Print VBMAN.TimeUse.Show("操作完成，耗时 {*} ms") ' 输出: 操作完成，耗时 50 ms Debug.Print VBMAN.TimeUse.Show("用时: {*}ms") ' 输出: 用时: 50ms ``` ### 完整示例 ```vb Private Sub PerformanceTest() ' 测试循环性能 VBMAN.TimeUse.Start() Dim i As Long Dim Sum As Double For i = 1 To 1000000 Sum = Sum + i Next i Debug.Print "累加结果: " & Sum Debug.Print VBMAN.TimeUse.Show("100万次循环耗时 {*} 毫秒") ' 测试字符串拼接 VBMAN.TimeUse.Start() Dim str As String For i = 1 To 10000 str = str & "x" Next i Debug.Print VBMAN.TimeUse.Show("字符串拼接耗时 {*} 毫秒") ' 测试数组操作 VBMAN.TimeUse.Start() Dim Arr(1 To 10000) As String For i = 1 To 10000 Arr(i) = "Item" & i Next i Debug.Print VBMAN.TimeUse.Show("数组操作耗时 {*} 毫秒") End Sub ``` *** ## cTimer / cTimers - 定时器类 ### 概述 提供基于 Windows API 的高精度定时器功能。 * `cTimer` - 单个定时器 * `cTimers` - 定时器集合，支持多个定时器 ### cTimer 属性 | 属性 | 类型 | 说明 | |------|------|------| | `Interval` | Long | 间隔时间（毫秒） | | `Enabled` | Boolean | 是否启用 | | `Tag` | Variant | 用户自定义数据 | ### cTimer 方法 #### EnableTimer 启用定时器并设置间隔。 ```vb Sub EnableTimer(mInterval As Long) ``` #### Enable / Disable 启用/禁用定时器。 ```vb Sub Enable() Sub Disable() ``` #### Reset 重置定时器（重新启动）。 ```vb Sub Reset() ``` ### cTimer 用法 ```vb Private WithEvents Tmr As cTimer Private Sub Form_Load() Set Tmr = New cTimer Tmr.Interval = 1000 ' 1秒 Tmr.Enabled = True End Sub Private Sub Tmr_Timer() Debug.Print "每秒触发一次" End Sub Private Sub Form_Unload(Cancel As Integer) Tmr.Enabled = False Set Tmr = Nothing End Sub ``` ### cTimers 用法（多定时器） ```vb Private WithEvents Timers As cTimers Private Sub Form_Load() Set Timers = New cTimers ' 添加两个定时器 Timers.Add Timers.Add ' 设置第一个定时器 Timers(1).Interval = 1000 Timers(1).Enabled = True ' 设置第二个定时器 Timers(2).Interval = 5000 Timers(2).Enabled = True End Sub Private Sub Timers_Timer(ByVal Index As Integer) Debug.Print "定时器 " & Index & " 触发" Select Case Index Case 1 Debug.Print "每秒任务" Case 2 Debug.Print "每5秒任务" End Select End Sub ``` ### 属性 | 属性 | 说明 | |------|------| | `Interval` | 间隔时间（毫秒） | | `Enabled` | 是否启用 | | `Tag` | 用户自定义数据 | | `Index` | 在集合中的索引（cTimers 用） | *** ## 完整示例 ```vb Private Sub DateTimeDemo() ' ===== 时间戳 ===== ' 获取 Unix 时间戳 Dim UnixTs As Currency UnixTs = VBMAN.ToolsDateTime.GetUnixTimestamp() Debug.Print "Unix时间戳: " & UnixTs ' 获取 ISO8601 时间戳 Dim IsoTime As String IsoTime = VBMAN.ToolsDateTime.GetIso8601Timestamp() Debug.Print "ISO8601: " & IsoTime ' ===== 日期格式化 ===== ' 各种格式 Debug.Print VBMAN.ToolsDateTime.FormatDateTime() Debug.Print VBMAN.ToolsDateTime.FormatDateTime("yyyy年mm月dd日") Debug.Print VBMAN.ToolsDateTime.FormatDateTime("hh:nn:ss") ' ===== 日期判断 ===== ' 检查过期 Dim ExpiryDate As String ExpiryDate = "2024-12-31" If VBMAN.ToolsDateTime.IsDatePast(ExpiryDate) Then Debug.Print "已过期" Else Debug.Print "未过期" End If ' ===== 性能测试 ===== VBMAN.TimeUse.Start() ' 模拟耗时操作 Dim i As Long For i = 1 To 100000 DoEvents Next i Debug.Print VBMAN.TimeUse.Show("操作完成，耗时 {*} 毫秒") End Sub ``` *** ## 应用场景 | 场景 | 使用方法 | |------|----------| | **API 请求** | GetUnixTimestamp() / GetIso8601Timestamp() | | **日志记录** | FormatDateTime() | | **许可证检查** | IsDatePast() | | **性能测试** | TimeUse.Start() + TimeUse.Show() | | **定时任务** | cTimer / cTimers | | **倒计时** | GetUnixTimestamp() 对比 | --- --- url: /zh/vbman/tools/math.md --- # Tools - 数学工具类 ## cToolsMath - 数学计算工具 ### 概述 提供取整、随机数、四舍五入等数学运算功能。 ### 枚举 #### EnumRoundingMode ```vb Public Enum EnumRoundingMode Rounding = 0 ' 四舍五入 Upper = 1 ' 向上取整 Downer = 2 ' 向下取整 End Enum ``` ### 方法 #### Ceil 向上取整（截断取整）。 ```vb Public Function Ceil( _ ByVal Num As Variant, _ Optional ByVal Dot As Long _ ) As Currency ``` **参数：** | 参数名 | 类型 | 说明 | |--------|------|------| | `Num` | Variant | 要取整的数值 | | `Dot` | Long | 保留小数位数（默认0） | **示例：** ```vb Debug.Print VBMAN.ToolsMath.Ceil(3.14) ' 输出: 4 Debug.Print VBMAN.ToolsMath.Ceil(3.14, 1) ' 输出: 3.2 Debug.Print VBMAN.ToolsMath.Ceil(-3.14) ' 输出: -3 ``` #### GetRandRange 获取指定范围内的随机整数（包含边界）。 ```vb Public Function GetRandRange(a As Long, b As Long) As Long ``` **示例：** ```vb ' 随机 1-100 之间的整数 Dim Rand As Long Rand = VBMAN.ToolsMath.GetRandRange(1, 100) Debug.Print Rand ' 随机布尔值 Dim IsTrue As Boolean IsTrue = (VBMAN.ToolsMath.GetRandRange(0, 1) = 1) ``` #### RoundCurrency 四舍五入（支持多种取整模式）。 ```vb Public Function RoundCurrency( _ ByVal Value As Variant, _ Optional ByVal DecimalPlaces As Integer = 0, _ Optional ByVal RoundingMode As EnumRoundingMode = 0 _ ) As Currency ``` **参数：** | 参数名 | 类型 | 说明 | |--------|------|------| | `Value` | Variant | 要取整的数值 | | `DecimalPlaces` | Integer | 保留小数位数（默认0，范围-4~4） | | `RoundingMode` | EnumRoundingMode | 取整模式 | **示例：** ```vb ' 四舍五入 Debug.Print VBMAN.ToolsMath.RoundCurrency(3.14159, 2) ' 3.14 Debug.Print VBMAN.ToolsMath.RoundCurrency(3.14159, 2, Rounding) ' 3.14 ' 向上取整 Debug.Print VBMAN.ToolsMath.RoundCurrency(3.14159, 2, Upper) ' 3.15 ' 向下取整 Debug.Print VBMAN.ToolsMath.RoundCurrency(3.14159, 2, Downer) ' 3.14 ' 负小数位（十位取整） Debug.Print VBMAN.ToolsMath.RoundCurrency(1234, -2, Rounding) ' 1200 ``` ### 完整示例 ```vb Private Sub MathDemo() Dim Price As Currency Price = 123.456 ' 商品价格四舍五入到分 Debug.Print "标准价格: " & VBMAN.ToolsMath.RoundCurrency(Price, 2) ' 优惠价格向上取整（不亏本） Debug.Print "优惠价格: " & VBMAN.ToolsMath.RoundCurrency(Price * 0.95, 2, Upper) ' 生成随机验证码 Dim Code As String Code = Format(VBMAN.ToolsMath.GetRandRange(1000, 9999), "0000") Debug.Print "验证码: " & Code End Sub ``` --- --- url: /zh/vbman/tools/array.md --- # Tools - 数组工具类 ## cToolsArray - 数组操作工具 ### 概述 提供数组操作相关的实用方法，包括删除元素、数组扩展、数组切片、数组解构等。 ### 方法 #### Remove 从数组中删除指定索引的元素，后面的元素自动前移。 ```vb Public Function Remove(ByRef Arr As Variant, ByVal Index As Integer) As Boolean ``` **参数：** | 参数名 | 类型 | 说明 | | ------- | ------- | ------------------------------ | | `Arr` | Variant | 要操作的数组（ByRef 引用传递） | | `Index` | Integer | 要删除的元素索引 | **返回值：** * `True` - 删除成功 * `False` - 删除失败（数组为空或索引越界） **示例：** ```vb Dim Arr As Variant Arr = Array("a", "b", "c", "d") ' 删除索引 1 的元素（"b"） VBMAN.ToolsArray.Remove Arr, 1 ' 结果: Arr = ["a", "c", "d"] Debug.Print Join(Arr, ",") ' 输出: a,c,d ``` #### Extend 将源数组的值扩展到目标数组。 ```vb Public Property Let Extend(Vars As Variant, Value As Variant) ``` **示例：** ```vb Dim Target(0 To 2) As String Dim Source As Variant Source = Split("x/y/z", "/") ' 将 Source 的值赋给 Target VBMAN.ToolsArray.Extend(Target) = Source Debug.Print Target(0) ' 输出: x ``` #### DeArray 解构数组到变量（将数组元素分别赋值给多个变量）。 ```vb Public Sub DeArray(Arr As Variant, ParamArray OutVars()) ``` **参数：** | 参数名 | 类型 | 说明 | | --------- | ---------- | ------------ | | `Arr` | Variant | 源数组 | | `OutVars` | ParamArray | 输出变量数组 | **示例：** ```vb Dim A As String, C As String ' 将数组的第0个元素赋值给A，第2个元素赋值给C VBMAN.ToolsArray.DeArray Split("a/b/c", "/"), A, , C Debug.Print A ' 输出: a Debug.Print C ' 输出: c ``` #### IsArrayEmpty 检查数组是否为空。 ```vb Public Function IsArrayEmpty(Arr As Variant) As Boolean ``` **返回值：** * `True` - 数组为空 * `False` - 数组不为空 **示例：** ```vb Dim EmptyArr() As Variant Dim Arr As Variant Arr = Array("a", "b") Debug.Print VBMAN.ToolsArray.IsArrayEmpty(EmptyArr) ' 输出: True Debug.Print VBMAN.ToolsArray.IsArrayEmpty(Arr) ' 输出: False ``` #### GetIndexByValue 根据值查找数组中的索引。 ```vb Public Function GetIndexByValue(Arr As Variant, Value As String) As Long ``` **参数：** | 参数名 | 类型 | 说明 | | ------- | ------- | ------------ | | `Arr` | Variant | 要搜索的数组 | | `Value` | String | 要查找的值 | **返回值：** * 找到则返回索引（从0开始） * 未找到返回 -1 **示例：** ```vb Dim Arr As Variant Arr = Array("apple", "banana", "cherry") Dim Index As Long Index = VBMAN.ToolsArray.GetIndexByValue(Arr, "banana") Debug.Print Index ' 输出: 1 ``` #### IsControlArray 检查控件是否为控件数组。 ```vb Public Function IsControlArray(Ctl As Object) As Boolean ``` **示例：** ```vb ' 检查 Command1 是否为控件数组 If VBMAN.ToolsArray.IsControlArray(Command1) Then Debug.Print "Command1 是控件数组" End If ``` *** ## 数组切片函数 ### SliceByteArray 处理 Byte 数组的切片。 ```vb Function SliceByteArray(ByRef Arr() As Byte, ByVal StartPos As Long, Optional ByVal EndPos As Long = -1) As Byte() ``` **参数：** | 参数名 | 类型 | 说明 | | ---------- | ------ | --------------------------------- | | `Arr` | Byte() | 源字节数组 | | `StartPos` | Long | 起始位置（0-based） | | `EndPos` | Long | 结束位置（0-based），-1表示到末尾 | **示例：** ```vb Dim ByteArray() As Byte Dim Sliced() As Byte ByteArray = StrConv("Hello-World", vbFromUnicode) Sliced = VBMAN.ToolsArray.SliceByteArray(ByteArray, 0, 4) ' 输出切片结果 Dim i As Long For i = LBound(Sliced) To UBound(Sliced) Debug.Print Chr(Sliced(i)); ' 输出: Hello Next i ``` ### SliceString 处理 String 类型的切片。 ```vb Function SliceString(ByVal Arr As String, ByVal StartPos As Long, Optional ByVal EndPos As Long = -1) As String ``` **示例：** ```vb Dim str As String Dim sliced As String str = "Hello World" sliced = VBMAN.ToolsArray.SliceString(str, 0, 4) Debug.Print sliced ' 输出: Hello ``` ### SliceLongArray 处理 Long 类型数组的切片。 ```vb Function SliceLongArray(ByRef Arr() As Long, ByVal StartPos As Long, Optional ByVal EndPos As Long = -1) As Long() ``` **示例：** ```vb Dim LongArr() As Long Dim Sliced() As Long LongArr = Array(10, 20, 30, 40, 50, 60, 70) Sliced = VBMAN.ToolsArray.SliceLongArray(LongArr, 2, 5) ' 输出: 30, 40, 50, 60 ``` *** ## 字节数组操作函数 ### StringToByteArray 将字符串转为字节数组。 ```vb Public Function StringToByteArray(ByVal St As String) As Byte() ``` **示例：** ```vb Dim Bytes() As Byte Bytes = VBMAN.ToolsArray.StringToByteArray("Hello") ``` ### GetArrayLength 获取数组长度。 ```vb Public Function GetArrayLength(Arr() As Variant) As Long ``` **示例：** ```vb Dim Arr As Variant Arr = Array("a", "b", "c") Debug.Print VBMAN.ToolsArray.GetArrayLength(Arr) ' 输出: 3 ``` ### FindByteArray 在字节数组中查找关键词字节数组的位置。 ```vb Public Function FindByteArray(ByRef Arr() As Byte, ByRef Keyword() As Byte) As Long ``` **返回值：** * 找到返回起始位置（0-based） * 未找到返回 -1 **示例：** ```vb Dim Data() As Byte Dim Keyword() As Byte Data = StrConv("Hello World, Hello VB", vbFromUnicode) Keyword = StrConv("World", vbFromUnicode) Dim Pos As Long Pos = VBMAN.ToolsArray.FindByteArray(Data, Keyword) Debug.Print Pos ' 输出: 6 ``` ### SplitByteArray 将字节数组分割成两个数组。 ```vb Public Function SplitByteArray(ByRef Arr() As Byte, ByVal Position As Long, Optional Offset As Long) As Variant ``` **返回值：** 返回包含两个字节数组的 Variant 数组： * 索引 0：前半部分 * 索引 1：后半部分（从 Position + Offset 开始） **示例：** ```vb Dim Data() As Byte Dim Result As Variant Data = StrConv("HelloWorldVB", vbFromUnicode) Result = VBMAN.ToolsArray.SplitByteArray(Data, 5, 0) ' Result(0) = "Hello" ' Result(1) = "WorldVB" ``` ### SplitByteArrayByKeyword 根据关键词分割字节数组，支持多次分割。 ```vb Function SplitByteArrayByKeyword(ByRef ByteArray() As Byte, ByVal Keyword As Variant, Optional ByVal SplitCount As Long) As Variant ``` **参数：** | 参数名 | 类型 | 说明 | | ------------ | ------- | ------------------------------ | | `ByteArray` | Byte() | 要分割的字节数组 | | `Keyword` | Variant | 关键词（支持字符串或字节数组） | | `SplitCount` | Long | 分割次数，0表示分割所有 | **返回值：** 返回 Variant 数组，每个元素是一个字节数组。 **示例：** ```vb Dim ByteArray() As Byte Dim Keyword As String Dim Result As Variant Dim i As Long ByteArray = StrConv("Hello World, This is a test. Hello World again!", vbFromUnicode) Keyword = "World" Result = VBMAN.ToolsArray.SplitByteArrayByKeyword(ByteArray, Keyword) For i = LBound(Result) To UBound(Result) Debug.Print "Part " & (i + 1) & ": " & StrConv(Result(i), vbUnicode) Next i ``` *** ## cToolsList - 记录集转换工具 ### 概述 提供 ADODB.Recordset 与 Collection/Dictionary 之间的转换功能。 ### 方法 #### RsToCollection 将 ADODB.Recordset 转换为 cCollection（字典数组）。 ```vb Public Function RsToCollection(Obj As Variant) As cCollection ``` **参数：** | 参数名 | 类型 | 说明 | | ------ | ------- | -------------------- | | `Obj` | Variant | ADODB.Recordset 对象 | **返回值：** 返回 `cCollection`，其中每个元素是一个 `Dictionary`，代表一条记录。 **示例：** ```vb Dim Rs As New ADODB.Recordset Dim Coll As cCollection Dim Row As Dictionary ' 执行查询 Set Rs = Db.Execute("SELECT * FROM Users") ' 转换为集合 Set Coll = VBMAN.ToolsList.RsToCollection(Rs) ' 遍历结果 Dim i As Long For i = 1 To Coll.Count Set Row = Coll(i) Debug.Print Row("UserName") & " - " & Row("Email") Next i ``` **说明：** * 支持分页（保留原记录集的分页状态） * 支持过滤器（保留原记录集的 Filter） * 克隆记录集进行遍历，不影响原记录集位置 --- --- url: /zh/vbman/tools/fso.md --- # Tools - 文件系统工具类 > **详细文档：** 每个类都有独立的详细文档，包含完整的成员说明和示例代码： > > * [cToolsFso.md](./fso/cToolsFso.md) - 文件系统工具类 > * [cFileIO.md](./fso/cFileIO.md) - API 文件操作类 > * [cFileEx.md](./fso/cFileEx.md) - VB 原生文件操作类 > * [cToolsStream.md](./fso/cToolsStream.md) - ADO Stream 文件操作类 > * [ToolsFso.md](./fso/ToolsFso.md) - FSO 模块 *** ## cToolsFso - 文件系统工具 ### 概述 提供文件路径处理、自动补全、目录创建等功能。 ### 属性 #### Inst 返回 Scripting.FileSystemObject 实例。 ```vb Public Inst As New Scripting.FileSystemObject ``` **示例：** ```vb ' 使用 Inst 访问 FSO 功能 Dim Folder As Scripting.Folder Set Folder = VBMAN.ToolsFso.Inst.GetFolder("C:\\MyFolder") Dim File As Scripting.File Set File = VBMAN.ToolsFso.Inst.GetFile("C:\\file.txt") ``` *** ### 路径处理 #### IsFullPath 检查路径是否为完整路径（包含盘符）。 ```vb Public Function IsFullPath(Path As String) As Boolean ``` **返回值：** * `True` - 是相对路径（不包含 `:\`） * `False` - 是绝对路径 **示例：** ```vb Debug.Print VBMAN.ToolsFso.IsFullPath("C:\\test.txt") ' False（是相对路径的判断，实际为完整路径） Debug.Print VBMAN.ToolsFso.IsFullPath("test.txt") ' True（是相对路径的判断，实际为相对路径） ``` #### AutoCompleteFullPath 自动补全为完整路径（相对路径转为绝对路径）。 ```vb Public Function AutoCompleteFullPath(Path As String, Optional IsFile As Boolean) As String ``` **参数：** | 参数名 | 类型 | 说明 | |--------|------|------| | `Path` | String | 源路径 | | `IsFile` | Boolean | 是否是文件路径 | **示例：** ```vb Dim FullPath As String FullPath = VBMAN.ToolsFso.AutoCompleteFullPath("data\\config.ini") ' 结果: C:\\MyApp\\data\\config.ini ``` #### ClearSpan 清理路径中的多余斜杠，统一为反斜杠。 ```vb Public Function ClearSpan(Path As String, Optional IsFile As Boolean) As String ``` **示例：** ```vb Debug.Print VBMAN.ToolsFso.ClearSpan("C:\\\\temp\\\\file.txt") ' 输出: C:\\temp\\file.txt Debug.Print VBMAN.ToolsFso.ClearSpan("C://temp//folder//", False) ' 输出: C:\\temp\\folder\\ ``` *** ### 目录操作 #### AutoMakeDir 自动创建目录（如果不存在）。 ```vb Public Function AutoMakeDir(ByVal Path As String, Optional IsFile As Boolean) As String ``` **参数：** | 参数名 | 类型 | 说明 | |--------|------|------| | `Path` | String | 路径 | | `IsFile` | Boolean | 是否是文件路径（为 True 时会提取目录部分） | **返回值：** 创建后的目录路径。 **示例：** ```vb ' 创建目录 VBMAN.ToolsFso.AutoMakeDir "C:\\MyApp\\Logs" ' 如果是文件路径，自动提取目录部分创建 VBMAN.ToolsFso.AutoMakeDir "C:\\MyApp\\Logs\\app.log", True ' 创建 C:\\MyApp\\Logs 目录 ``` *** ### 应用程序路径 #### AppPath 获取应用程序路径（自动处理 IDE 和编译后的路径差异）。 ```vb Public Function AppPath(Optional ByVal Path As String) As String ``` **说明：** * IDE 环境返回: `App.Path & "\..\dist\EXE\"` * 编译后返回: `App.Path & "\"` **示例：** ```vb ' IDE 环境: C:\\MyProject\\..\\dist\\EXE\\ ' 编译后: C:\\Program Files\\MyApp\\ Dim ConfigPath As String ConfigPath = VBMAN.ToolsFso.AppPath("config.ini") Debug.Print ConfigPath ``` *** ### 文件名处理 #### MakeNewFileFulPath 生成新的文件完整路径（添加后缀）。 ```vb Public Function MakeNewFileFulPath(FileSrc As String, AppendFix As String, Optional JoinStr As String = "_") As String ``` **参数：** | 参数名 | 类型 | 说明 | |--------|------|------| | `FileSrc` | String | 源文件路径 | | `AppendFix` | String | 要添加的后缀 | | `JoinStr` | String | 连接符（默认 "\_"） | **示例：** ```vb Dim NewPath As String NewPath = VBMAN.ToolsFso.MakeNewFileFulPath("C:\\file.txt", "backup") ' 输出: file_backup.txt NewPath = VBMAN.ToolsFso.MakeNewFileFulPath("C:\\data\\report.pdf", "2024", "-") ' 输出: report-2024.pdf ``` *** ## cFileIO - 高级文件操作（API 实现） ### 概述 使用 Windows CreateFile API 实现的高级文件操作，支持大文件（>2GB）。 ### 属性 | 属性 | 说明 | |------|------| | `IsOpen` | 文件是否已打开（Boolean，只读） | | `FilePath` | 当前文件路径（String，只读） | | `LastError` | 最后一次错误信息（String，只读） | | `FileSize` | 文件大小（Currency，单位字节，只读） | | `BufferSize` | 当前缓冲区字节数（Long，只读） | ### 文件打开/关闭 #### OpenFile 打开文件，返回 Me 支持链式调用。 ```vb Public Function OpenFile(ByVal FilePath As String, Optional ByVal AccessMode As String = "RW") As cFileIO ``` **参数：** | 参数名 | 类型 | 说明 | |--------|------|------| | `FilePath` | String | 文件路径 | | `AccessMode` | String | 访问模式："R"=只读, "W"=只写, "RW"=读写(默认) | **示例：** ```vb ' 只读方式打开 VBMAN.FileIO.OpenFile "C:\\data.txt", "R" ' 读写方式打开 VBMAN.FileIO.OpenFile "C:\\data.txt", "RW" ' 链式调用 Dim Content As String Content = VBMAN.FileIO.OpenFile("C:\\data.txt").ReadData().ReturnText() ``` #### CloseFile 关闭文件。 ```vb Public Sub CloseFile() ``` **示例：** ```vb VBMAN.FileIO.CloseFile ``` *** ### 缓冲区操作 #### ClearBuffer 清空内部缓冲区。 ```vb Public Function ClearBuffer() As cFileIO ``` #### SetBuffer 用外部字节数组填充缓冲区。 ```vb Public Function SetBuffer(Data() As Byte) As cFileIO ``` **示例：** ```vb Dim Bytes() As Byte Bytes = StrConv("Hello", vbFromUnicode) VBMAN.FileIO.SetBuffer Bytes ``` #### AppendBuffer 追加字节到缓冲区。 ```vb Public Function AppendBuffer(Data() As Byte) As cFileIO ``` **示例：** ```vb Dim Bytes1() As Byte, Bytes2() As Byte Bytes1 = StrConv("Hello", vbFromUnicode) Bytes2 = StrConv(" World", vbFromUnicode) VBMAN.FileIO.SetBuffer(Bytes1).AppendBuffer Bytes2 ``` #### SetBufferText 用字符串填充缓冲区（默认 UTF-8）。 ```vb Public Function SetBufferText(ByVal Text As String, Optional ByVal CharSet As String = "UTF-8") As cFileIO ``` **示例：** ```vb VBMAN.FileIO.SetBufferText "Hello World", "UTF-8" ``` *** ### 数据读取 #### ReadData 将文件指定范围读入内部缓冲区。 ```vb Public Function ReadData(Optional ByVal StartPos As Long = -1, Optional ByVal EndPos As Long = -1) As cFileIO ``` **参数：** | 参数名 | 类型 | 说明 | |--------|------|------| | `StartPos` | Long | 起始位置（0-based），-1表示从头开始 | | `EndPos` | Long | 结束位置（0-based），-1表示读到末尾 | **示例：** ```vb ' 读取整个文件 VBMAN.FileIO.OpenFile("C:\\data.txt").ReadData ' 读取指定范围 VBMAN.FileIO.OpenFile("C:\\data.txt").ReadData 0, 1023 ' 读取前1KB ' 链式调用读取并获取文本 Dim Text As String Text = VBMAN.FileIO.OpenFile("C:\\data.txt").ReadData().ReturnText() ``` *** ### 数据返回 #### ReturnText 返回缓冲区内容为文本。 ```vb Public Function ReturnText(Optional ByVal CharSet As String = "UTF-8") As String ``` **示例：** ```vb Dim Text As String VBMAN.FileIO.OpenFile("C:\\utf8.txt").ReadData() Text = VBMAN.FileIO.ReturnText("UTF-8") ``` #### ReturnBytes 返回字节数组（副本）。 ```vb Public Function ReturnBytes() As Byte() ``` **示例：** ```vb Dim Bytes() As Byte VBMAN.FileIO.OpenFile("C:\\data.bin").ReadData() Bytes = VBMAN.FileIO.ReturnBytes() ``` #### ReturnBase64 返回 Base64 编码字符串。 ```vb Public Function ReturnBase64() As String ``` **示例：** ```vb Dim Base64 As String VBMAN.FileIO.OpenFile("C:\\image.png").ReadData() Base64 = VBMAN.FileIO.ReturnBase64() ``` *** ### 数据写入 #### SaveData 将内部缓冲区写入文件。 ```vb Public Function SaveData(Optional ByVal FilePath As String, Optional ByVal IsAppend As Boolean = False) As cFileIO ``` **参数：** | 参数名 | 类型 | 说明 | |--------|------|------| | `FilePath` | String | 目标路径，为空则使用当前打开的文件 | | `IsAppend` | Boolean | False=覆盖(默认), True=追加 | **示例：** ```vb ' 覆盖写入 VBMAN.FileIO.SetBufferText("Hello World").SaveData "C:\\output.txt" ' 追加写入 VBMAN.FileIO.SetBufferText("New Line").SaveData "C:\\log.txt", True ' 写入当前打开的文件 VBMAN.FileIO.OpenFile("C:\\data.txt", "RW").SetBufferText("Content").SaveData ``` *** ### 完整示例 ```vb Private Sub FileIODemo() ' 读取文本文件 Dim Content As String Content = VBMAN.FileIO.OpenFile("C:\\input.txt").ReadData().ReturnText() Debug.Print Content ' 读取并转换 Dim Base64 As String Base64 = VBMAN.FileIO.OpenFile("C:\\image.png").ReadData().ReturnBase64() ' 写入文件 VBMAN.FileIO.SetBufferText("Hello World").SaveData "C:\\output.txt" ' 追加内容 VBMAN.FileIO.SetBufferText("Line 1" & vbCrLf).SaveData "C:\\log.txt", True VBMAN.FileIO.SetBufferText("Line 2" & vbCrLf).SaveData "C:\\log.txt", True ' 复制文件（分块读取大文件） With VBMAN.FileIO .OpenFile "C:\\largefile.zip" Dim FileLen As Currency FileLen = .FileSize ' 分2MB块读取 Dim Pos As Long For Pos = 0 To FileLen Step 2097152 .ReadData Pos, Pos + 2097151 .SaveData "C:\\copy.zip", True Next Pos End With End Sub ``` *** ## cFileEx - 高级文件操作（Open 语句实现） ### 概述 使用 VB 原生 Open 语句实现的文件操作，兼容性好，接口与 `cFileIO` 保持一致。 ### 与 cFileIO 的区别 | 特性 | cFileIO | cFileEx | |------|---------|---------| | 实现方式 | CreateFile API | VB Open 语句 | | 大文件支持 | >2GB | 受限于 VB | | 兼容性 | 需要 Windows API | 原生 VB，兼容性好 | | 性能 | 高 | 一般 | ### 属性 与 `cFileIO` 相同： * `IsOpen` - 文件是否已打开 * `FilePath` - 当前文件路径 * `LastError` - 最后一次错误信息 * `FileSize` - 文件大小 * `BufferSize` - 当前缓冲区字节数 ### 方法 与 `cFileIO` 基本相同，额外支持： #### SetBufferBase64 用 Base64 字符串填充缓冲区。 ```vb Public Function SetBufferBase64(ByVal Base64String As String) As cFileEx ``` **示例：** ```vb VBMAN.FileEx.SetBufferBase64 "SGVsbG8gV29ybGQ=" ``` #### SetBufferHex 用 Hex 字符串填充缓冲区。 ```vb Public Function SetBufferHex(ByVal HexString As String, Optional ByVal Separator As String = " ") As cFileEx ``` **示例：** ```vb VBMAN.FileEx.SetBufferHex "48 65 6C 6C 6F" VBMAN.FileEx.SetBufferHex "48656C6C6F", "" ' 无分隔符 ``` #### SetBufferBinString 用二进制字符串填充缓冲区。 ```vb Public Function SetBufferBinString(ByVal BinString As String, Optional ByVal Separator As String = " ") As cFileEx ``` **示例：** ```vb VBMAN.FileEx.SetBufferBinString "01001000 01100101 01101100 01101100 01101111" ``` #### ReturnHex 返回 Hex 编码字符串。 ```vb Public Function ReturnHex(Optional ByVal Separator As String = " ") As String ``` **示例：** ```vb VBMAN.FileEx.OpenFile("C:\\data.bin").ReadData() Debug.Print VBMAN.FileEx.ReturnHex(" ") ' 输出: 48 65 6C 6C 6F Debug.Print VBMAN.FileEx.ReturnHex("") ' 输出: 48656C6C6F ``` #### ReturnBinString 返回二进制字符串。 ```vb Public Function ReturnBinString(Optional ByVal Separator As String = " ") As String ``` **示例：** ```vb Debug.Print VBMAN.FileEx.ReturnBinString(" ") ' 输出: 01001000 01100101... ``` *** ## cToolsStream - 流式文件操作 ### 概述 基于 ADODB.Stream 的文件流操作，支持按行读写、多种编码。 ### 属性 | 属性 | 类型 | 说明 | |------|------|------| | `Inst` | ADODB.Stream | Stream 实例 | | `LastError` | String | 最后错误信息 | | `UseLine` | Boolean | 是否启用按行模式 | | `LineData` | cCollection | 行数据集合 | | `LineNumber` | Long | 当前行号 | ### 方法 #### UseLineMode 设置是否启用按行读写模式（链式调用）。 ```vb Public Function UseLineMode(v As Boolean) As cToolsStream ``` **示例：** ```vb VBMAN.ToolsStream.UseLineMode(True) ``` #### LoadFileAsText 加载文本文件。 ```vb Public Function LoadFileAsText(ByVal FileName As String, Optional ByVal CharSet As String = "UTF-8") As String ``` **示例：** ```vb Dim Content As String Content = VBMAN.ToolsStream.LoadFileAsText("test.txt", "UTF-8") ``` #### SaveFileAsText 保存文本文件。 ```vb Public Function SaveFileAsText(ByVal FileName As String, Optional Data As Variant, Optional ByVal CharSet As String = "UTF-8") As Boolean ``` **示例：** ```vb ' 直接保存数据 VBMAN.ToolsStream.SaveFileAsText "output.txt", "Hello World", "UTF-8" ' 使用按行模式保存 VBMAN.ToolsStream.UseLineMode(True) VBMAN.ToolsStream.WriteLine "Line 1" VBMAN.ToolsStream.WriteLine "Line 2" VBMAN.ToolsStream.SaveFileAsText "output.txt", , "UTF-8" ``` #### LoadFileAsBinary 以二进制方式加载文件。 ```vb Public Function LoadFileAsBinary(ByVal Path As String, OutData() As Byte) As Boolean ``` **示例：** ```vb Dim Data() As Byte VBMAN.ToolsStream.LoadFileAsBinary "image.png", Data ``` #### SaveFileAsBinary 以二进制方式保存文件。 ```vb Public Function SaveFileAsBinary(ByVal Path As String, OutData() As Byte) As Boolean ``` **示例：** ```vb Dim Data() As Byte ' ... 填充 Data VBMAN.ToolsStream.SaveFileAsBinary "output.bin", Data ``` #### ReadLine 读取一行（需启用按行模式）。 ```vb Public Function ReadLine(Optional ByVal Line As Long) As String ``` **参数：** | 参数名 | 类型 | 说明 | |--------|------|------| | `Line` | Long | 指定行号，0表示当前行 | **示例：** ```vb ' 按行读取文件 With VBMAN.ToolsStream.UseLineMode(True) .LoadFileAsText "log.txt", "UTF-8" Dim Line As String Line = .ReadLine(1) ' 读取第1行 Debug.Print Line Line = .ReadLine() ' 读取下一行（自动递增） Debug.Print Line End With ``` #### WriteLine 写入一行（需启用按行模式）。 ```vb Public Function WriteLine(Text As String, Optional ByVal Line As Long) As Boolean ``` **示例：** ```vb ' 按行写入文件 With VBMAN.ToolsStream.UseLineMode(True) .WriteLine "第一行内容" .WriteLine "第二行内容" .WriteLine "第三行内容", 10 ' 写入第10行 .SaveFileAsText "output.txt", , "UTF-8" End With ``` *** ## 完整示例 ```vb Private Sub FileOperationsDemo() ' ========== cToolsFso 示例 ========== ' 创建目录 VBMAN.ToolsFso.AutoMakeDir "C:\\MyApp\\Logs" ' 获取应用路径 Dim AppPath As String AppPath = VBMAN.ToolsFso.AppPath("config.ini") ' 生成备份文件名 Dim BackupName As String BackupName = VBMAN.ToolsFso.MakeNewFileFulPath("report.pdf", "backup") ' ========== cFileIO 示例 ========== ' 读取大文件 Dim LargeFileContent As String With VBMAN.FileIO .OpenFile "C:\\largefile.bin" LargeFileContent = .ReadData().ReturnBase64() End With ' 写入文件 VBMAN.FileIO.SetBufferText("Hello World").SaveData "C:\\test.txt" ' ========== cFileEx 示例 ========== ' Hex 操作 VBMAN.FileEx.SetBufferHex "48 65 6C 6C 6F" VBMAN.FileEx.SaveData "C:\\hex_test.bin" ' ========== cToolsStream 示例 ========== ' 按行处理配置文件 With VBMAN.ToolsStream.UseLineMode(True) .LoadFileAsText "config.ini", "UTF-8" Dim i As Long For i = 1 To 10 Debug.Print "Line " & i & ": " & .ReadLine(i) Next i End With End Sub ``` --- --- url: /zh/vbman/tools/system.md --- # Tools - 系统工具类 ## cToolsSystem - 系统操作工具 ### 概述 提供系统级别的操作功能，如以管理员身份运行程序。 ### 方法 #### RunAsAdmin 以管理员身份运行指定的程序。 ```vb Public Function RunAsAdmin( _ ByRef Path As Variant, _ ParamArray StartArgs() As Variant _ ) As Long ``` **参数：** | 参数名 | 类型 | 说明 | |--------|------|------| | `Path` | Variant | 程序路径（支持 App 对象或字符串） | | `StartArgs` | Variant | 可选，命令行参数数组 | **返回值：** ShellExecute 的执行结果。 **示例：** ```vb ' 方式1：传入 App 对象 VBMAN.ToolsSystem.RunAsAdmin App ' 方式2：传入路径字符串 VBMAN.ToolsSystem.RunAsAdmin "C:\\Program Files\\MyApp\\MyApp.exe" ' 带参数运行 VBMAN.ToolsSystem.RunAsAdmin App, "--config", "debug" ``` ### 完整示例 ```vb Private Sub RestartAsAdmin() Dim Result As Long ' 检查是否已以管理员身份运行（需要额外实现检查逻辑） If Not IsAdmin() Then Result = VBMAN.ToolsSystem.RunAsAdmin(App) If Result > 32 Then ' 成功启动管理员进程，退出当前进程 End Else MsgBox "无法提升到管理员权限", vbExclamation End If End If End Sub ``` ### 注意事项 1. 调用会触发 UAC（用户账户控制）提示 2. 如果用户拒绝提升权限，程序不会启动 3. 返回值大于 32 表示成功 --- --- url: /zh/vbman/tools/dic.md --- # Tools - 字典工具类 ## cToolsDic - 字典操作工具 ### 概述 提供 Dictionary 对象的扩展操作方法，包括表单编码转换、嵌套字典操作、字典合并、深拷贝等。 *** ## Form URL-Encoded 转换 #### ToWwwFormUrlencoded 将字典转换为 `application/x-www-form-urlencoded` 格式字符串。 ```vb Public Function ToWwwFormUrlencoded(Dic As Dictionary) As String ``` **参数：** | 参数名 | 类型 | 说明 | | ------ | ---------- | ------------ | | `Dic` | Dictionary | 要转换的字典 | **返回值：** URL 编码格式的字符串，如 `key1=value1&key2=value2`。 **说明：** * 简单实现版本，直接拼接键值对 * 暂不支持数组类型值 **示例：** ```vb Dim Dic As New Dictionary Dic.Add "name", "张三" Dic.Add "age", "25" Dim FormData As String FormData = VBMAN.ToolsDic.ToWwwFormUrlencoded(Dic) Debug.Print FormData ' 输出: name=张三&age=25 ``` #### FromWwwFormUrlencoded 解析 `application/x-www-form-urlencoded` 格式字符串到字典。 ```vb Public Function FromWwwFormUrlencoded(Content As String, Dic As Dictionary) As Boolean ``` **参数：** | 参数名 | 类型 | 说明 | | --------- | ---------- | ----------------------- | | `Content` | String | URL 编码格式的字符串 | | `Dic` | Dictionary | 存储结果的字典（ByRef） | **返回值：** * `True` - 解析成功 **示例：** ```vb Dim Dic As New Dictionary Dim Success As Boolean Success = VBMAN.ToolsDic.FromWwwFormUrlencoded("name=张三&age=25", Dic) Debug.Print Dic("name") ' 输出: 张三 Debug.Print Dic("age") ' 输出: 25 ``` *** ## 嵌套字典操作 #### TowLevelDicAssign 双层嵌套字典赋值辅助方法。 ```vb Public Sub TowLevelDicAssign(Dic As Dictionary, Lv1Name As String, Lv2Name As String, Value As Variant) ``` **说明：** 自动创建第一层字典（如果不存在），然后在第二层字典中赋值。 **参数：** | 参数名 | 类型 | 说明 | | --------- | ---------- | ---------- | | `Dic` | Dictionary | 目标字典 | | `Lv1Name` | String | 第一层键名 | | `Lv2Name` | String | 第二层键名 | | `Value` | Variant | 要赋的值 | **示例：** ```vb Dim Dic As New Dictionary ' 自动创建 "user" 子字典，并设置 "name" 值 VBMAN.ToolsDic.TowLevelDicAssign Dic, "user", "name", "张三" VBMAN.ToolsDic.TowLevelDicAssign Dic, "user", "age", 25 ' 结果: Dic("user")("name") = "张三" ' Dic("user")("age") = 25 Debug.Print Dic("user")("name") ' 输出: 张三 Debug.Print Dic("user")("age") ' 输出: 25 ' 也可以操作更深层的字典 VBMAN.ToolsDic.TowLevelDicAssign Dic, "settings", "theme", "dark" VBMAN.ToolsDic.TowLevelDicAssign Dic, "settings", "lang", "zh-CN" Debug.Print Dic("settings")("theme") ' 输出: dark ``` *** ## 字典合并 #### OverWrite 合并源字典到目标字典。 ```vb Public Sub OverWrite(DistDic As Dictionary, srcDic As Dictionary, Optional OnlyKey As Boolean = True) ``` **参数：** | 参数名 | 类型 | 说明 | | --------- | ---------- | ----------------------------- | | `DistDic` | Dictionary | 目标字典 | | `srcDic` | Dictionary | 源字典 | | `OnlyKey` | Boolean | 仅覆盖已存在的键（默认 True） | **说明：** * 支持递归合并嵌套字典 * 对象类型使用递归合并 * 非对象类型直接赋值 **示例：** ```vb Dim Target As New Dictionary Dim Source As New Dictionary Target.Add "a", "old_a" Target.Add "b", "old_b" Source.Add "a", "new_a" Source.Add "c", "new_c" ' OnlyKey=True：只覆盖已存在的键（a） VBMAN.ToolsDic.OverWrite Target, Source, True ' 结果: Target("a") = "new_a" ' Target("b") = "old_b" ' Target("c") = 不存在 ' OnlyKey=False：覆盖所有并添加新键 Dim Target2 As New Dictionary Target2.Add "a", "old_a" Target2.Add "b", "old_b" VBMAN.ToolsDic.OverWrite Target2, Source, False ' 结果: Target2("a") = "new_a" ' Target2("b") = "old_b" ' Target2("c") = "new_c" ' 嵌套字典合并示例 Dim NestedTarget As New Dictionary Dim NestedSource As New Dictionary Dim UserDic As New Dictionary Dim SettingsDic As New Dictionary UserDic.Add "name", "张三" UserDic.Add "age", 20 NestedTarget.Add "user", UserDic SettingsDic.Add "theme", "light" NestedSource.Add "user", SettingsDic VBMAN.ToolsDic.OverWrite NestedTarget, NestedSource, False ' NestedTarget("user") 包含 name, age, theme ``` *** ## 字典拷贝 #### DeepCopy 深拷贝字典对象。 ```vb Public Function DeepCopy(srcDic As Dictionary) As Dictionary ``` **参数：** | 参数名 | 类型 | 说明 | | -------- | ---------- | ------ | | `srcDic` | Dictionary | 源字典 | **返回值：** 新的字典对象，包含源字典的所有键值对。 **说明：** * 目前仅实现单层拷贝（第一层键值对） * 对象类型使用 Set 赋值 * 非对象类型使用 Let 赋值 * TODO: 需要改为递归实现深层对象赋值 **示例：** ```vb Dim Original As New Dictionary Original.Add "name", "张三" Original.Add "age", 25 ' 创建深拷贝 Dim Copy As Dictionary Set Copy = VBMAN.ToolsDic.DeepCopy(Original) ' 修改拷贝不影响原字典 Copy("name") = "李四" Debug.Print Original("name") ' 输出: 张三 Debug.Print Copy("name") ' 输出: 李四 ' 注意：对于嵌套字典，目前仍是浅拷贝 Dim Nested As New Dictionary Dim Inner As New Dictionary Inner.Add "key", "value" Nested.Add "inner", Inner Dim NestedCopy As Dictionary Set NestedCopy = VBMAN.ToolsDic.DeepCopy(Nested) ' 修改嵌套字典会影响原字典（因为是引用） NestedCopy("inner")("key") = "new_value" Debug.Print Nested("inner")("key") ' 输出: new_value ``` *** ## 完整示例 ```vb Private Sub DictionaryDemo() ' ===== Form URL-Encoded 操作 ===== Dim Params As New Dictionary Params.Add "username", "admin" Params.Add "password", "123456" Params.Add "remember", "true" ' 编码为 Form 格式 Dim FormData As String FormData = VBMAN.ToolsDic.ToWwwFormUrlencoded(Params) Debug.Print "Form数据: " & FormData ' 解码回字典 Dim Parsed As New Dictionary VBMAN.ToolsDic.FromWwwFormUrlencoded FormData, Parsed Debug.Print "用户名: " & Parsed("username") ' ===== 嵌套字典操作 ===== Dim Config As New Dictionary ' 使用 TowLevelDicAssign 快速创建嵌套结构 VBMAN.ToolsDic.TowLevelDicAssign Config, "database", "host", "localhost" VBMAN.ToolsDic.TowLevelDicAssign Config, "database", "port", 3306 VBMAN.ToolsDic.TowLevelDicAssign Config, "database", "name", "mydb" VBMAN.ToolsDic.TowLevelDicAssign Config, "cache", "enabled", True VBMAN.ToolsDic.TowLevelDicAssign Config, "cache", "ttl", 3600 Debug.Print "数据库主机: " & Config("database")("host") Debug.Print "缓存TTL: " & Config("cache")("ttl") ' ===== 字典合并 ===== Dim Defaults As New Dictionary Defaults.Add "theme", "light" Defaults.Add "lang", "en" Defaults.Add "notifications", True Dim UserSettings As New Dictionary UserSettings.Add "theme", "dark" ' 合并：用户设置覆盖默认值 VBMAN.ToolsDic.OverWrite Defaults, UserSettings, False Debug.Print "主题: " & Defaults("theme") ' dark（用户设置） Debug.Print "语言: " & Defaults("lang") ' en（默认值） Debug.Print "通知: " & Defaults("notifications") ' True（默认值） ' ===== 深拷贝 ===== Dim Original As New Dictionary Original.Add "key1", "value1" Original.Add "key2", 12345 Dim Cloned As Dictionary Set Cloned = VBMAN.ToolsDic.DeepCopy(Original) ' 验证是独立副本 Cloned("key1") = "modified" Debug.Print "Original: " & Original("key1") ' value1 Debug.Print "Cloned: " & Cloned("key1") ' modified End Sub ``` *** ## 方法对比表 | 方法 | 用途 | 复杂度 | | ----------------------- | ---------------- | ------ | | `ToWwwFormUrlencoded` | 字典转查询字符串 | O(n) | | `FromWwwFormUrlencoded` | 查询字符串转字典 | O(n) | | `TowLevelDicAssign` | 双层嵌套赋值 | O(1) | | `OverWrite` | 字典合并 | O(n) | | `DeepCopy` | 字典深拷贝 | O(n) | --- --- url: /zh/vbman/tools/string.md --- # Tools - 字符串工具类 ## cToolsStr - 字符串处理工具 ### 概述 提供丰富的字符串处理功能，包括正则提取、行分割、编码检测、字符串切片、随机字符串生成等。 *** ### 文本分割与合并 #### ParseNumbers 从字符串中提取数字（支持小数）。 ```vb Function ParseNumbers(inputString As String, Optional DecimalPlaces As Long = -1, Optional Count As Long) As Collection ``` **参数：** | 参数名 | 类型 | 说明 | |--------|------|------| | `inputString` | String | 输入字符串 | | `DecimalPlaces` | Long | 小数位数，-1表示不处理 | | `Count` | Long | 提取个数限制，0表示不限制 | **示例：** ```vb Dim Numbers As Collection Set Numbers = VBMAN.ToolsStr.ParseNumbers("价格: 123.5元，数量: 10个") Dim n As Variant For Each n In Numbers Debug.Print n ' 输出: 123.5, 10 Next n ``` #### SplitLinesToCollection 将文本按行分割为集合。 ```vb Public Function SplitLinesToCollection(ByVal Text As String) As cCollection ``` **示例：** ```vb Dim Lines As cCollection Set Lines = VBMAN.ToolsStr.SplitLinesToCollection("Line1" & vbCrLf & "Line2") Debug.Print Lines(1) ' 输出: Line1 ``` #### JoinLinesFromCollection 将行集合合并为字符串。 ```vb Public Function JoinLinesFromCollection(Coll As cCollection) As String ``` **示例：** ```vb Dim Lines As cCollection Set Lines = New cCollection Lines.Add "Line1" Lines.Add "Line2" Dim Text As String Text = VBMAN.ToolsStr.JoinLinesFromCollection(Lines) Debug.Print Text ' 输出: Line1\r\nLine2 ``` #### SplitLines 将文本按行分割为数组。 ```vb Public Function SplitLines(ByVal Text As String) As String() ``` **示例：** ```vb Dim Lines() As String Lines = VBMAN.ToolsStr.SplitLines("Line1" & vbCrLf & "Line2") Debug.Print Lines(0) ' 输出: Line1 ``` *** ### 字符串查询与判断 #### HasStr 检查字符串是否包含子串（返回位置，0表示不存在）。 ```vb Public Function HasStr(ByVal FindStr As String, FullStr As String, Optional StartPos As Long = 1, Optional CompType As VbCompareMethod = vbTextCompare) As Long ``` **示例：** ```vb If VBMAN.ToolsStr.HasStr("test", "this is a test") > 0 Then Debug.Print "包含 test" End If ' 指定起始位置 Dim Pos As Long Pos = VBMAN.ToolsStr.HasStr("a", "banana", 2) Debug.Print Pos ' 输出: 4 ``` #### HasStrFromRight 从右侧开始检查字符串是否包含子串。 ```vb Public Function HasStrFromRight(ByVal FindStr As String, FullStr As String, Optional StartPos As Long = -1, Optional CompType As VbCompareMethod = vbTextCompare) As Long ``` **示例：** ```vb Dim Pos As Long Pos = VBMAN.ToolsStr.HasStrFromRight("a", "banana") Debug.Print Pos ' 输出: 6（最后一个a的位置） ``` #### IsEmptyEx 检查字符串是否为空（去除空白字符后）。 ```vb Public Function IsEmptyEx(Text As String) As Boolean ``` **示例：** ```vb Debug.Print VBMAN.ToolsStr.IsEmptyEx(" ") ' 输出: True Debug.Print VBMAN.ToolsStr.IsEmptyEx("hello") ' 输出: False ``` #### IsString 检查变量是否为字符串类型。 ```vb Public Function IsString(var As Variant) As Boolean ``` **示例：** ```vb Debug.Print VBMAN.ToolsStr.IsString("hello") ' 输出: True Debug.Print VBMAN.ToolsStr.IsString(123) ' 输出: False ``` *** ### 字符串切片与截取 #### SliceString 处理 String 类型的切片。 ```vb Public Function SliceString(ByVal Arr As String, ByVal StartPos As Long, Optional ByVal EndPos As Long = -1) As String ``` **参数：** | 参数名 | 类型 | 说明 | |--------|------|------| | `Arr` | String | 源字符串 | | `StartPos` | Long | 起始位置（0-based） | | `EndPos` | Long | 结束位置（0-based），-1表示到末尾 | **示例：** ```vb Dim str As String Dim sliced As String str = "Hello World" sliced = VBMAN.ToolsStr.SliceString(str, 0, 4) Debug.Print sliced ' 输出: Hello ' 从位置6到末尾 sliced = VBMAN.ToolsStr.SliceString(str, 6) Debug.Print sliced ' 输出: World ``` #### SubStr 截取任意位置字符串（根据起始和结束标记）。 ```vb Public Function SubStr(ByVal Txt As String, ByVal txtFirst As String, Optional ByVal txtEnd As String, Optional RetInt As Boolean, Optional Method As VbCompareMethod = vbBinaryCompare, Optional FindFromEnd As Boolean) As String ``` **参数：** | 参数名 | 类型 | 说明 | |--------|------|------| | `Txt` | String | 源字符串 | | `txtFirst` | String | 起始标记 | | `txtEnd` | String | 结束标记，为空则取到末尾 | | `RetInt` | Boolean | 未找到时返回"0"而不是空字符串 | | `Method` | VbCompareMethod | 比较方式 | | `FindFromEnd` | Boolean | 从末尾开始查找结束标记 | **示例：** ```vb Dim Text As String Dim Result As String Text = "
    Hello World
    " ' 提取div标签内的内容 Result = VBMAN.ToolsStr.SubStr(Text, "
    ", "
    ") Debug.Print Result ' 输出: Hello World ' 从末尾查找 Result = VBMAN.ToolsStr.SubStr(Text, "<", ">", False, vbBinaryCompare, True) Debug.Print Result ' 输出: /div ``` #### MidEx 截取任意位置字符串（支持起始位置）。 ```vb Public Function MidEx(FullStr As String, Lstr As String, Rstr As String, Optional starindex As Long) As String ``` **示例：** ```vb Dim Text As String Text = "name[张三]age[25]city[北京]" Dim Result As String Dim StartPos As Long Result = VBMAN.ToolsStr.MidEx(Text, "[", "]", StartPos) Debug.Print Result ' 输出: 张三 Debug.Print StartPos ' 输出: 下一个查找的起始位置 ``` #### ToArray 将字符串转换为字符数组。 ```vb Public Function ToArray(Text As String) As String() ``` **示例：** ```vb Dim CharArray() As String CharArray = VBMAN.ToolsStr.ToArray("Hello") Dim i As Long For i = LBound(CharArray) To UBound(CharArray) Debug.Print CharArray(i) ' 输出: H e l l o Next i ``` *** ### 字符串修剪与处理 #### TrimEx 去除字符串前后的空白字符（包括不可见字符）。 ```vb Public Function TrimEx(ByRef Text As String, Optional IsLeft As Boolean = True, Optional IsRight As Boolean = True) As String ``` **参数：** | 参数名 | 类型 | 说明 | |--------|------|------| | `Text` | String | 源字符串 | | `IsLeft` | Boolean | 是否去除左侧空白 | | `IsRight` | Boolean | 是否去除右侧空白 | **示例：** ```vb Dim Text As String Text = vbCrLf & " Hello World " & vbTab Debug.Print VBMAN.ToolsStr.TrimEx(Text) ' 输出: Hello World Debug.Print VBMAN.ToolsStr.TrimEx(Text, True, False) ' 输出: Hello World \t Debug.Print VBMAN.ToolsStr.TrimEx(Text, False, True) ' 输出: \r\n Hello World ``` #### RightEx / LeftEx 获取字符串右侧/左侧指定长度的字符。 ```vb Public Function RightEx(Text As Variant, Length As Long) As String Public Function LeftEx(Text As Variant, Length As Long) As String ``` **示例：** ```vb Dim Text As String Text = " Hello World " Debug.Print VBMAN.ToolsStr.RightEx(Text, 5) ' 输出: World Debug.Print VBMAN.ToolsStr.LeftEx(Text, 5) ' 输出: Hello ``` #### InsertSpan 每隔指定字符数插入分隔符。 ```vb Public Function InsertSpan(ByRef inputStr As String, ByVal Span As String, ByVal SetpNum As Long, Optional HeadFoot As Boolean) As String ``` **参数：** | 参数名 | 类型 | 说明 | |--------|------|------| | `inputStr` | String | 源字符串 | | `Span` | String | 分隔符 | | `SetpNum` | Long | 每隔多少字符插入 | | `HeadFoot` | Boolean | 是否在首尾也添加分隔符 | **示例：** ```vb Dim Text As String Text = "1234567890123456" ' 每4位插入一个空格 Debug.Print VBMAN.ToolsStr.InsertSpan(Text, " ", 4) ' 输出: 1234 5678 9012 3456 Debug.Print VBMAN.ToolsStr.InsertSpan(Text, "-", 4, True) ' 输出: -1234-5678-9012-3456- ``` *** ### 字符串编码转换 #### PercentEncode / PercentDecode 百分号编码/解码（将数字转换为%格式）。 ```vb Public Function PercentEncode(inputStr As String) As String Function PercentDecode(encodedStr As String) As String ``` **示例：** ```vb Dim Text As String Text = "43068119891129321X" Dim Encoded As String Encoded = VBMAN.ToolsStr.PercentEncode(Text) Debug.Print Encoded ' 输出: %34%33%30%36%38%31%31%39%38%39%31%31%32%39%33%32%31X Dim Decoded As String Decoded = VBMAN.ToolsStr.PercentDecode(Encoded) Debug.Print Decoded ' 输出: 43068119891129321X ``` #### UnicodeEncode / UnicodeDecode Unicode 编码/解码（\uXXXX格式）。 ```vb Public Function UnicodeEncode(ByVal inputString As String, Optional PreFix As String = "\u") As String Public Function UnicodeDecode(Text As String, Optional PreFix As String = "\u") As String ``` **示例：** ```vb Dim Text As String Text = "你好 World" Dim Encoded As String Encoded = VBMAN.ToolsStr.UnicodeEncode(Text) Debug.Print Encoded ' 输出: \u4F60\u597D World Dim Decoded As String Decoded = VBMAN.ToolsStr.UnicodeDecode(Encoded) Debug.Print Decoded ' 输出: 你好 World ``` *** ### 字节数组操作 #### ToBytes 将字符串转换为字节数组（Unicode）。 ```vb Public Function ToBytes(inputString As String) As Byte() ``` **示例：** ```vb Dim Bytes() As Byte Bytes = VBMAN.ToolsStr.ToBytes("Hello") ``` #### FromByteArray 将字节数组转换为字符串。 ```vb Public Function FromByteArray(inputArray() As Byte, Optional CharSet As String = "UTF-8") As String ``` **示例：** ```vb Dim Bytes() As Byte Bytes = VBMAN.ToolsStr.ToBytes("Hello") Dim Text As String Text = VBMAN.ToolsStr.FromByteArray(Bytes) Debug.Print Text ' 输出: Hello ``` #### LenBytes 计算字节数组长度。 ```vb Public Function LenBytes(inputArray() As Byte) As Long ``` **示例：** ```vb Dim Bytes() As Byte Bytes = VBMAN.ToolsStr.ToBytes("Hello") Debug.Print VBMAN.ToolsStr.LenBytes(Bytes) ' 输出: 5 ``` #### ToHex / FromHex 字符串与十六进制转换。 ```vb Public Function ToHex(InputData As Variant, Optional CharSet As String = "UTF-8") As String Public Function FromHex(hexStr As String, Optional CharSet As String = "UTF-8") As String ``` **示例：** ```vb Dim Text As String Text = "Hello" ' 转为十六进制 Dim HexStr As String HexStr = VBMAN.ToolsStr.ToHex(Text) Debug.Print HexStr ' 输出: 48656C6C6F ' 从十六进制还原 Dim Original As String Original = VBMAN.ToolsStr.FromHex(HexStr) Debug.Print Original ' 输出: Hello ``` *** ### 随机字符串生成 #### GetRandStr 获取随机字符串。 ```vb Public Function GetRandStr(Optional ByVal Lens As Long = 32, Optional Zuhe As String = "1aA") As String ``` **参数：** | 参数名 | 类型 | 说明 | |--------|------|------| | `Lens` | Long | 字符串长度 | | `Zuhe` | String | 字符组合：1=数字, a=小写, A=大写, @=特殊字符 | **示例：** ```vb ' 纯数字，8位 Debug.Print VBMAN.ToolsStr.GetRandStr(8, "1") ' 数字+小写字母，16位 Debug.Print VBMAN.ToolsStr.GetRandStr(16, "1a") ' 数字+大小写字母，32位 Debug.Print VBMAN.ToolsStr.GetRandStr(32, "1aA") ' 包含特殊字符 Debug.Print VBMAN.ToolsStr.GetRandStr(16, "1aA@") ``` #### GetRandByte / GetRandByteToHex 获取随机字节数组。 ```vb Public Function GetRandByte(Optional ByteSize As Long = 32) As Byte() Public Function GetRandByteToHex(Optional ByteSize As Long = 32, Optional Span As String = "") As String ``` **示例：** ```vb ' 获取32字节随机数组 Dim Bytes() As Byte Bytes = VBMAN.ToolsStr.GetRandByte(32) ' 获取16字节随机字符串（十六进制） Dim HexStr As String HexStr = VBMAN.ToolsStr.GetRandByteToHex(16) Debug.Print HexStr ' 输出: a3f7b2c8d1e5... ' 带分隔符 HexStr = VBMAN.ToolsStr.GetRandByteToHex(16, "-") Debug.Print HexStr ' 输出: a3-f7-b2-c8-... ``` *** ### GUID 生成 #### GetGUID 生成 GUID 字符串。 ```vb Public Function GetGUID(Optional isFull As Boolean) As String ``` **参数：** | 参数名 | 类型 | 说明 | |--------|------|------| | `isFull` | Boolean | 是否返回完整格式（包含括号） | **示例：** ```vb ' 标准GUID格式 Debug.Print VBMAN.ToolsStr.GetGUID() ' 输出: 550e8400-e29b-41d4-a716-446655440000 ' 完整格式（带括号） Debug.Print VBMAN.ToolsStr.GetGUID(True) ' 输出: {550e8400-e29b-41d4-a716-446655440000} ``` *** ### 辅助函数 #### JoinStr 使用指定分隔符连接多个字符串。 ```vb Public Function JoinStr(Span As String, ParamArray Strings() As Variant) As String ``` **示例：** ```vb Dim Result As String Result = VBMAN.ToolsStr.JoinStr("-", "2024", "05", "17") Debug.Print Result ' 输出: 2024-05-17 ``` #### UniVbCrLf 统一换行符为 vbCrLf。 ```vb Public Function UniVbCrLf(Text As String) As String ``` **示例：** ```vb Dim Text As String Text = "Line1" & vbLf & "Line2" & vbCr & "Line3" Dim Result As String Result = VBMAN.ToolsStr.UniVbCrLf(Text) ' 结果: Line1\r\nLine2\r\nLine3 ``` #### GetFirstChar / GetLastChar 获取首/尾有效字符。 ```vb Public Function GetFirstChar(Txt As String, Optional Length As Long = 1) As String Public Function GetLastChar(Txt As String, Optional Length As Long = 1) As String ``` **示例：** ```vb Dim Text As String Text = " Hello World " Debug.Print VBMAN.ToolsStr.GetFirstChar(Text) ' 输出: H Debug.Print VBMAN.ToolsStr.GetLastChar(Text) ' 输出: d Debug.Print VBMAN.ToolsStr.GetFirstChar(Text, 5) ' 输出: Hello ``` *** ## cFormater - 通用格式化器 ### 概述 支持链式调用的通用格式化类，可格式化文件大小、时间、数字等。 ### 链式入口 #### Data 设置要格式化的数据源。 ```vb Public Function Data(ByVal Source As Variant) As cFormater ``` ### 文件大小格式化 #### ReturnFileSize 格式化文件大小为易读格式（B/KB/MB/GB/TB）。 ```vb Public Function ReturnFileSize(Optional ByVal DecimalPlaces As Long = 2, Optional ByVal ForceUnit As String = "") As String ``` **示例：** ```vb ' 自动选择单位 Debug.Print VBMAN.Formater.Data(1536).ReturnFileSize() ' 1.50 KB Debug.Print VBMAN.Formater.Data(1572864).ReturnFileSize() ' 1.50 MB ' 强制单位 Debug.Print VBMAN.Formater.Data(1024).ReturnFileSize(2, "KB") ' 1.00 KB Debug.Print VBMAN.Formater.Data(1024).ReturnFileSize(2, "B") ' 1024.00 B ``` ### 时间格式化 #### ReturnRelativeTime 返回相对时间描述（几秒前、几分钟前等）。 ```vb Public Function ReturnRelativeTime() As String ``` **示例：** ```vb Dim Ts As Currency Ts = VBMAN.ToolsDateTime.GetUnixTimestamp() - 60000 ' 1分钟前 Debug.Print VBMAN.Formater.Data(Ts).ReturnRelativeTime() ' 1分钟前 ``` #### ReturnDuration 格式化持续时间。 ```vb Public Function ReturnDuration(Optional ByVal Precision As String = "auto") As String ``` **示例：** ```vb Debug.Print VBMAN.Formater.Data(65000).ReturnDuration() ' 1分5秒 Debug.Print VBMAN.Formater.Data(3661000).ReturnDuration() ' 1小时1分1秒 ``` ### 数字格式化 #### ReturnNumber 格式化数字（千分位、小数位等）。 ```vb Public Function ReturnNumber(Optional ByVal DecimalPlaces As Long = -1, Optional ByVal UseThousandSeparator As Boolean = True) As String ``` **示例：** ```vb Debug.Print VBMAN.Formater.Data(1234567.89).ReturnNumber() ' 1,234,567.89 Debug.Print VBMAN.Formater.Data(1234567.89).ReturnNumber(0) ' 1,234,568 ``` ### 完整示例 ```vb Private Sub FormatterDemo() ' 文件大小 Dim FileSize As Currency FileSize = FileLen("C:\\largefile.zip") lblSize.Caption = VBMAN.Formater.Data(FileSize).ReturnFileSize() ' 数字千分位 Dim Amount As Currency Amount = 1234567.89 lblAmount.Caption = VBMAN.Formater.Data(Amount).ReturnNumber(2) ' 相对时间 Dim LastTime As Currency LastTime = GetLastLoginTime() ' Unix 时间戳 lblLastLogin.Caption = VBMAN.Formater.Data(LastTime).ReturnRelativeTime() End Sub ``` --- --- url: /en/vbman/tools/array.md --- # Tools - Array Tools ## cToolsArray - Array Operation Tools ### Overview Provides practical methods for array operations, including removing elements, array extension, slicing, destructuring, etc. ### Methods #### Remove Removes element at specified index from array, subsequent elements move forward automatically. ```vb Public Function Remove(ByRef Arr As Variant, ByVal Index As Integer) As Boolean ``` **Parameters:** | Parameter | Type | Description | | --------- | ------- | ---------------------------------- | | `Arr` | Variant | Array to operate on (ByRef passed) | | `Index` | Integer | Index of element to remove | **Return Value:** * `True` - Removal successful * `False` - Removal failed (array empty or index out of bounds) **Example:** ```vb Dim Arr As Variant Arr = Array("a", "b", "c", "d") ' Remove element at index 1 ("b") VBMAN.ToolsArray.Remove Arr, 1 ' Result: Arr = ["a", "c", "d"] Debug.Print Join(Arr, ",") ' Output: a,c,d ``` #### extend Extends values from source array to target array. ```vb Public Property Let extend(Vars As Variant, Value As Variant) ``` **Example:** ```vb Dim Target(0 To 2) As String Dim Source As Variant Source = Split("x/y/z", "/") ' Assign Source values to Target VBMAN.ToolsArray.extend(Target) = Source Debug.Print Target(0) ' Output: x ``` #### DeArray Destructures array to variables (assigns array elements to multiple variables). ```vb Public Sub DeArray(Arr As Variant, ParamArray OutVars()) ``` **Parameters:** | Parameter | Type | Description | | --------- | ---------- | --------------------- | | `Arr` | Variant | Source array | | `OutVars` | ParamArray | Output variable array | **Example:** ```vb Dim A As String, C As String ' Assign array element 0 to A, element 2 to C VBMAN.ToolsArray.DeArray Split("a/b/c", "/"), A, , C Debug.Print A ' Output: a Debug.Print C ' Output: c ``` #### IsArrayEmpty Checks if array is empty. ```vb Public Function IsArrayEmpty(Arr As Variant) As Boolean ``` **Return Value:** * `True` - Array is empty * `False` - Array is not empty **Example:** ```vb Dim EmptyArr() As Variant Dim Arr As Variant Arr = Array("a", "b") Debug.Print VBMAN.ToolsArray.IsArrayEmpty(EmptyArr) ' Output: True Debug.Print VBMAN.ToolsArray.IsArrayEmpty(Arr) ' Output: False ``` #### GetIndexByValue Finds index of value in array. ```vb Public Function GetIndexByValue(Arr As Variant, Value As String) As Long ``` **Parameters:** | Parameter | Type | Description | | --------- | ------- | --------------- | | `Arr` | Variant | Array to search | | `Value` | String | Value to find | **Return Value:** * Returns index if found (0-based) * Returns -1 if not found **Example:** ```vb Dim Arr As Variant Arr = Array("apple", "banana", "cherry") Dim Index As Long Index = VBMAN.ToolsArray.GetIndexByValue(Arr, "banana") Debug.Print Index ' Output: 1 ``` #### IsControlArray Checks if control is a control array. ```vb Public Function IsControlArray(Ctl As Object) As Boolean ``` **Example:** ```vb ' Check if Command1 is a control array If VBMAN.ToolsArray.IsControlArray(Command1) Then Debug.Print "Command1 is a control array" End If ``` *** ## Array Slice Functions ### SliceByteArray Processes Byte array slicing. ```vb Function SliceByteArray(ByRef Arr() As Byte, ByVal StartPos As Long, Optional ByVal EndPos As Long = -1) As Byte() ``` **Parameters:** | Parameter | Type | Description | | ---------- | ------ | --------------------------------------- | | `Arr` | Byte() | Source byte array | | `StartPos` | Long | Start position (0-based) | | `EndPos` | Long | End position (0-based), -1 means to end | **Example:** ```vb Dim ByteArray() As Byte Dim Sliced() As Byte ByteArray = StrConv("Hello-World", vbFromUnicode) Sliced = VBMAN.ToolsArray.SliceByteArray(ByteArray, 0, 4) ' Output slice result Dim i As Long For i = LBound(Sliced) To UBound(Sliced) Debug.Print Chr(Sliced(i)); ' Output: Hello Next i ``` ### SliceString Processes String type slicing. ```vb Function SliceString(ByVal Arr As String, ByVal StartPos As Long, Optional ByVal EndPos As Long = -1) As String ``` **Example:** ```vb Dim str As String Dim sliced As String str = "Hello World" sliced = VBMAN.ToolsArray.SliceString(str, 0, 4) Debug.Print sliced ' Output: Hello ``` ### SliceLongArray Processes Long type array slicing. ```vb Function SliceLongArray(ByRef Arr() As Long, ByVal StartPos As Long, Optional ByVal EndPos As Long = -1) As Long() ``` **Example:** ```vb Dim LongArr() As Long Dim Sliced() As Long LongArr = Array(10, 20, 30, 40, 50, 60, 70) Sliced = VBMAN.ToolsArray.SliceLongArray(LongArr, 2, 5) ' Output: 30, 40, 50, 60 ``` *** ## Byte Array Operation Functions ### StringToByteArray Converts string to byte array. ```vb Public Function StringToByteArray(ByVal St As String) As Byte() ``` **Example:** ```vb Dim Bytes() As Byte Bytes = VBMAN.ToolsArray.StringToByteArray("Hello") ``` ### GetArrayLength Gets array length. ```vb Public Function GetArrayLength(Arr() As Variant) As Long ``` **Example:** ```vb Dim Arr As Variant Arr = Array("a", "b", "c") Debug.Print VBMAN.ToolsArray.GetArrayLength(Arr) ' Output: 3 ``` ### FindByteArray Finds position of keyword byte array in byte array. ```vb Public Function FindByteArray(ByRef Arr() As Byte, ByRef Keyword() As Byte) As Long ``` **Return Value:** * Returns start position if found (0-based) * Returns -1 if not found **Example:** ```vb Dim Data() As Byte Dim Keyword() As Byte Data = StrConv("Hello World, Hello VB", vbFromUnicode) Keyword = StrConv("World", vbFromUnicode) Dim Pos As Long Pos = VBMAN.ToolsArray.FindByteArray(Data, Keyword) Debug.Print Pos ' Output: 6 ``` ### SplitByteArray Splits byte array into two arrays. ```vb Public Function SplitByteArray(ByRef Arr() As Byte, ByVal Position As Long, Optional Offset As Long) As Variant ``` **Return Value:** Returns Variant array containing two byte arrays: * Index 0: First part * Index 1: Second part (starting from Position + Offset) **Example:** ```vb Dim Data() As Byte Dim Result As Variant Data = StrConv("HelloWorldVB", vbFromUnicode) Result = VBMAN.ToolsArray.SplitByteArray(Data, 5, 0) ' Result(0) = "Hello" ' Result(1) = "WorldVB" ``` ### SplitByteArrayByKeyword Splits byte array by keyword, supports multiple splits. ```vb Function SplitByteArrayByKeyword(ByRef ByteArray() As Byte, ByVal Keyword As Variant, Optional ByVal SplitCount As Long) As Variant ``` **Parameters:** | Parameter | Type | Description | | ------------ | ------- | --------------------------------------- | | `ByteArray` | Byte() | Byte array to split | | `Keyword` | Variant | Keyword (supports string or byte array) | | `SplitCount` | Long | Split count, 0 means split all | **Return Value:** Returns Variant array, each element is a byte array. **Example:** ```vb Dim ByteArray() As Byte Dim Keyword As String Dim Result As Variant Dim i As Long ByteArray = StrConv("Hello World, This is a test. Hello World again!", vbFromUnicode) Keyword = "World" Result = VBMAN.ToolsArray.SplitByteArrayByKeyword(ByteArray, Keyword) For i = LBound(Result) To UBound(Result) Debug.Print "Part " & (i + 1) & ": " & StrConv(Result(i), vbUnicode) Next i ``` *** ## cToolsList - Recordset Conversion Tools ### Overview Provides conversion functionality between ADODB.Recordset and Collection/Dictionary. ### Methods #### RsToCollection Converts ADODB.Recordset to cCollection (dictionary array). ```vb Public Function RsToCollection(Obj As Variant) As cCollection ``` **Parameters:** | Parameter | Type | Description | | --------- | ------- | ---------------------- | | `Obj` | Variant | ADODB.Recordset object | **Return Value:** Returns `cCollection`, where each element is a `Dictionary` representing one record. **Example:** ```vb Dim Rs As New ADODB.Recordset Dim Coll As cCollection Dim Row As Dictionary ' Execute query Set Rs = Db.Execute("SELECT * FROM Users") ' Convert to collection Set Coll = VBMAN.ToolsList.RsToCollection(Rs) ' Iterate results Dim i As Long For i = 1 To Coll.Count Set Row = Coll(i) Debug.Print Row("UserName") & " - " & Row("Email") Next i ``` **Description:** * Supports pagination (preserves original recordset's pagination state) * Supports filters (preserves original recordset's Filter) * Clones recordset for iteration, does not affect original recordset position --- --- url: /zh/vbman/tools/base64.md --- # Tools - Base64 编码工具 ## cToolsBase64 - Base64 编解码 ### 概述 提供 Base64 字符串的编码和解码功能，支持标准 Base64 和 UTF-8 Base64，以及字节数组和文件操作。 ### 方法 #### Encode 将字符串编码为 Base64 格式。 ```vb Public Function Encode(ByVal Data As String) As String ``` **参数：** | 参数名 | 类型 | 说明 | |--------|------|------| | `Data` | String | 要编码的原始字符串 | **返回值：** Base64 编码后的字符串。 **示例：** ```vb Dim Base64 As String Base64 = VBMAN.ToolsBase64.Encode("Hello World") Debug.Print Base64 ' 输出: SGVsbG8gV29ybGQ= ``` #### Decode 将 Base64 字符串解码为原始字符串。 ```vb Public Function Decode(ByVal Data As String) As String ``` **参数：** | 参数名 | 类型 | 说明 | |--------|------|------| | `Data` | String | Base64 编码的字符串 | **返回值：** 解码后的原始字符串。 **示例：** ```vb Dim Original As String Original = VBMAN.ToolsBase64.Decode("SGVsbG8gV29ybGQ=") Debug.Print Original ' 输出: Hello World ``` *** ## UTF-8 Base64 编解码 #### Utf8Encode 将字符串按 UTF-8 编码后再进行 Base64 编码。 ```vb Public Function Utf8Encode(ByVal Data As String) As String ``` **说明：** * 先将字符串转为 UTF-8 字节数组 * 再进行 Base64 编码 * 适合处理包含中文等非 ASCII 字符的字符串 **示例：** ```vb Dim Text As String Text = "你好世界" ' 标准 Base64（可能有乱码） Debug.Print VBMAN.ToolsBase64.Encode(Text) ' UTF-8 Base64（推荐用于中文） Debug.Print VBMAN.ToolsBase64.Utf8Encode(Text) ' 输出: 5L2g5aW95LiW55WM ``` #### Utf8Decode 将 UTF-8 Base64 字符串解码。 ```vb Public Function Utf8Decode(ByVal Data As String) As String ``` **示例：** ```vb Dim Encoded As String Encoded = "5L2g5aW95LiW55WM" Dim Decoded As String Decoded = VBMAN.ToolsBase64.Utf8Decode(Encoded) Debug.Print Decoded ' 输出: 你好世界 ``` *** ## 字节数组操作 #### BytesToBase64 将字节数组编码为 Base64 字符串。 ```vb Public Function BytesToBase64(ByRef Bytes() As Byte) As String ``` **参数：** | 参数名 | 类型 | 说明 | |--------|------|------| | `Bytes` | Byte() | 要编码的字节数组 | **返回值：** Base64 编码后的字符串。 **示例：** ```vb Dim Bytes() As Byte Bytes = StrConv("Hello", vbFromUnicode) Dim Base64 As String Base64 = VBMAN.ToolsBase64.BytesToBase64(Bytes) Debug.Print Base64 ' 输出: SGVsbG8= ``` #### Base64ToBytes 将 Base64 字符串解码为字节数组。 ```vb Public Function Base64ToBytes(ByVal Data As String) As Byte() ``` **参数：** | 参数名 | 类型 | 说明 | |--------|------|------| | `Data` | String | Base64 编码的字符串 | **返回值：** 解码后的字节数组。 **示例：** ```vb Dim Base64 As String Base64 = "SGVsbG8gV29ybGQ=" Dim Bytes() As Byte Bytes = VBMAN.ToolsBase64.Base64ToBytes(Base64) ' 转回字符串 Dim Text As String Text = StrConv(Bytes, vbUnicode) Debug.Print Text ' 输出: Hello World ``` *** ## 文件操作 #### FileToBase64 将文件内容编码为 Base64 字符串。 ```vb Public Function FileToBase64(ByVal Path As String, Optional ImageType As String) As String ``` **参数：** | 参数名 | 类型 | 说明 | |--------|------|------| | `Path` | String | 文件路径 | | `ImageType` | String | 图片类型（如 "png", "jpg"），提供时返回 Data URI 格式 | **返回值：** * 普通 Base64 字符串，或 * Data URI 格式（如提供了 ImageType）：`data:image/png;base64,xxxx` **示例：** ```vb ' 普通 Base64 Dim Base64 As String Base64 = VBMAN.ToolsBase64.FileToBase64("C:\\image.png") ' Data URI 格式（适合直接用于 HTML） Dim DataUri As String DataUri = VBMAN.ToolsBase64.FileToBase64("C:\\image.png", "png") Debug.Print DataUri ' 输出: data:image/png;base64,iVBORw0KGgo... ``` #### Base64ToFile 将 Base64 字符串解码并保存为文件。 ```vb Public Function Base64ToFile(ByRef Data As String, Optional ByVal Path As String) As Byte() ``` **参数：** | 参数名 | 类型 | 说明 | |--------|------|------| | `Data` | String | Base64 编码的字符串（支持 Data URI 格式） | | `Path` | String | 可选，保存路径 | **返回值：** 解码后的字节数组。 **示例：** ```vb Dim Base64 As String Base64 = "iVBORw0KGgoAAAANSUhEUgAAAAEAAAABCAYAAAAfFcSJAAAADUlEQVR42mNk+M9QDwADhgGAWjR9awAAAABJRU5ErkJggg==" ' 仅获取字节数组 Dim Bytes() As Byte Bytes = VBMAN.ToolsBase64.Base64ToFile(Base64) ' 保存到文件 VBMAN.ToolsBase64.Base64ToFile Base64, "C:\\output.png" ' 支持 Data URI 格式 Dim DataUri As String DataUri = "data:image/png;base64," & Base64 VBMAN.ToolsBase64.Base64ToFile DataUri, "C:\\output.png" ``` *** ## 完整示例 ```vb Private Sub TestBase64() Dim Original As String Dim Encoded As String Dim Decoded As String Original = "VBMAN 框架是一个强大的 VB6 开发框架" ' 标准编码 Encoded = VBMAN.ToolsBase64.Encode(Original) Debug.Print "编码后: " & Encoded ' 标准解码 Decoded = VBMAN.ToolsBase64.Decode(Encoded) Debug.Print "解码后: " & Decoded ' 验证 Debug.Print "是否一致: " & (Original = Decoded) ' UTF-8 编码（推荐用于中文） Encoded = VBMAN.ToolsBase64.Utf8Encode(Original) Debug.Print "UTF-8编码: " & Encoded Decoded = VBMAN.ToolsBase64.Utf8Decode(Encoded) Debug.Print "UTF-8解码: " & Decoded End Sub Private Sub TestFileBase64() Dim Base64 As String ' 文件转 Base64 Base64 = VBMAN.ToolsBase64.FileToBase64("C:\\test.pdf") Debug.Print "文件Base64长度: " & Len(Base64) ' Base64 转文件 VBMAN.ToolsBase64.Base64ToFile Base64, "C:\\test_copy.pdf" ' 图片转 Data URI Dim DataUri As String DataUri = VBMAN.ToolsBase64.FileToBase64("C:\\photo.jpg", "jpeg") ' 可用于 HTML WebBrowser1.Document.Write "" End Sub ``` *** ## 应用场景 | 场景 | 示例 | |------|------| | **HTTP 认证** | `Authorization: Basic ` & Base64Encode("user:pass") | | **数据传输** | 对二进制数据进行文本编码传输 | | **URL 参数** | 对复杂数据进行编码后传递 | | **配置文件** | 对敏感信息进行简单混淆存储 | | **图片嵌入** | 将图片转为 Data URI 嵌入 HTML | | **文件传输** | 通过 Base64 传输二进制文件 | --- --- url: /en/vbman/tools/base64.md --- # Tools - Base64 Encoding Utility ## cToolsBase64 - Base64 Encoding and Decoding ### Overview Provides Base64 string encoding and decoding functionality, supporting standard Base64 and UTF-8 Base64, as well as byte array and file operations. ### Methods #### Encode Encodes a string into Base64 format. ```vb Public Function Encode(ByVal Data As String) As String ``` **Parameters:** | Parameter | Type | Description | |-----------|------|-------------| | `Data` | String | The original string to encode | **Returns:** The Base64-encoded string. **Example:** ```vb Dim Base64 As String Base64 = VBMAN.ToolsBase64.Encode("Hello World") Debug.Print Base64 ' Output: SGVsbG8gV29ybGQ= ``` #### Decode Decodes a Base64 string back to the original string. ```vb Public Function Decode(ByVal Data As String) As String ``` **Parameters:** | Parameter | Type | Description | |-----------|------|-------------| | `Data` | String | The Base64-encoded string | **Returns:** The decoded original string. **Example:** ```vb Dim Original As String Original = VBMAN.ToolsBase64.Decode("SGVsbG8gV29ybGQ=") Debug.Print Original ' Output: Hello World ``` *** ## UTF-8 Base64 Encoding and Decoding #### Utf8Encode Encodes a string using UTF-8 encoding before Base64 encoding. ```vb Public Function Utf8Encode(ByVal Data As String) As String ``` **Description:** * First converts the string to UTF-8 byte array * Then performs Base64 encoding * Suitable for handling strings containing non-ASCII characters like Chinese **Example:** ```vb Dim Text As String Text = "你好世界" ' Standard Base64 (may produce garbled characters) Debug.Print VBMAN.ToolsBase64.Encode(Text) ' UTF-8 Base64 (recommended for Chinese text) Debug.Print VBMAN.ToolsBase64.Utf8Encode(Text) ' Output: 5L2g5aW95LiW55WM ``` #### Utf8Decode Decodes a UTF-8 Base64 string. ```vb Public Function Utf8Decode(ByVal Data As String) As String ``` **Example:** ```vb Dim Encoded As String Encoded = "5L2g5aW95LiW55WM" Dim Decoded As String Decoded = VBMAN.ToolsBase64.Utf8Decode(Encoded) Debug.Print Decoded ' Output: 你好世界 ``` *** ## Byte Array Operations #### BytesToBase64 Encodes a byte array into a Base64 string. ```vb Public Function BytesToBase64(ByRef Bytes() As Byte) As String ``` **Parameters:** | Parameter | Type | Description | |-----------|------|-------------| | `Bytes` | Byte() | The byte array to encode | **Returns:** The Base64-encoded string. **Example:** ```vb Dim Bytes() As Byte Bytes = StrConv("Hello", vbFromUnicode) Dim Base64 As String Base64 = VBMAN.ToolsBase64.BytesToBase64(Bytes) Debug.Print Base64 ' Output: SGVsbG8= ``` #### Base64ToBytes Decodes a Base64 string into a byte array. ```vb Public Function Base64ToBytes(ByVal Data As String) As Byte() ``` **Parameters:** | Parameter | Type | Description | |-----------|------|-------------| | `Data` | String | The Base64-encoded string | **Returns:** The decoded byte array. **Example:** ```vb Dim Base64 As String Base64 = "SGVsbG8gV29ybGQ=" Dim Bytes() As Byte Bytes = VBMAN.ToolsBase64.Base64ToBytes(Base64) ' Convert back to string Dim Text As String Text = StrConv(Bytes, vbUnicode) Debug.Print Text ' Output: Hello World ``` *** ## File Operations #### FileToBase64 Encodes file content into a Base64 string. ```vb Public Function FileToBase64(ByVal Path As String, Optional ImageType As String) As String ``` **Parameters:** | Parameter | Type | Description | |-----------|------|-------------| | `Path` | String | File path | | `ImageType` | String | Image type (e.g., "png", "jpg"), returns Data URI format when provided | **Returns:** * Normal Base64 string, or * Data URI format (when ImageType is provided): `data:image/png;base64,xxxx` **Example:** ```vb ' Normal Base64 Dim Base64 As String Base64 = VBMAN.ToolsBase64.FileToBase64("C:\\image.png") ' Data URI format (suitable for direct use in HTML) Dim DataUri As String DataUri = VBMAN.ToolsBase64.FileToBase64("C:\\image.png", "png") Debug.Print DataUri ' Output: data:image/png;base64,iVBORw0KGgo... ``` #### Base64ToFile Decodes a Base64 string and saves it as a file. ```vb Public Function Base64ToFile(ByRef Data As String, Optional ByVal Path As String) As Byte() ``` **Parameters:** | Parameter | Type | Description | |-----------|------|-------------| | `Data` | String | Base64-encoded string (supports Data URI format) | | `Path` | String | Optional, save path | **Returns:** The decoded byte array. **Example:** ```vb Dim Base64 As String Base64 = "iVBORw0KGgoAAAANSUhEUgAAAAEAAAABCAYAAAAfFcSJAAAADUlEQVR42mNk+M9QDwADhgGAWjR9awAAAABJRU5ErkJggg==" ' Get byte array only Dim Bytes() As Byte Bytes = VBMAN.ToolsBase64.Base64ToFile(Base64) ' Save to file VBMAN.ToolsBase64.Base64ToFile Base64, "C:\\output.png" ' Supports Data URI format Dim DataUri As String DataUri = "data:image/png;base64," & Base64 VBMAN.ToolsBase64.Base64ToFile DataUri, "C:\\output.png" ``` *** ## Complete Examples ```vb Private Sub TestBase64() Dim Original As String Dim Encoded As String Dim Decoded As String Original = "VBMAN Framework is a powerful VB6 development framework" ' Standard encoding Encoded = VBMAN.ToolsBase64.Encode(Original) Debug.Print "Encoded: " & Encoded ' Standard decoding Decoded = VBMAN.ToolsBase64.Decode(Encoded) Debug.Print "Decoded: " & Decoded ' Verification Debug.Print "Match: " & (Original = Decoded) ' UTF-8 encoding (recommended for Chinese text) Encoded = VBMAN.ToolsBase64.Utf8Encode(Original) Debug.Print "UTF-8 Encoded: " & Encoded Decoded = VBMAN.ToolsBase64.Utf8Decode(Encoded) Debug.Print "UTF-8 Decoded: " & Decoded End Sub Private Sub TestFileBase64() Dim Base64 As String ' File to Base64 Base64 = VBMAN.ToolsBase64.FileToBase64("C:\\test.pdf") Debug.Print "File Base64 length: " & Len(Base64) ' Base64 to file VBMAN.ToolsBase64.Base64ToFile Base64, "C:\\test_copy.pdf" ' Image to Data URI Dim DataUri As String DataUri = VBMAN.ToolsBase64.FileToBase64("C:\\photo.jpg", "jpeg") ' Can be used in HTML WebBrowser1.Document.Write "" End Sub ``` *** ## Use Cases | Scenario | Example | |----------|---------| | **HTTP Authentication** | `Authorization: Basic ` & Base64Encode("user:pass") | | **Data Transmission** | Text encoding of binary data for transmission | | **URL Parameters** | Encoding complex data for transmission | | **Configuration Files** | Simple obfuscation for storing sensitive information | | **Image Embedding** | Convert images to Data URI embedded in HTML | | **File Transmission** | Transmitting binary files via Base64 | --- --- url: /zh/vbman/tools/crc.md --- # Tools - CRC 计算类 > **类文件：** `src\Tools\Crc\cToolsCrc.cls` *** ## 概述 `cToolsCrc` 是一个 CRC16/32 计算类，支持逐位计算法和查表法。采用链式调用设计，可方便地连续调用多个方法。 **特性：** * 支持 CRC16-Modbus 计算（多项式 0xA001） * 支持 CRC32 计算（多项式 0xEDB88320，IEEE 802.3） * 链式调用支持（每个计算函数返回自身实例） * 多种数据输入方式（字节数组、HEX字符串、文本字符串） * 多种结果输出格式（Long、Currency、字节数组、Hex 字符串） *** ## 枚举类型 ### CRCType 枚举 ```vb Public Enum CRCType CRC16 = 0 CRC32 = 1 End Enum ``` ### CRCDataType 枚举 ```vb Public Enum CRCDataType DataType_ByteArray = 0 ' 字节数组 DataType_HexString = 1 ' HEX字符串（自动处理空格） DataType_Text = 2 ' 文本字符串 End Enum ``` *** ## 方法 ### Data (默认成员) 设置数据到内部缓存，供后续计算使用。此方法是类的**默认成员**，可以省略调用。 ```vb Public Function Data(Optional ByVal DataType As CRCDataType = DataType_ByteArray, Optional ByVal Content As Variant = Empty) As cToolsCrc ``` **参数：** | 参数名 | 类型 | 说明 | |--------|------|------| | `DataType` | CRCDataType | 数据类型（可选，默认为字节数组） | | `Content` | Variant | 数据内容 | **DataType 说明：** | 类型 | 值 | 说明 | |------|-----|------| | `DataType_ByteArray` | 0 | 字节数组 (`Byte()`) | | `DataType_HexString` | 1 | HEX 字符串，自动处理空格、横杠、冒号等分隔符 | | `DataType_Text` | 2 | 文本字符串，自动转换为 ANSI 字节数组 | **返回值：** 返回 `cToolsCrc` 实例，支持链式调用。 **示例：** ```vb Dim CRC As New cToolsCrc Dim CRCValue As Long ' ========== 方式1: 字节数组 (可省略 DataType 参数) ========== Dim Bytes() As Byte Bytes = StrConv("Hello World", vbFromUnicode) CRCValue = CRC.Data(DataType_ByteArray, Bytes).CalculateCRC16.ReturnLong() ' 或省略 Data 方法名（默认成员） CRCValue = CRC(DataType_ByteArray, Bytes).CalculateCRC16.ReturnLong() ' ========== 方式2: HEX 字符串 ========== Dim HexStr As String HexStr = "48 65 6C 6C 6F" ' "Hello" 的 HEX CRCValue = CRC(DataType_HexString, HexStr).CalculateCRC16.ReturnLong() ' 支持多种分隔符格式 CRC(DataType_HexString, "48-65-6C-6C-6F").CalculateCRC16.ReturnLong() CRC(DataType_HexString, "48:65:6C:6C:6F").CalculateCRC16.ReturnLong() CRC(DataType_HexString, "48656C6C6F").CalculateCRC16.ReturnLong() ' ========== 方式3: 文本字符串 ========== Dim Text As String Text = "Hello World" CRCValue = CRC(DataType_Text, Text).CalculateCRC16.ReturnLong() ``` *** ### CalculateCRC16 计算 CRC16（逐位计算法），基于多项式 0xA001（CRC16-Modbus）。 **注意：必须先调用 `Data` 方法设置数据。** ```vb Public Function CalculateCRC16(Optional ByVal StartIndex As Long = 0, Optional ByVal Length As Long = -1) As cToolsCrc ``` **参数：** | 参数名 | 类型 | 说明 | |--------|------|------| | `StartIndex` | Long | 起始索引（可选，默认为 0） | | `Length` | Long | 数据长度（可选，默认为 -1 表示计算到数组末尾） | **返回值：** 返回 `cToolsCrc` 实例，支持链式调用。 **示例：** ```vb Dim CRC As New cToolsCrc Dim CRCValue As Long ' ========== 字节数组方式 ========== Dim Bytes() As Byte Bytes = StrConv("Hello World", vbFromUnicode) CRCValue = CRC(DataType_ByteArray, Bytes).CalculateCRC16.ReturnLong() Debug.Print "CRC16: " & Hex$(CRCValue) ' 输出: CRC16: 3AFA ' ========== HEX 字符串方式 ========== CRCValue = CRC(DataType_HexString, "48 65 6C 6C 6F 20 57 6F 72 6C 64").CalculateCRC16.ReturnLong() ' ========== 文本字符串方式 ========== CRCValue = CRC(DataType_Text, "Hello World").CalculateCRC16.ReturnLong() ``` **计算部分数据：** ```vb ' 只计算前 5 个字节（Hello） Dim CRCValue As Long CRCValue = CRC(DataType_Text, "Hello World").CalculateCRC16(0, 5).ReturnLong() ``` *** ### ReturnLong 返回 CRC 值作为 Long 类型。 ```vb Public Function ReturnLong(Optional ByVal CRCTypeValue As CRCType = CRC16) As Long ``` **参数：** | 参数名 | 类型 | 说明 | |--------|------|------| | `CRCTypeValue` | CRCType | CRC 类型（可选，默认为 CRC16） | **说明：** * CRC16 返回无符号 16 位值（0-65535） * CRC32 返回 Long 类型（若大于 2147483647 则为负数） * 需要无符号 32 位结果时建议使用 `ReturnCurrency` 或 `ReturnHex` **示例：** ```vb ' CRC16 Dim CRC16Value As Long CRC16Value = CRC.CalculateCRC16(Data).ReturnLong(CRC16) ' CRC32 Dim CRC32Value As Long CRC32Value = CRC.CalculateCRC32(Data).ReturnLong(CRC32) ``` *** ### ReturnCurrency 返回 CRC32 值作为 Currency 类型（无符号 32 位）。 ```vb Public Function ReturnCurrency(Optional ByVal CRCTypeValue As CRCType = CRC16) As Currency ``` **参数：** | 参数名 | 类型 | 说明 | |--------|------|------| | `CRCTypeValue` | CRCType | CRC 类型（可选，默认为 CRC16） | **说明：** * CRC32 返回 0 到 4294967295 的正数 * CRC16 返回 0 到 65535 **示例：** ```vb Dim CRC32Value As Currency CRC32Value = CRC.CalculateCRC32(Data).ReturnCurrency(CRC32) Debug.Print "CRC32: " & CRC32Value ' 输出: CRC32: 1243062890 ``` *** ### ReturnBytes 返回 CRC 值作为字节数组（高字节在前）。 ```vb Public Function ReturnBytes(Optional ByVal CRCTypeValue As CRCType = CRC16) As Byte() ``` **参数：** | 参数名 | 类型 | 说明 | |--------|------|------| | `CRCTypeValue` | CRCType | CRC 类型（可选，默认为 CRC16） | **返回值：** * CRC16 返回 2 字节数组（高字节在前） * CRC32 返回 4 字节数组（高字节在前） **示例：** ```vb Dim Result() As Byte Result = CRC.CalculateCRC16(Data).ReturnBytes() ' Result(0) = 高字节 ' Result(1) = 低字节 Debug.Print "Bytes: " & Hex$(Result(0)) & " " & Hex$(Result(1)) ``` *** ### ReturnHex 返回 CRC 值作为十六进制字符串（大写）。 ```vb Public Function ReturnHex(Optional ByVal CRCTypeValue As CRCType = CRC16) As String ``` **参数：** | 参数名 | 类型 | 说明 | |--------|------|------| | `CRCTypeValue` | CRCType | CRC 类型（可选，默认为 CRC16） | **返回值：** * CRC16 返回 4 位大写字符串（如 "B001"） * CRC32 返回 8 位大写字符串（如 "A1B2C3D4"） **示例：** ```vb Dim HexValue As String HexValue = CRC.CalculateCRC16(Data).ReturnHex() Debug.Print "CRC16: " & HexValue ' 输出: CRC16: 3AFA ' CRC32 Dim CRC32Hex As String CRC32Hex = CRC.CalculateCRC32(Data).ReturnHex(CRC32) Debug.Print "CRC32: " & CRC32Hex ' 输出: CRC32: 4A17B156 ``` *** ### ReturnHexString 返回带分隔符的十六进制字符串（适合显示）。 ```vb Public Function ReturnHexString(Optional ByVal CRCTypeValue As CRCType = CRC16, Optional ByVal Separator As String = " ") As String ``` **参数：** | 参数名 | 类型 | 说明 | |--------|------|------| | `CRCTypeValue` | CRCType | CRC 类型（可选，默认为 CRC16） | | `Separator` | String | 分隔符（可选，默认为空格） | **返回值：** * CRC16 如 "B0 01" * CRC32 如 "A1 B2 C3 D4" **示例：** ```vb Dim HexStr As String ' 默认空格分隔 HexStr = CRC.CalculateCRC16(Data).ReturnHexString() Debug.Print HexStr ' 输出: 3A FA ' 自定义分隔符 HexStr = CRC.CalculateCRC16(Data).ReturnHexString(CRC16, "-") Debug.Print HexStr ' 输出: 3A-FA ' CRC32 HexStr = CRC.CalculateCRC32(Data).ReturnHexString(CRC32, ":") Debug.Print HexStr ' 输出: 4A:17:B1:56 ``` *** ## 完整示例 ```vb Private Sub CRCDemo() Dim CRC As New cToolsCrc Dim Data() As Byte Dim CRCValue As Long Dim HexResult As String ' ========== 方式1: 字节数组方式 ========== Data = StrConv("Hello World", vbFromUnicode) ' 返回 Long CRCValue = CRC(DataType_ByteArray, Data).CalculateCRC16.ReturnLong() Debug.Print "CRC16 (Long): " & CRCValue ' 返回 Hex 字符串 HexResult = CRC(DataType_ByteArray, Data).CalculateCRC16.ReturnHex() Debug.Print "CRC16 (Hex): " & HexResult ' 返回带分隔符的 Hex HexResult = CRC(DataType_ByteArray, Data).CalculateCRC16.ReturnHexString(CRC16, "-") Debug.Print "CRC16 (Formatted): " & HexResult ' ========== 方式2: HEX 字符串方式 ========== ' 使用 HEX 字符串（自动处理空格） HexResult = CRC(DataType_HexString, "48 65 6C 6C 6F 20 57 6F 72 6C 64").CalculateCRC16.ReturnHex() Debug.Print "CRC16 from HEX: " & HexResult ' 使用无空格 HEX HexResult = CRC(DataType_HexString, "48656C6C6F20576F726C64").CalculateCRC16.ReturnHex() Debug.Print "CRC16 from HEX (no space): " & HexResult ' 使用横杠分隔 HexResult = CRC(DataType_HexString, "48-65-6C-6C-6F-20-57-6F-72-6C-64").CalculateCRC16.ReturnHex() Debug.Print "CRC16 from HEX (dash): " & HexResult ' ========== 方式3: 文本字符串方式 ========== ' 直接使用文本（自动转换为字节数组） HexResult = CRC(DataType_Text, "Hello World").CalculateCRC16.ReturnHex() Debug.Print "CRC16 from Text: " & HexResult ' ========== 方式4: 链式调用（默认成员语法） ========== ' 最简洁的用法：CRC(DataType, Content).Calculate.Return Debug.Print CRC(DataType_Text, "Test").CalculateCRC16.ReturnHex() ' ========== 计算部分数据示例 ========== ' 只计算前 5 个字节 Dim PartialCRC As Long PartialCRC = CRC(DataType_Text, "Hello World").CalculateCRC16(0, 5).ReturnLong() Debug.Print "CRC16 of 'Hello': " & Hex$(PartialCRC) ' 从第 6 个字节开始计算 PartialCRC = CRC(DataType_Text, "Hello World").CalculateCRC16(6).ReturnLong() Debug.Print "CRC16 of 'World': " & Hex$(PartialCRC) ' ========== 实用示例：计算 Modbus RTU 帧的 CRC ========== ' Modbus RTU 请求帧: 01 03 00 00 00 0A Dim ModbusFrame As String Dim ModbusCRC As String ModbusFrame = "01 03 00 00 00 0A" ModbusCRC = CRC(DataType_HexString, ModbusFrame).CalculateCRC16.ReturnHexString(CRC16, " ") Debug.Print "Modbus CRC: " & ModbusCRC ' 输出: Modbus CRC: C5 CD ' 完整的 Modbus 帧 Debug.Print "Complete Frame: " & ModbusFrame & " " & ModbusCRC End Sub ``` *** ## 技术说明 ### CRC16 参数 | 参数 | 值 | |------|-----| | 多项式 | 0xA001（CRC16-Modbus）| | 初始值 | 0xFFFF | | 输入反转 | 是 | | 输出反转 | 是 | | 结果异或 | 0x0000 | ### CRC32 参数 | 参数 | 值 | |------|-----| | 多项式 | 0xEDB88320（IEEE 802.3）| | 初始值 | 0xFFFFFFFF | | 输入反转 | 是 | | 输出反转 | 是 | | 结果异或 | 0xFFFFFFFF | ### 注意事项 1. **数据类型：** CRC32 计算使用 `Currency` 类型来避免 VB6 中 Long 类型的符号位问题（支持无符号 32 位） 2. **字节序：** 所有返回字节数组的方法使用大端序（高字节在前） 3. **线程安全：** 每个 CRC 计算实例是独立的，可以在多线程环境中使用（需确保 VB6 的线程安全） 4. **性能：** 查表法（Table-Driven）比逐位计算快约 8 倍，适合大数据量处理 5. **默认成员：** `Data` 方法是类的默认成员，可以省略方法名直接调用，如 `CRC(DataType_Text, "Hello")` 等价于 `CRC.Data(DataType_Text, "Hello")` 6. **HEX 字符串：** `DataType_HexString` 类型会自动移除空格、横杠、冒号等常见分隔符，支持多种格式 --- --- url: /en/vbman/tools/crc.md --- # Tools - CRC Calculation Class > **Class File:** `src\Tools\Crc\cToolsCrc.cls` *** ## Overview `cToolsCrc` is a CRC16/32 calculation class that supports bit-by-bit calculation and table lookup methods. It uses a fluent/chaining design for easy consecutive method calls. **Features:** * Supports CRC16-Modbus calculation (polynomial 0xA001) * Supports CRC32 calculation (polynomial 0xEDB88320, IEEE 802.3) * Method chaining support (each calculation function returns its own instance) * Multiple data input methods (byte array, HEX string, text string) * Multiple result output formats (Long, Currency, byte array, Hex string) *** ## Enumerations ### CRCType Enum ```vb Public Enum CRCType CRC16 = 0 CRC32 = 1 End Enum ``` ### CRCDataType Enum ```vb Public Enum CRCDataType DataType_ByteArray = 0 ' Byte array DataType_HexString = 1 ' HEX string (automatically handles spaces) DataType_Text = 2 ' Text string End Enum ``` *** ## Methods ### Data (Default Member) Sets data to the internal buffer for subsequent calculations. This method is the **default member** of the class and can be omitted. ```vb Public Function Data(Optional ByVal DataType As CRCDataType = DataType_ByteArray, Optional ByVal Content As Variant = Empty) As cToolsCrc ``` **Parameters:** | Parameter | Type | Description | |-----------|------|-------------| | `DataType` | CRCDataType | Data type (optional, defaults to byte array) | | `Content` | Variant | Data content | **DataType Description:** | Type | Value | Description | |------|-------|-------------| | `DataType_ByteArray` | 0 | Byte array (`Byte()`) | | `DataType_HexString` | 1 | HEX string, automatically handles spaces, dashes, colons, etc. | | `DataType_Text` | 2 | Text string, automatically converted to ANSI byte array | **Return Value:** Returns `cToolsCrc` instance, supporting method chaining. **Example:** ```vb Dim CRC As New cToolsCrc Dim CRCValue As Long ' ========== Method 1: Byte array (can omit DataType parameter) ========== Dim Bytes() As Byte Bytes = StrConv("Hello World", vbFromUnicode) CRCValue = CRC.Data(DataType_ByteArray, Bytes).CalculateCRC16.ReturnLong() ' Or omit Data method name (default member) CRCValue = CRC(DataType_ByteArray, Bytes).CalculateCRC16.ReturnLong() ' ========== Method 2: HEX string ========== Dim HexStr As String HexStr = "48 65 6C 6C 6F" ' HEX of "Hello" CRCValue = CRC(DataType_HexString, HexStr).CalculateCRC16.ReturnLong() ' Supports multiple delimiter formats CRC(DataType_HexString, "48-65-6C-6C-6F").CalculateCRC16.ReturnLong() CRC(DataType_HexString, "48:65:6C:6C:6F").CalculateCRC16.ReturnLong() CRC(DataType_HexString, "48656C6C6F").CalculateCRC16.ReturnLong() ' ========== Method 3: Text string ========== Dim Text As String Text = "Hello World" CRCValue = CRC(DataType_Text, Text).CalculateCRC16.ReturnLong() ``` *** ### CalculateCRC16 Calculates CRC16 (bit-by-bit calculation method) based on polynomial 0xA001 (CRC16-Modbus). **Note: You must call the `Data` method to set data first.** ```vb Public Function CalculateCRC16(Optional ByVal StartIndex As Long = 0, Optional ByVal Length As Long = -1) As cToolsCrc ``` **Parameters:** | Parameter | Type | Description | |-----------|------|-------------| | `StartIndex` | Long | Starting index (optional, defaults to 0) | | `Length` | Long | Data length (optional, defaults to -1 meaning calculate to end of array) | **Return Value:** Returns `cToolsCrc` instance, supporting method chaining. **Example:** ```vb Dim CRC As New cToolsCrc Dim CRCValue As Long ' ========== Byte array method ========== Dim Bytes() As Byte Bytes = StrConv("Hello World", vbFromUnicode) CRCValue = CRC(DataType_ByteArray, Bytes).CalculateCRC16.ReturnLong() Debug.Print "CRC16: " & Hex$(CRCValue) ' Output: CRC16: 3AFA ' ========== HEX string method ========== CRCValue = CRC(DataType_HexString, "48 65 6C 6C 6F 20 57 6F 72 6C 64").CalculateCRC16.ReturnLong() ' ========== Text string method ========== CRCValue = CRC(DataType_Text, "Hello World").CalculateCRC16.ReturnLong() ``` **Calculate Partial Data:** ```vb ' Only calculate first 5 bytes (Hello) Dim CRCValue As Long CRCValue = CRC(DataType_Text, "Hello World").CalculateCRC16(0, 5).ReturnLong() ``` *** ### ReturnLong Returns the CRC value as Long type. ```vb Public Function ReturnLong(Optional ByVal CRCTypeValue As CRCType = CRC16) As Long ``` **Parameters:** | Parameter | Type | Description | |-----------|------|-------------| | `CRCTypeValue` | CRCType | CRC type (optional, defaults to CRC16) | **Description:** * CRC16 returns unsigned 16-bit value (0-65535) * CRC32 returns Long type (negative if greater than 2147483647) * For unsigned 32-bit results, use `ReturnCurrency` or `ReturnHex` **Example:** ```vb ' CRC16 Dim CRC16Value As Long CRC16Value = CRC.CalculateCRC16(Data).ReturnLong(CRC16) ' CRC32 Dim CRC32Value As Long CRC32Value = CRC.CalculateCRC32(Data).ReturnLong(CRC32) ``` *** ### ReturnCurrency Returns the CRC32 value as Currency type (unsigned 32-bit). ```vb Public Function ReturnCurrency(Optional ByVal CRCTypeValue As CRCType = CRC16) As Currency ``` **Parameters:** | Parameter | Type | Description | |-----------|------|-------------| | `CRCTypeValue` | CRCType | CRC type (optional, defaults to CRC16) | **Description:** * CRC32 returns positive number from 0 to 4294967295 * CRC16 returns 0 to 65535 **Example:** ```vb Dim CRC32Value As Currency CRC32Value = CRC.CalculateCRC32(Data).ReturnCurrency(CRC32) Debug.Print "CRC32: " & CRC32Value ' Output: CRC32: 1243062890 ``` *** ### ReturnBytes Returns the CRC value as a byte array (high byte first). ```vb Public Function ReturnBytes(Optional ByVal CRCTypeValue As CRCType = CRC16) As Byte() ``` **Parameters:** | Parameter | Type | Description | |-----------|------|-------------| | `CRCTypeValue` | CRCType | CRC type (optional, defaults to CRC16) | **Return Value:** * CRC16 returns 2-byte array (high byte first) * CRC32 returns 4-byte array (high byte first) **Example:** ```vb Dim Result() As Byte Result = CRC.CalculateCRC16(Data).ReturnBytes() ' Result(0) = High byte ' Result(1) = Low byte Debug.Print "Bytes: " & Hex$(Result(0)) & " " & Hex$(Result(1)) ``` *** ### ReturnHex Returns the CRC value as a hexadecimal string (uppercase). ```vb Public Function ReturnHex(Optional ByVal CRCTypeValue As CRCType = CRC16) As String ``` **Parameters:** | Parameter | Type | Description | |-----------|------|-------------| | `CRCTypeValue` | CRCType | CRC type (optional, defaults to CRC16) | **Return Value:** * CRC16 returns 4-character uppercase string (e.g., "B001") * CRC32 returns 8-character uppercase string (e.g., "A1B2C3D4") **Example:** ```vb Dim HexValue As String HexValue = CRC.CalculateCRC16(Data).ReturnHex() Debug.Print "CRC16: " & HexValue ' Output: CRC16: 3AFA ' CRC32 Dim CRC32Hex As String CRC32Hex = CRC.CalculateCRC32(Data).ReturnHex(CRC32) Debug.Print "CRC32: " & CRC32Hex ' Output: CRC32: 4A17B156 ``` *** ### ReturnHexString Returns a hexadecimal string with separators (suitable for display). ```vb Public Function ReturnHexString(Optional ByVal CRCTypeValue As CRCType = CRC16, Optional ByVal Separator As String = " ") As String ``` **Parameters:** | Parameter | Type | Description | |-----------|------|-------------| | `CRCTypeValue` | CRCType | CRC type (optional, defaults to CRC16) | | `Separator` | String | Separator character (optional, defaults to space) | **Return Value:** * CRC16 e.g., "B0 01" * CRC32 e.g., "A1 B2 C3 D4" **Example:** ```vb Dim HexStr As String ' Default space separator HexStr = CRC.CalculateCRC16(Data).ReturnHexString() Debug.Print HexStr ' Output: 3A FA ' Custom separator HexStr = CRC.CalculateCRC16(Data).ReturnHexString(CRC16, "-") Debug.Print HexStr ' Output: 3A-FA ' CRC32 HexStr = CRC.CalculateCRC32(Data).ReturnHexString(CRC32, ":") Debug.Print HexStr ' Output: 4A:17:B1:56 ``` *** ## Complete Example ```vb Private Sub CRCDemo() Dim CRC As New cToolsCrc Dim Data() As Byte Dim CRCValue As Long Dim HexResult As String ' ========== Method 1: Byte array method ========== Data = StrConv("Hello World", vbFromUnicode) ' Return Long CRCValue = CRC(DataType_ByteArray, Data).CalculateCRC16.ReturnLong() Debug.Print "CRC16 (Long): " & CRCValue ' Return Hex string HexResult = CRC(DataType_ByteArray, Data).CalculateCRC16.ReturnHex() Debug.Print "CRC16 (Hex): " & HexResult ' Return Hex with separators HexResult = CRC(DataType_ByteArray, Data).CalculateCRC16.ReturnHexString(CRC16, "-") Debug.Print "CRC16 (Formatted): " & HexResult ' ========== Method 2: HEX string method ========== ' Use HEX string (automatically handles spaces) HexResult = CRC(DataType_HexString, "48 65 6C 6C 6F 20 57 6F 72 6C 64").CalculateCRC16.ReturnHex() Debug.Print "CRC16 from HEX: " & HexResult ' Use HEX without spaces HexResult = CRC(DataType_HexString, "48656C6C6F20576F726C64").CalculateCRC16.ReturnHex() Debug.Print "CRC16 from HEX (no space): " & HexResult ' Use dash separator HexResult = CRC(DataType_HexString, "48-65-6C-6C-6F-20-57-6F-72-6C-64").CalculateCRC16.ReturnHex() Debug.Print "CRC16 from HEX (dash): " & HexResult ' ========== Method 3: Text string method ========== ' Use text directly (automatically converted to byte array) HexResult = CRC(DataType_Text, "Hello World").CalculateCRC16.ReturnHex() Debug.Print "CRC16 from Text: " & HexResult ' ========== Method 4: Method chaining (default member syntax) ========== ' Most concise usage: CRC(DataType, Content).Calculate.Return Debug.Print CRC(DataType_Text, "Test").CalculateCRC16.ReturnHex() ' ========== Partial data calculation example ========== ' Only calculate first 5 bytes Dim PartialCRC As Long PartialCRC = CRC(DataType_Text, "Hello World").CalculateCRC16(0, 5).ReturnLong() Debug.Print "CRC16 of 'Hello': " & Hex$(PartialCRC) ' Calculate from 6th byte PartialCRC = CRC(DataType_Text, "Hello World").CalculateCRC16(6).ReturnLong() Debug.Print "CRC16 of 'World': " & Hex$(PartialCRC) ' ========== Practical example: Calculate CRC for Modbus RTU frame ========== ' Modbus RTU request frame: 01 03 00 00 00 0A Dim ModbusFrame As String Dim ModbusCRC As String ModbusFrame = "01 03 00 00 00 0A" ModbusCRC = CRC(DataType_HexString, ModbusFrame).CalculateCRC16.ReturnHexString(CRC16, " ") Debug.Print "Modbus CRC: " & ModbusCRC ' Output: Modbus CRC: C5 CD ' Complete Modbus frame Debug.Print "Complete Frame: " & ModbusFrame & " " & ModbusCRC End Sub ``` *** ## Technical Specifications ### CRC16 Parameters | Parameter | Value | |-----------|-------| | Polynomial | 0xA001 (CRC16-Modbus) | | Initial Value | 0xFFFF | | Input Reflected | Yes | | Output Reflected | Yes | | Final XOR | 0x0000 | ### CRC32 Parameters | Parameter | Value | |-----------|-------| | Polynomial | 0xEDB88320 (IEEE 802.3) | | Initial Value | 0xFFFFFFFF | | Input Reflected | Yes | | Output Reflected | Yes | | Final XOR | 0xFFFFFFFF | ### Notes 1. **Data Type:** CRC32 calculation uses `Currency` type to avoid VB6's Long type sign bit issues (supports unsigned 32-bit) 2. **Byte Order:** All methods returning byte arrays use big-endian (high byte first) 3. **Thread Safety:** Each CRC calculation instance is independent and can be used in multi-threaded environments (ensure VB6 thread safety) 4. **Performance:** Table-Driven method is about 8x faster than bit-by-bit calculation, suitable for large data processing 5. **Default Member:** The `Data` method is the default member of the class and can be called without the method name, e.g., `CRC(DataType_Text, "Hello")` is equivalent to `CRC.Data(DataType_Text, "Hello")` 6. **HEX String:** `DataType_HexString` type automatically removes common separators like spaces, dashes, colons, supporting multiple formats --- --- url: /en/vbman/tools/datetime.md --- # Tools - Date and Time Utilities ## cToolsDateTime - Date and Time Tools ### Overview Provides Unix timestamp, ISO8601 format, and date formatting functionality. *** ## Timestamp Retrieval #### GetUnixTimestamp Gets the Unix timestamp for the current time (13-digit milliseconds). ```vb Public Function GetUnixTimestamp() As Currency ``` **Returns:** 13-digit Unix timestamp (millisecond-level). **Example:** ```vb Dim Ts As Currency Ts = VBMAN.ToolsDateTime.GetUnixTimestamp() Debug.Print Ts ' Output: 1715904000000 ``` #### GetIso8601Timestamp Gets the ISO8601 formatted timestamp (UTC time). ```vb Public Function GetIso8601Timestamp() As String ``` **Returns:** Format: `YYYY-MM-DDTHH:MM:SSZ` **Example:** ```vb Dim Iso As String Iso = VBMAN.ToolsDateTime.GetIso8601Timestamp() Debug.Print Iso ' Output: 2024-05-17T08:00:00Z ``` #### GetUtcTimestamp Gets the UTC timestamp (Beijing time converted to UTC). ```vb Public Function GetUtcTimestamp() As String ``` **Returns:** Format: `YYYY-MM-DDTHH:MM:SSZ` **Description:** * Calculated based on current system time minus 8 hours * Suitable for scenarios requiring UTC time **Example:** ```vb Dim Utc As String Utc = VBMAN.ToolsDateTime.GetUtcTimestamp() Debug.Print Utc ' Output: 2024-05-17T08:00:00Z ``` *** ## Date Checking and Formatting #### IsDatePast Checks if a date has already passed. ```vb Public Function IsDatePast(targetDate As Variant) As Boolean ``` **Parameters:** | Parameter | Type | Description | |-----------|------|-------------| | `targetDate` | Variant | Target date (string or date type) | **Returns:** * `True` - Target date has passed * `False` - Target date has not arrived * `"Invalid Date Format"` - Invalid date format **Example:** ```vb ' Check expiration If VBMAN.ToolsDateTime.IsDatePast("2023-12-31") Then Debug.Print "Expired" End If ' Check license If VBMAN.ToolsDateTime.IsDatePast(LicenseExpiryDate) Then MsgBox "License has expired, please renew" End If ``` #### FormatDateTime Formats a date/time to the specified format. ```vb Public Function FormatDateTime(Optional ByVal strFormat As String = "yyyy-mm-dd hh:nn:ss", Optional ByVal varDate As Variant) As String ``` **Parameters:** | Parameter | Type | Description | |-----------|------|-------------| | `strFormat` | String | Format string (default "yyyy-mm-dd hh:nn:ss") | | `varDate` | Variant | Date to format, uses current time if omitted | **Common Formats:** | Format | Output Example | |--------|----------------| | `yyyy-mm-dd hh:nn:ss` | 2024-05-17 14:30:00 | | `yyyy年mm月dd日` | 2024年05月17日 | | `dd/mm/yyyy` | 17/05/2024 | | `hh:nn:ss AM/PM` | 02:30:00 PM | | `yyyy-mm-dd` | 2024-05-17 | **Example:** ```vb ' Current time Debug.Print VBMAN.ToolsDateTime.FormatDateTime() ' 2024-05-17 14:30:00 ' Specific date Debug.Print VBMAN.ToolsDateTime.FormatDateTime("yyyy年mm月dd日", "2024-5-17") ' Output: 2024年05月17日 ' Format current time Debug.Print VBMAN.ToolsDateTime.FormatDateTime("Today is yyyy年m月d日") ' Output: Today is 2024年5月17日 ``` *** ## cTimeUse - Execution Time Measurement Tool ### Overview Simple code execution time measurement tool, based on GetTickCount API. ### Methods #### Start Starts the timer. ```vb Public Sub Start() ``` **Description:** * Records current timestamp as start time * Call before the code you want to measure **Example:** ```vb ' Start timing VBMAN.TimeUse.Start() ' Perform some operations For i = 1 To 1000000 ' Some calculation Next i ' Show elapsed time Debug.Print VBMAN.TimeUse.Show() ``` #### Show Displays the elapsed time. ```vb Public Function Show(Optional Txt As String = "耗时：{*} 毫秒") As Variant ``` **Parameters:** | Parameter | Type | Description | |-----------|------|-------------| | `Txt` | String | Output format, `*` will be replaced with elapsed milliseconds | **Returns:** Formatted string. **Example:** ```vb ' Start timing VBMAN.TimeUse.Start() ' Perform some operations For i = 1 To 1000000 ' Some calculation Next i ' Show elapsed time Debug.Print VBMAN.TimeUse.Show() ' Output: Elapsed: 50 milliseconds ' Custom format Debug.Print VBMAN.TimeUse.Show("Operation completed, took {*} ms") ' Output: Operation completed, took 50 ms Debug.Print VBMAN.TimeUse.Show("Time: {*}ms") ' Output: Time: 50ms ``` ### Complete Example ```vb Private Sub PerformanceTest() ' Test loop performance VBMAN.TimeUse.Start() Dim i As Long Dim Sum As Double For i = 1 To 1000000 Sum = Sum + i Next i Debug.Print "Sum result: " & Sum Debug.Print VBMAN.TimeUse.Show("1 million loop iterations took {*} milliseconds") ' Test string concatenation VBMAN.TimeUse.Start() Dim str As String For i = 1 To 10000 str = str & "x" Next i Debug.Print VBMAN.TimeUse.Show("String concatenation took {*} milliseconds") ' Test array operations VBMAN.TimeUse.Start() Dim Arr(1 To 10000) As String For i = 1 To 10000 Arr(i) = "Item" & i Next i Debug.Print VBMAN.TimeUse.Show("Array operations took {*} milliseconds") End Sub ``` *** ## cTimer / cTimers - Timer Classes ### Overview Provides high-precision timer functionality based on Windows API. * `cTimer` - Single timer * `cTimers` - Timer collection, supports multiple timers ### cTimer Properties | Property | Type | Description | |----------|------|-------------| | `Interval` | Long | Interval time (milliseconds) | | `Enabled` | Boolean | Whether enabled | | `Tag` | Variant | User-defined data | ### cTimer Methods #### EnableTimer Enables the timer and sets the interval. ```vb Sub EnableTimer(mInterval As Long) ``` #### Enable / Disable Enables/disables the timer. ```vb Sub Enable() Sub Disable() ``` #### Reset Resets the timer (restarts). ```vb Sub Reset() ``` ### cTimer Usage ```vb Private WithEvents Tmr As cTimer Private Sub Form_Load() Set Tmr = New cTimer Tmr.Interval = 1000 ' 1 second Tmr.Enabled = True End Sub Private Sub Tmr_Timer() Debug.Print "Triggered once per second" End Sub Private Sub Form_Unload(Cancel As Integer) Tmr.Enabled = False Set Tmr = Nothing End Sub ``` ### cTimers Usage (Multiple Timers) ```vb Private WithEvents Timers As cTimers Private Sub Form_Load() Set Timers = New cTimers ' Add two timers Timers.Add Timers.Add ' Configure first timer Timers(1).Interval = 1000 Timers(1).Enabled = True ' Configure second timer Timers(2).Interval = 5000 Timers(2).Enabled = True End Sub Private Sub Timers_Timer(ByVal Index As Integer) Debug.Print "Timer " & Index & " triggered" Select Case Index Case 1 Debug.Print "Every-second task" Case 2 Debug.Print "Every-5-seconds task" End Select End Sub ``` ### Properties | Property | Description | |----------|-------------| | `Interval` | Interval time (milliseconds) | | `Enabled` | Whether enabled | | `Tag` | User-defined data | | `Index` | Index in collection (for cTimers) | *** ## Complete Example ```vb Private Sub DateTimeDemo() ' ===== Timestamps ===== ' Get Unix timestamp Dim UnixTs As Currency UnixTs = VBMAN.ToolsDateTime.GetUnixTimestamp() Debug.Print "Unix timestamp: " & UnixTs ' Get ISO8601 timestamp Dim IsoTime As String IsoTime = VBMAN.ToolsDateTime.GetIso8601Timestamp() Debug.Print "ISO8601: " & IsoTime ' ===== Date Formatting ===== ' Various formats Debug.Print VBMAN.ToolsDateTime.FormatDateTime() Debug.Print VBMAN.ToolsDateTime.FormatDateTime("yyyy年mm月dd日") Debug.Print VBMAN.ToolsDateTime.FormatDateTime("hh:nn:ss") ' ===== Date Checking ===== ' Check expiration Dim ExpiryDate As String ExpiryDate = "2024-12-31" If VBMAN.ToolsDateTime.IsDatePast(ExpiryDate) Then Debug.Print "Expired" Else Debug.Print "Not expired" End If ' ===== Performance Testing ===== VBMAN.TimeUse.Start() ' Simulate time-consuming operation Dim i As Long For i = 1 To 100000 DoEvents Next i Debug.Print VBMAN.TimeUse.Show("Operation completed, took {*} milliseconds") End Sub ``` *** ## Use Cases | Scenario | Method to Use | |----------|---------------| | **API Requests** | GetUnixTimestamp() / GetIso8601Timestamp() | | **Logging** | FormatDateTime() | | **License Checking** | IsDatePast() | | **Performance Testing** | TimeUse.Start() + TimeUse.Show() | | **Scheduled Tasks** | cTimer / cTimers | | **Countdown** | GetUnixTimestamp() comparison | --- --- url: /en/vbman/tools/dic.md --- # Tools - Dictionary Utilities ## cToolsDic - Dictionary Operations ### Overview Provides extended operations for Dictionary objects, including form encoding conversion, nested dictionary operations, dictionary merging, deep copy, etc. *** ## Form URL-Encoded Conversion #### ToWwwFormUrlencoded Converts a dictionary to `application/x-www-form-urlencoded` format string. ```vb Public Function ToWwwFormUrlencoded(Dic As Dictionary) As String ``` **Parameters:** | Parameter | Type | Description | | --------- | ---------- | ------------------------- | | `Dic` | Dictionary | The dictionary to convert | **Returns:** URL-encoded format string, such as `key1=value1&key2=value2`. **Description:** * Simple implementation, directly concatenates key-value pairs * Currently does not support array-type values **Example:** ```vb Dim Dic As New Dictionary Dic.Add "name", "John" Dic.Add "age", "25" Dim FormData As String FormData = VBMAN.ToolsDic.ToWwwFormUrlencoded(Dic) Debug.Print FormData ' Output: name=John&age=25 ``` #### FromWwwFormUrlencoded Parses `application/x-www-form-urlencoded` format string into a dictionary. ```vb Public Function FromWwwFormUrlencoded(Content As String, Dic As Dictionary) As Boolean ``` **Parameters:** | Parameter | Type | Description | | --------- | ---------- | ----------------------------------- | | `Content` | String | URL-encoded format string | | `Dic` | Dictionary | Dictionary to store results (ByRef) | **Returns:** * `True` - Parsing successful **Example:** ```vb Dim Dic As New Dictionary Dim Success As Boolean Success = VBMAN.ToolsDic.FromWwwFormUrlencoded("name=John&age=25", Dic) Debug.Print Dic("name") ' Output: John Debug.Print Dic("age") ' Output: 25 ``` *** ## Nested Dictionary Operations #### TowLevelDicAssign Two-level nested dictionary assignment helper method. ```vb Public Sub TowLevelDicAssign(Dic As Dictionary, Lv1Name As String, Lv2Name As String, Value As Variant) ``` **Description:** Automatically creates the first-level dictionary (if it doesn't exist), then assigns the value in the second-level dictionary. **Parameters:** | Parameter | Type | Description | | --------- | ---------- | --------------------- | | `Dic` | Dictionary | Target dictionary | | `Lv1Name` | String | First-level key name | | `Lv2Name` | String | Second-level key name | | `Value` | Variant | Value to assign | **Example:** ```vb Dim Dic As New Dictionary ' Automatically create "user" sub-dictionary and set "name" value VBMAN.ToolsDic.TowLevelDicAssign Dic, "user", "name", "John" VBMAN.ToolsDic.TowLevelDicAssign Dic, "user", "age", 25 ' Result: Dic("user")("name") = "John" ' Dic("user")("age") = 25 Debug.Print Dic("user")("name") ' Output: John Debug.Print Dic("user")("age") ' Output: 25 ' Can also operate on deeper dictionaries VBMAN.ToolsDic.TowLevelDicAssign Dic, "settings", "theme", "dark" VBMAN.ToolsDic.TowLevelDicAssign Dic, "settings", "lang", "zh-CN" Debug.Print Dic("settings")("theme") ' Output: dark ``` *** ## Dictionary Merging #### OverWrite Merges source dictionary into target dictionary. ```vb Public Sub OverWrite(DistDic As Dictionary, srcDic As Dictionary, Optional OnlyKey As Boolean = True) ``` **Parameters:** | Parameter | Type | Description | | --------- | ---------- | ------------------------------------------- | | `DistDic` | Dictionary | Target dictionary | | `srcDic` | Dictionary | Source dictionary | | `OnlyKey` | Boolean | Only overwrite existing keys (default True) | **Description:** * Supports recursive merging of nested dictionaries * Object types use recursive merging * Non-object types are directly assigned **Example:** ```vb Dim Target As New Dictionary Dim Source As New Dictionary Target.Add "a", "old_a" Target.Add "b", "old_b" Source.Add "a", "new_a" Source.Add "c", "new_c" ' OnlyKey=True: Only overwrite existing keys (a) VBMAN.ToolsDic.OverWrite Target, Source, True ' Result: Target("a") = "new_a" ' Target("b") = "old_b" ' Target("c") = does not exist ' OnlyKey=False: Overwrite all and add new keys Dim Target2 As New Dictionary Target2.Add "a", "old_a" Target2.Add "b", "old_b" VBMAN.ToolsDic.OverWrite Target2, Source, False ' Result: Target2("a") = "new_a" ' Target2("b") = "old_b" ' Target2("c") = "new_c" ' Nested dictionary merge example Dim NestedTarget As New Dictionary Dim NestedSource As New Dictionary Dim UserDic As New Dictionary Dim SettingsDic As New Dictionary UserDic.Add "name", "John" UserDic.Add "age", 20 NestedTarget.Add "user", UserDic SettingsDic.Add "theme", "light" NestedSource.Add "user", SettingsDic VBMAN.ToolsDic.OverWrite NestedTarget, NestedSource, False ' NestedTarget("user") contains name, age, theme ``` *** ## Dictionary Copy #### DeepCopy Deep copies a dictionary object. ```vb Public Function DeepCopy(srcDic As Dictionary) As Dictionary ``` **Parameters:** | Parameter | Type | Description | | --------- | ---------- | ----------------- | | `srcDic` | Dictionary | Source dictionary | **Returns:** A new dictionary object containing all key-value pairs from the source dictionary. **Description:** * Currently only implements single-level copy (first-level key-value pairs) * Object types use Set assignment * Non-object types use Let assignment * TODO: Need to change to recursive implementation for deep object assignment **Example:** ```vb Dim Original As New Dictionary Original.Add "name", "John" Original.Add "age", 25 ' Create deep copy Dim Copy As Dictionary Set Copy = VBMAN.ToolsDic.DeepCopy(Original) ' Modifying the copy does not affect the original Copy("name") = "Jane" Debug.Print Original("name") ' Output: John Debug.Print Copy("name") ' Output: Jane ' Note: For nested dictionaries, currently still shallow copy Dim Nested As New Dictionary Dim Inner As New Dictionary Inner.Add "key", "value" Nested.Add "inner", Inner Dim NestedCopy As Dictionary Set NestedCopy = VBMAN.ToolsDic.DeepCopy(Nested) ' Modifying nested dictionary affects original (because it's a reference) NestedCopy("inner")("key") = "new_value" Debug.Print Nested("inner")("key") ' Output: new_value ``` *** ## Complete Example ```vb Private Sub DictionaryDemo() ' ===== Form URL-Encoded Operations ===== Dim Params As New Dictionary Params.Add "username", "admin" Params.Add "password", "123456" Params.Add "remember", "true" ' Encode to Form format Dim FormData As String FormData = VBMAN.ToolsDic.ToWwwFormUrlencoded(Params) Debug.Print "Form data: " & FormData ' Decode back to dictionary Dim Parsed As New Dictionary VBMAN.ToolsDic.FromWwwFormUrlencoded FormData, Parsed Debug.Print "Username: " & Parsed("username") ' ===== Nested Dictionary Operations ===== Dim Config As New Dictionary ' Use TowLevelDicAssign to quickly create nested structure VBMAN.ToolsDic.TowLevelDicAssign Config, "database", "host", "localhost" VBMAN.ToolsDic.TowLevelDicAssign Config, "database", "port", 3306 VBMAN.ToolsDic.TowLevelDicAssign Config, "database", "name", "mydb" VBMAN.ToolsDic.TowLevelDicAssign Config, "cache", "enabled", True VBMAN.ToolsDic.TowLevelDicAssign Config, "cache", "ttl", 3600 Debug.Print "Database host: " & Config("database")("host") Debug.Print "Cache TTL: " & Config("cache")("ttl") ' ===== Dictionary Merging ===== Dim Defaults As New Dictionary Defaults.Add "theme", "light" Defaults.Add "lang", "en" Defaults.Add "notifications", True Dim UserSettings As New Dictionary UserSettings.Add "theme", "dark" ' Merge: User settings override defaults VBMAN.ToolsDic.OverWrite Defaults, UserSettings, False Debug.Print "Theme: " & Defaults("theme") ' dark (user setting) Debug.Print "Language: " & Defaults("lang") ' en (default) Debug.Print "Notifications: " & Defaults("notifications") ' True (default) ' ===== Deep Copy ===== Dim Original As New Dictionary Original.Add "key1", "value1" Original.Add "key2", 12345 Dim Cloned As Dictionary Set Cloned = VBMAN.ToolsDic.DeepCopy(Original) ' Verify it's an independent copy Cloned("key1") = "modified" Debug.Print "Original: " & Original("key1") ' value1 Debug.Print "Cloned: " & Cloned("key1") ' modified End Sub ``` *** ## Method Comparison Table | Method | Purpose | Complexity | | ----------------------- | --------------------------- | ---------- | | `ToWwwFormUrlencoded` | Dictionary to query string | O(n) | | `FromWwwFormUrlencoded` | Query string to dictionary | O(n) | | `TowLevelDicAssign` | Two-level nested assignment | O(1) | | `OverWrite` | Dictionary merging | O(n) | | `DeepCopy` | Dictionary deep copy | O(n) | --- --- url: /en/vbman/tools/fso.md --- # Tools - File System Utilities > **Detailed Documentation:** Each class has its own detailed documentation with complete member descriptions and example code: > > * [cToolsFso.md](./fso/cToolsFso.md) - File System Tools Class > * [cFileIO.md](./fso/cFileIO.md) - API File Operations Class > * [cFileEx.md](./fso/cFileEx.md) - VB Native File Operations Class > * [cToolsStream.md](./fso/cToolsStream.md) - ADO Stream File Operations Class > * [ToolsFso.md](./fso/ToolsFso.md) - FSO Module *** ## cToolsFso - File System Tools ### Overview Provides file path processing, auto-completion, directory creation, and other functionality. ### Properties #### Inst Returns a Scripting.FileSystemObject instance. ```vb Public Inst As New Scripting.FileSystemObject ``` **Example:** ```vb ' Use Inst to access FSO functionality Dim Folder As Scripting.Folder Set Folder = VBMAN.ToolsFso.Inst.GetFolder("C:\\MyFolder") Dim File As Scripting.File Set File = VBMAN.ToolsFso.Inst.GetFile("C:\\file.txt") ``` *** ### Path Processing #### IsFullPath Checks if a path is a full path (contains drive letter). ```vb Public Function IsFullPath(Path As String) As Boolean ``` **Returns:** * `True` - Is relative path (does not contain `:\`) * `False` - Is absolute path **Example:** ```vb Debug.Print VBMAN.ToolsFso.IsFullPath("C:\\test.txt") ' False (is full path) Debug.Print VBMAN.ToolsFso.IsFullPath("test.txt") ' True (is relative path) ``` #### AutoCompleteFullPath Auto-completes to full path (relative path to absolute path). ```vb Public Function AutoCompleteFullPath(Path As String, Optional IsFile As Boolean) As String ``` **Parameters:** | Parameter | Type | Description | |-----------|------|-------------| | `Path` | String | Source path | | `IsFile` | Boolean | Whether it's a file path | **Example:** ```vb Dim FullPath As String FullPath = VBMAN.ToolsFso.AutoCompleteFullPath("data\\config.ini") ' Result: C:\\MyApp\\data\\config.ini ``` #### ClearSpan Cleans up extra slashes in the path, unified to backslash. ```vb Public Function ClearSpan(Path As String, Optional IsFile As Boolean) As String ``` **Example:** ```vb Debug.Print VBMAN.ToolsFso.ClearSpan("C:\\\\temp\\\\file.txt") ' Output: C:\\temp\\file.txt Debug.Print VBMAN.ToolsFso.ClearSpan("C://temp//folder//", False) ' Output: C:\\temp\\folder\\ ``` *** ### Directory Operations #### AutoMakeDir Automatically creates a directory (if it doesn't exist). ```vb Public Function AutoMakeDir(ByVal Path As String, Optional IsFile As Boolean) As String ``` **Parameters:** | Parameter | Type | Description | |-----------|------|-------------| | `Path` | String | Path | | `IsFile` | Boolean | Whether it's a file path (if True, extracts directory part) | **Returns:** The created directory path. **Example:** ```vb ' Create directory VBMAN.ToolsFso.AutoMakeDir "C:\\MyApp\\Logs" ' If file path, automatically extracts directory part and creates VBMAN.ToolsFso.AutoMakeDir "C:\\MyApp\\Logs\\app.log", True ' Creates C:\\MyApp\\Logs directory ``` *** ### Application Path #### AppPath Gets the application path (automatically handles IDE and compiled path differences). ```vb Public Function AppPath(Optional ByVal Path As String) As String ``` **Description:** * IDE environment returns: `App.Path & "\..\dist\EXE\"` * Compiled returns: `App.Path & "\"` **Example:** ```vb ' IDE environment: C:\\MyProject\\..\\dist\\EXE\\ ' Compiled: C:\\Program Files\\MyApp\\ Dim ConfigPath As String ConfigPath = VBMAN.ToolsFso.AppPath("config.ini") Debug.Print ConfigPath ``` *** ### File Name Processing #### MakeNewFileFulPath Generates a new file full path (adds suffix). ```vb Public Function MakeNewFileFulPath(FileSrc As String, AppendFix As String, Optional JoinStr As String = "_") As String ``` **Parameters:** | Parameter | Type | Description | |-----------|------|-------------| | `FileSrc` | String | Source file path | | `AppendFix` | String | Suffix to add | | `JoinStr` | String | Join string (default "\_") | **Example:** ```vb Dim NewPath As String NewPath = VBMAN.ToolsFso.MakeNewFileFulPath("C:\\file.txt", "backup") ' Output: file_backup.txt NewPath = VBMAN.ToolsFso.MakeNewFileFulPath("C:\\data\\report.pdf", "2024", "-") ' Output: report-2024.pdf ``` *** ## cFileIO - Advanced File Operations (API Implementation) ### Overview Advanced file operations using Windows CreateFile API, supports large files (>2GB). ### Properties | Property | Description | |----------|-------------| | `IsOpen` | Whether file is open (Boolean, read-only) | | `FilePath` | Current file path (String, read-only) | | `LastError` | Last error message (String, read-only) | | `FileSize` | File size (Currency, in bytes, read-only) | | `BufferSize` | Current buffer byte count (Long, read-only) | ### File Open/Close #### OpenFile Opens a file, returns Me to support method chaining. ```vb Public Function OpenFile(ByVal FilePath As String, Optional ByVal AccessMode As String = "RW") As cFileIO ``` **Parameters:** | Parameter | Type | Description | |-----------|------|-------------| | `FilePath` | String | File path | | `AccessMode` | String | Access mode: "R"=read-only, "W"=write-only, "RW"=read-write (default) | **Example:** ```vb ' Open in read-only mode VBMAN.FileIO.OpenFile "C:\\data.txt", "R" ' Open in read-write mode VBMAN.FileIO.OpenFile "C:\\data.txt", "RW" ' Method chaining Dim Content As String Content = VBMAN.FileIO.OpenFile("C:\\data.txt").ReadData().ReturnText() ``` #### CloseFile Closes the file. ```vb Public Sub CloseFile() ``` **Example:** ```vb VBMAN.FileIO.CloseFile ``` *** ### Buffer Operations #### ClearBuffer Clears the internal buffer. ```vb Public Function ClearBuffer() As cFileIO ``` #### SetBuffer Fills the buffer with external byte array. ```vb Public Function SetBuffer(Data() As Byte) As cFileIO ``` **Example:** ```vb Dim Bytes() As Byte Bytes = StrConv("Hello", vbFromUnicode) VBMAN.FileIO.SetBuffer Bytes ``` #### AppendBuffer Appends bytes to the buffer. ```vb Public Function AppendBuffer(Data() As Byte) As cFileIO ``` **Example:** ```vb Dim Bytes1() As Byte, Bytes2() As Byte Bytes1 = StrConv("Hello", vbFromUnicode) Bytes2 = StrConv(" World", vbFromUnicode) VBMAN.FileIO.SetBuffer(Bytes1).AppendBuffer Bytes2 ``` #### SetBufferText Fills the buffer with string (default UTF-8). ```vb Public Function SetBufferText(ByVal Text As String, Optional ByVal CharSet As String = "UTF-8") As cFileIO ``` **Example:** ```vb VBMAN.FileIO.SetBufferText "Hello World", "UTF-8" ``` *** ### Data Reading #### ReadData Reads specified range of file into internal buffer. ```vb Public Function ReadData(Optional ByVal StartPos As Long = -1, Optional ByVal EndPos As Long = -1) As cFileIO ``` **Parameters:** | Parameter | Type | Description | |-----------|------|-------------| | `StartPos` | Long | Start position (0-based), -1 means from beginning | | `EndPos` | Long | End position (0-based), -1 means to end | **Example:** ```vb ' Read entire file VBMAN.FileIO.OpenFile("C:\\data.txt").ReadData ' Read specified range VBMAN.FileIO.OpenFile("C:\\data.txt").ReadData 0, 1023 ' Read first 1KB ' Method chaining to read and get text Dim Text As String Text = VBMAN.FileIO.OpenFile("C:\\data.txt").ReadData().ReturnText() ``` *** ### Data Return #### ReturnText Returns buffer content as text. ```vb Public Function ReturnText(Optional ByVal CharSet As String = "UTF-8") As String ``` **Example:** ```vb Dim Text As String VBMAN.FileIO.OpenFile("C:\\utf8.txt").ReadData() Text = VBMAN.FileIO.ReturnText("UTF-8") ``` #### ReturnBytes Returns byte array (copy). ```vb Public Function ReturnBytes() As Byte() ``` **Example:** ```vb Dim Bytes() As Byte VBMAN.FileIO.OpenFile("C:\\data.bin").ReadData() Bytes = VBMAN.FileIO.ReturnBytes() ``` #### ReturnBase64 Returns Base64-encoded string. ```vb Public Function ReturnBase64() As String ``` **Example:** ```vb Dim Base64 As String VBMAN.FileIO.OpenFile("C:\\image.png").ReadData() Base64 = VBMAN.FileIO.ReturnBase64() ``` *** ### Data Writing #### SaveData Writes internal buffer to file. ```vb Public Function SaveData(Optional ByVal FilePath As String, Optional ByVal IsAppend As Boolean = False) As cFileIO ``` **Parameters:** | Parameter | Type | Description | |-----------|------|-------------| | `FilePath` | String | Target path, uses currently opened file if empty | | `IsAppend` | Boolean | False=overwrite (default), True=append | **Example:** ```vb ' Overwrite VBMAN.FileIO.SetBufferText("Hello World").SaveData "C:\\output.txt" ' Append VBMAN.FileIO.SetBufferText("New Line").SaveData "C:\\log.txt", True ' Write to currently opened file VBMAN.FileIO.OpenFile("C:\\data.txt", "RW").SetBufferText("Content").SaveData ``` *** ### Complete Example ```vb Private Sub FileIODemo() ' Read text file Dim Content As String Content = VBMAN.FileIO.OpenFile("C:\\input.txt").ReadData().ReturnText() Debug.Print Content ' Read and convert Dim Base64 As String Base64 = VBMAN.FileIO.OpenFile("C:\\image.png").ReadData().ReturnBase64() ' Write file VBMAN.FileIO.SetBufferText("Hello World").SaveData "C:\\output.txt" ' Append content VBMAN.FileIO.SetBufferText("Line 1" & vbCrLf).SaveData "C:\\log.txt", True VBMAN.FileIO.SetBufferText("Line 2" & vbCrLf).SaveData "C:\\log.txt", True ' Copy file (chunked reading for large files) With VBMAN.FileIO .OpenFile "C:\\largefile.zip" Dim FileLen As Currency FileLen = .FileSize ' Read in 2MB chunks Dim Pos As Long For Pos = 0 To FileLen Step 2097152 .ReadData Pos, Pos + 2097151 .SaveData "C:\\copy.zip", True Next Pos End With End Sub ``` *** ## cFileEx - Advanced File Operations (Open Statement Implementation) ### Overview File operations using VB native Open statement, with good compatibility, interface consistent with `cFileIO`. ### Difference from cFileIO | Feature | cFileIO | cFileEx | |---------|---------|---------| | Implementation | CreateFile API | VB Open statement | | Large file support | >2GB | Limited by VB | | Compatibility | Requires Windows API | Native VB, better compatibility | | Performance | High | Moderate | ### Properties Same as `cFileIO`: * `IsOpen` - Whether file is open * `FilePath` - Current file path * `LastError` - Last error message * `FileSize` - File size * `BufferSize` - Current buffer byte count ### Methods Same as `cFileIO`, with additional support: #### SetBufferBase64 Fills the buffer with Base64 string. ```vb Public Function SetBufferBase64(ByVal Base64String As String) As cFileEx ``` **Example:** ```vb VBMAN.FileEx.SetBufferBase64 "SGVsbG8gV29ybGQ=" ``` #### SetBufferHex Fills the buffer with Hex string. ```vb Public Function SetBufferHex(ByVal HexString As String, Optional ByVal Separator As String = " ") As cFileEx ``` **Example:** ```vb VBMAN.FileEx.SetBufferHex "48 65 6C 6C 6F" VBMAN.FileEx.SetBufferHex "48656C6C6F", "" ' Without separator ``` #### SetBufferBinString Fills the buffer with binary string. ```vb Public Function SetBufferBinString(ByVal BinString As String, Optional ByVal Separator As String = " ") As cFileEx ``` **Example:** ```vb VBMAN.FileEx.SetBufferBinString "01001000 01100101 01101100 01101100 01101111" ``` #### ReturnHex Returns Hex-encoded string. ```vb Public Function ReturnHex(Optional ByVal Separator As String = " ") As String ``` **Example:** ```vb VBMAN.FileEx.OpenFile("C:\\data.bin").ReadData() Debug.Print VBMAN.FileEx.ReturnHex(" ") ' Output: 48 65 6C 6C 6F Debug.Print VBMAN.FileEx.ReturnHex("") ' Output: 48656C6C6F ``` #### ReturnBinString Returns binary string. ```vb Public Function ReturnBinString(Optional ByVal Separator As String = " ") As String ``` **Example:** ```vb Debug.Print VBMAN.FileEx.ReturnBinString(" ") ' Output: 01001000 01100101... ``` *** ## cToolsStream - Stream File Operations ### Overview File stream operations based on ADODB.Stream, supporting line-by-line reading/writing and multiple encodings. ### Properties | Property | Type | Description | |----------|------|-------------| | `Inst` | ADODB.Stream | Stream instance | | `LastError` | String | Last error message | | `UseLine` | Boolean | Whether line-by-line mode is enabled | | `LineData` | cCollection | Line data collection | | `LineNumber` | Long | Current line number | ### Methods #### UseLineMode Sets whether to enable line-by-line read/write mode (method chaining). ```vb Public Function UseLineMode(v As Boolean) As cToolsStream ``` **Example:** ```vb VBMAN.ToolsStream.UseLineMode(True) ``` #### LoadFileAsText Loads a text file. ```vb Public Function LoadFileAsText(ByVal FileName As String, Optional ByVal CharSet As String = "UTF-8") As String ``` **Example:** ```vb Dim Content As String Content = VBMAN.ToolsStream.LoadFileAsText("test.txt", "UTF-8") ``` #### SaveFileAsText Saves a text file. ```vb Public Function SaveFileAsText(ByVal FileName As String, Optional Data As Variant, Optional ByVal CharSet As String = "UTF-8") As Boolean ``` **Example:** ```vb ' Save data directly VBMAN.ToolsStream.SaveFileAsText "output.txt", "Hello World", "UTF-8" ' Use line mode to save VBMAN.ToolsStream.UseLineMode(True) VBMAN.ToolsStream.WriteLine "Line 1" VBMAN.ToolsStream.WriteLine "Line 2" VBMAN.ToolsStream.SaveFileAsText "output.txt", , "UTF-8" ``` #### LoadFileAsBinary Loads file as binary. ```vb Public Function LoadFileAsBinary(ByVal Path As String, OutData() As Byte) As Boolean ``` **Example:** ```vb Dim Data() As Byte VBMAN.ToolsStream.LoadFileAsBinary "image.png", Data ``` #### SaveFileAsBinary Saves file as binary. ```vb Public Function SaveFileAsBinary(ByVal Path As String, OutData() As Byte) As Boolean ``` **Example:** ```vb Dim Data() As Byte ' ... fill Data VBMAN.ToolsStream.SaveFileAsBinary "output.bin", Data ``` #### ReadLine Reads a line (requires line mode enabled). ```vb Public Function ReadLine(Optional ByVal Line As Long) As String ``` **Parameters:** | Parameter | Type | Description | |-----------|------|-------------| | `Line` | Long | Specify line number, 0 means current line | **Example:** ```vb ' Read file line by line With VBMAN.ToolsStream.UseLineMode(True) .LoadFileAsText "log.txt", "UTF-8" Dim Line As String Line = .ReadLine(1) ' Read line 1 Debug.Print Line Line = .ReadLine() ' Read next line (auto increment) Debug.Print Line End With ``` #### WriteLine Writes a line (requires line mode enabled). ```vb Public Function WriteLine(Text As String, Optional ByVal Line As Long) As Boolean ``` **Example:** ```vb ' Write file line by line With VBMAN.ToolsStream.UseLineMode(True) .WriteLine "First line content" .WriteLine "Second line content" .WriteLine "Third line content", 10 ' Write to line 10 .SaveFileAsText "output.txt", , "UTF-8" End With ``` *** ## Complete Example ```vb Private Sub FileOperationsDemo() ' ========== cToolsFso Examples ========== ' Create directory VBMAN.ToolsFso.AutoMakeDir "C:\\MyApp\\Logs" ' Get application path Dim AppPath As String AppPath = VBMAN.ToolsFso.AppPath("config.ini") ' Generate backup file name Dim BackupName As String BackupName = VBMAN.ToolsFso.MakeNewFileFulPath("report.pdf", "backup") ' ========== cFileIO Examples ========== ' Read large file Dim LargeFileContent As String With VBMAN.FileIO .OpenFile "C:\\largefile.bin" LargeFileContent = .ReadData().ReturnBase64() End With ' Write file VBMAN.FileIO.SetBufferText("Hello World").SaveData "C:\\test.txt" ' ========== cFileEx Examples ========== ' Hex operations VBMAN.FileEx.SetBufferHex "48 65 6C 6C 6F" VBMAN.FileEx.SaveData "C:\\hex_test.bin" ' ========== cToolsStream Examples ========== ' Process config file line by line With VBMAN.ToolsStream.UseLineMode(True) .LoadFileAsText "config.ini", "UTF-8" Dim i As Long For i = 1 To 10 Debug.Print "Line " & i & ": " & .ReadLine(i) Next i End With End Sub ``` --- --- url: /zh/vbman/tools/http.md --- # Tools - HTTP 工具类 ## cToolsHttp - HTTP 编码工具 ### 概述 提供 URL 编码/解码、HTTP 相关字符串处理、查询字符串构建、HTTP 方法映射等功能。 *** ## URL 编解码（GB2312） #### UrlEncode 对字符串进行 GB2312 URL 编码。 ```vb Public Function UrlEncode(ByRef strURL As String) As String ``` **说明：** * 使用 GB2312 编码 * 适合处理中文等传统编码场景 **示例：** ```vb Dim Encoded As String Encoded = VBMAN.ToolsHttp.UrlEncode("你好世界") Debug.Print Encoded ' 输出: %C4%E3%BA%C3%CA%C0%BD%E7 ``` #### UrlDecode 对 GB2312 URL 编码的字符串进行解码。 ```vb Public Function UrlDecode(ByVal url As String) As String ``` **示例：** ```vb Dim Decoded As String Decoded = VBMAN.ToolsHttp.UrlDecode("%C4%E3%BA%C3%CA%C0%BD%E7") Debug.Print Decoded ' 输出: 你好世界 ``` *** ## URL 编解码（UTF-8） #### UrlEncodeUtf8 对字符串进行 UTF-8 URL 编码（RFC3986 标准）。 ```vb Public Function UrlEncodeUtf8(ByVal szInput As Variant) As String ``` **说明：** * 遵循 RFC3986 标准 * 安全字符：`A-Z a-z 0-9 - _ . ~` * 其他字符进行百分号编码 * 支持多字节 UTF-8 字符 **示例：** ```vb Dim Encoded As String ' ASCII 字符 Encoded = VBMAN.ToolsHttp.UrlEncodeUtf8("Hello World!") Debug.Print Encoded ' 输出: Hello%20World%21 ' 中文字符 Encoded = VBMAN.ToolsHttp.UrlEncodeUtf8("你好世界") Debug.Print Encoded ' 输出: %E4%BD%A0%E5%A5%BD%E4%B8%96%E7%95%8C ' 特殊字符 Encoded = VBMAN.ToolsHttp.UrlEncodeUtf8("a/b+c=d&e") Debug.Print Encoded ' 输出: a%2Fb%2Bc%3Dd%26e ``` #### UrlDecodeUtf8 对 UTF-8 URL 编码的字符串进行解码。 ```vb Public Function UrlDecodeUtf8(ByVal url As String) As String ``` **示例：** ```vb Dim Decoded As String Decoded = VBMAN.ToolsHttp.UrlDecodeUtf8("Hello%20World%21") Debug.Print Decoded ' 输出: Hello World! Decoded = VBMAN.ToolsHttp.UrlDecodeUtf8("%E4%BD%A0%E5%A5%BD%E4%B8%96%E7%95%8C") Debug.Print Decoded ' 输出: 你好世界 ``` *** ## 查询字符串操作 #### AddToQueryString 将查询参数添加到 URL。 ```vb Public Function AddToQueryString(ByVal url As String, ByVal QS As String) As String ``` **说明：** * 自动判断 URL 是否已有查询参数 * 自动添加 `?` 或 `&` **示例：** ```vb Dim Url As String Url = VBMAN.ToolsHttp.AddToQueryString("http://api.example.com/user", "id=123") Debug.Print Url ' 输出: http://api.example.com/user?id=123 Url = VBMAN.ToolsHttp.AddToQueryString("http://api.example.com/user?id=123", "name=张三") Debug.Print Url ' 输出: http://api.example.com/user?id=123&name=张三 ``` #### MakeContent 将字典构建为查询字符串格式。 ```vb Public Function MakeContent(Dic As Dictionary, Optional IsUrlEncode As Boolean = True) As String ``` **参数：** | 参数名 | 类型 | 说明 | | ------------- | ---------- | ---------------------------------- | | `Dic` | Dictionary | 要转换的字典 | | `IsUrlEncode` | Boolean | 是否对值进行 URL 编码（默认 True） | **示例：** ```vb Dim Params As New Dictionary Params.Add "name", "张三" Params.Add "age", "25" Params.Add "city", "北京" Dim QueryString As String QueryString = VBMAN.ToolsHttp.MakeContent(Params) Debug.Print QueryString ' 输出: name=%E5%BC%A0%E4%B8%89&age=25&city=%E5%8C%97%E4%BA%AC ' 不编码 QueryString = VBMAN.ToolsHttp.MakeContent(Params, False) Debug.Print QueryString ' 输出: name=张三&age=25&city=北京 ``` #### ParseContent 解析查询字符串到字典。 ```vb Public Function ParseContent(Content As String, Obj As Dictionary, Optional IsUrlDecode As Boolean = True) As Boolean ``` **参数：** | 参数名 | 类型 | 说明 | | ------------- | ---------- | ------------------------------ | | `Content` | String | 查询字符串 | | `Obj` | Dictionary | 存储结果的字典 | | `IsUrlDecode` | Boolean | 是否进行 URL 解码（默认 True） | **示例：** ```vb Dim Params As New Dictionary Dim Success As Boolean Success = VBMAN.ToolsHttp.ParseContent("name=%E5%BC%A0%E4%B8%89&age=25", Params) Debug.Print Params("name") ' 输出: 张三 Debug.Print Params("age") ' 输出: 25 ``` #### ParseKeyValue 解析键值对格式的字符串到字典（如 HTTP Headers）。 ```vb Public Function ParseKeyValue(Content As String, Obj As Dictionary) As Boolean ``` **说明：** * 按行分割 * 每行按第一个 `:` 分割为键和值 * 适合解析 HTTP Headers **示例：** ```vb Dim Headers As New Dictionary Dim HeaderText As String HeaderText = "Content-Type: application/json" & vbCrLf & _ "Authorization: Bearer token123" & vbCrLf & _ "X-Custom-Header: value" VBMAN.ToolsHttp.ParseKeyValue HeaderText, Headers Debug.Print Headers("Content-Type") ' 输出: application/json Debug.Print Headers("Authorization") ' 输出: Bearer token123 ``` *** ## Form URL-Encoded 转换 #### ToWwwFormUrlencoded 将集合对象转换为 `application/x-www-form-urlencoded` 格式。 ```vb Public Function ToWwwFormUrlencoded(ByRef Obj As Object, Optional ByVal IsUrlEncode As Boolean = True) As String ``` **参数：** | 参数名 | 类型 | 说明 | | ------------- | ------- | ------------------------------------- | | `Obj` | Object | 集合对象（cCollection 或 Dictionary） | | `IsUrlEncode` | Boolean | 是否对值进行 URL 编码（默认 True） | **示例：** ```vb Dim Dic As New Dictionary Dic.Add "username", "admin" Dic.Add "password", "123456" Dim FormData As String FormData = VBMAN.ToolsHttp.ToWwwFormUrlencoded(Dic) Debug.Print FormData ' 输出: username=admin&password=123456 ``` #### FromWwwFormUrlencoded 将 `application/x-www-form-urlencoded` 格式解析到集合对象。 ```vb Public Function FromWwwFormUrlencoded(ByVal Content As String, ByRef Obj As Object, Optional ByVal IsUrlDecode As Boolean = True) As Boolean ``` **示例：** ```vb Dim Dic As New Dictionary Dim Success As Boolean Success = VBMAN.ToolsHttp.FromWwwFormUrlencoded("name=张三&age=25", Dic) Debug.Print Dic("name") ' 输出: 张三 Debug.Print Dic("age") ' 输出: 25 ``` *** ## HTTP 方法映射 #### MapMethod 将 HTTP 方法名映射为内部索引。 ```vb Public Function MapMethod(Name As String) As Long ``` **映射表：** | 方法名 | 索引 | | ------- | ---- | | ANY | 0 | | POST | 1 | | GET | 2 | | PUT | 3 | | DELETE | 4 | | OPTIONS | 5 | **示例：** ```vb Dim Index As Long Index = VBMAN.ToolsHttp.MapMethod("GET") Debug.Print Index ' 输出: 2 Index = VBMAN.ToolsHttp.MapMethod("POST") Debug.Print Index ' 输出: 1 ``` #### MapMethodName 将内部索引映射为 HTTP 方法名。 ```vb Public Function MapMethodName(Index As Long) As String ``` **示例：** ```vb Dim MethodName As String MethodName = VBMAN.ToolsHttp.MapMethodName(2) Debug.Print MethodName ' 输出: GET ``` *** ## cHttpCrossDomain - HTTP 跨域配置 ### 概述 用于配置 HTTP 服务器的 CORS（跨域资源共享）响应头。 ### 属性 | 属性 | 类型 | 默认值 | 说明 | | ------------------ | ------- | -------- | ------------------------ | | `Enable` | Boolean | False | 是否启用跨域支持 | | `AllowOrigin` | String | "\*" | 允许的源 | | `AllowMethods` | String | "\*" | 允许的方法 | | `AllowHeaders` | String | "\*" | 允许的请求头 | | `AllowCredentials` | Boolean | True | 是否允许携带凭证 | | `MaxAge` | Long | 86400000 | 预检请求缓存时间（毫秒） | ### 用法 ```vb ' 启用跨域 VBMAN.HttpCrossDomain.Enable = True ' 自定义配置 With VBMAN.HttpCrossDomain .Enable = True .AllowOrigin = "https://example.com" .AllowMethods = "GET, POST, PUT, DELETE" .AllowHeaders = "Content-Type, Authorization" .AllowCredentials = True End With ``` ### 在 HttpServer 中使用 ```vb Private Sub Server_OnBeforeRequest(Request As cHttpServerRequest) ' 自动添加跨域头 VBMAN.HttpCrossDomain.AddTo Request.Response.Headers End Sub ``` *** ## 完整示例 ```vb Private Sub HttpDemo() ' URL 编码 Dim Url As String Url = "http://api.example.com/search?q=" & _ VBMAN.ToolsHttp.UrlEncodeUtf8("VB6 编程") Debug.Print Url ' 构建查询参数 Dim Params As New Dictionary Params.Add "page", "1" Params.Add "size", "20" Params.Add "keyword", "VB6" Dim QueryString As String QueryString = VBMAN.ToolsHttp.MakeContent(Params) Url = "http://api.example.com/list?" & QueryString Debug.Print Url ' 解析查询字符串 Dim Parsed As New Dictionary VBMAN.ToolsHttp.ParseContent QueryString, Parsed Debug.Print "页码: " & Parsed("page") Debug.Print "每页: " & Parsed("size") ' 解析 HTTP Headers Dim Headers As New Dictionary Dim HeaderText As String HeaderText = "Content-Type: application/json" & vbCrLf & _ "Authorization: Bearer xxx" VBMAN.ToolsHttp.ParseKeyValue HeaderText, Headers End Sub ``` --- --- url: /en/vbman/tools/http.md --- # Tools - HTTP Utility Class ## cToolsHttp - HTTP Encoding Tools ### Overview Provides URL encoding/decoding, HTTP-related string processing, query string construction, HTTP method mapping, and other functionality. *** ## URL Encoding/Decoding (GB2312) #### UrlEncode Encodes a string using GB2312 URL encoding. ```vb Public Function UrlEncode(ByRef strURL As String) As String ``` **Description:** * Uses GB2312 encoding * Suitable for traditional encoding scenarios with Chinese characters **Example:** ```vb Dim Encoded As String Encoded = VBMAN.ToolsHttp.UrlEncode("你好世界") Debug.Print Encoded ' Output: %C4%E3%BA%C3%CA%C0%BD%E7 ``` #### UrlDecode Decodes a GB2312 URL-encoded string. ```vb Public Function UrlDecode(ByVal url As String) As String ``` **Example:** ```vb Dim Decoded As String Decoded = VBMAN.ToolsHttp.UrlDecode("%C4%E3%BA%C3%CA%C0%BD%E7") Debug.Print Decoded ' Output: 你好世界 ``` *** ## URL Encoding/Decoding (UTF-8) #### UrlEncodeUtf8 Encodes a string using UTF-8 URL encoding (RFC3986 standard). ```vb Public Function UrlEncodeUtf8(ByVal szInput As Variant) As String ``` **Description:** * Follows RFC3986 standard * Safe characters: `A-Z a-z 0-9 - _ . ~` * Other characters are percent-encoded * Supports multi-byte UTF-8 characters **Example:** ```vb Dim Encoded As String ' ASCII characters Encoded = VBMAN.ToolsHttp.UrlEncodeUtf8("Hello World!") Debug.Print Encoded ' Output: Hello%20World%21 ' Chinese characters Encoded = VBMAN.ToolsHttp.UrlEncodeUtf8("你好世界") Debug.Print Encoded ' Output: %E4%BD%A0%E5%A5%BD%E4%B8%96%E7%95%8C ' Special characters Encoded = VBMAN.ToolsHttp.UrlEncodeUtf8("a/b+c=d&e") Debug.Print Encoded ' Output: a%2Fb%2Bc%3Dd%26e ``` #### UrlDecodeUtf8 Decodes a UTF-8 URL-encoded string. ```vb Public Function UrlDecodeUtf8(ByVal url As String) As String ``` **Example:** ```vb Dim Decoded As String Decoded = VBMAN.ToolsHttp.UrlDecodeUtf8("Hello%20World%21") Debug.Print Decoded ' Output: Hello World! Decoded = VBMAN.ToolsHttp.UrlDecodeUtf8("%E4%BD%A0%E5%A5%BD%E4%B8%96%E7%95%8C") Debug.Print Decoded ' Output: 你好世界 ``` *** ## Query String Operations #### AddToQueryString Adds query parameters to a URL. ```vb Public Function AddToQueryString(ByVal url As String, ByVal QS As String) As String ``` **Description:** * Automatically determines if URL already has query parameters * Automatically adds `?` or `&` **Example:** ```vb Dim Url As String Url = VBMAN.ToolsHttp.AddToQueryString("http://api.example.com/user", "id=123") Debug.Print Url ' Output: http://api.example.com/user?id=123 Url = VBMAN.ToolsHttp.AddToQueryString("http://api.example.com/user?id=123", "name=John") Debug.Print Url ' Output: http://api.example.com/user?id=123&name=John ``` #### MakeContent Builds a dictionary into query string format. ```vb Public Function MakeContent(Dic As Dictionary, Optional IsUrlEncode As Boolean = True) As String ``` **Parameters:** | Parameter | Type | Description | | ------------- | ---------- | ------------------------------------------- | | `Dic` | Dictionary | Dictionary to convert | | `IsUrlEncode` | Boolean | Whether to URL-encode values (default True) | **Example:** ```vb Dim Params As New Dictionary Params.Add "name", "John" Params.Add "age", "25" Params.Add "city", "Beijing" Dim QueryString As String QueryString = VBMAN.ToolsHttp.MakeContent(Params) Debug.Print QueryString ' Output: name=John&age=25&city=Beijing ' Without encoding QueryString = VBMAN.ToolsHttp.MakeContent(Params, False) Debug.Print QueryString ' Output: name=John&age=25&city=Beijing ``` #### ParseContent Parses query string into dictionary. ```vb Public Function ParseContent(Content As String, Obj As Dictionary, Optional IsUrlDecode As Boolean = True) As Boolean ``` **Parameters:** | Parameter | Type | Description | | ------------- | ---------- | ------------------------------------ | | `Content` | String | Query string | | `Obj` | Dictionary | Dictionary to store results | | `IsUrlDecode` | Boolean | Whether to URL-decode (default True) | **Example:** ```vb Dim Params As New Dictionary Dim Success As Boolean Success = VBMAN.ToolsHttp.ParseContent("name=John&age=25", Params) Debug.Print Params("name") ' Output: John Debug.Print Params("age") ' Output: 25 ``` #### ParseKeyValue Parses key-value formatted string into dictionary (e.g., HTTP Headers). ```vb Public Function ParseKeyValue(Content As String, Obj As Dictionary) As Boolean ``` **Description:** * Splits by lines * Each line splits by first `:` into key and value * Suitable for parsing HTTP Headers **Example:** ```vb Dim Headers As New Dictionary Dim HeaderText As String HeaderText = "Content-Type: application/json" & vbCrLf & _ "Authorization: Bearer token123" & vbCrLf & _ "X-Custom-Header: value" VBMAN.ToolsHttp.ParseKeyValue HeaderText, Headers Debug.Print Headers("Content-Type") ' Output: application/json Debug.Print Headers("Authorization") ' Output: Bearer token123 ``` *** ## Form URL-Encoded Conversion #### ToWwwFormUrlencoded Converts a collection object to `application/x-www-form-urlencoded` format. ```vb Public Function ToWwwFormUrlencoded(ByRef Obj As Object, Optional ByVal IsUrlEncode As Boolean = True) As String ``` **Parameters:** | Parameter | Type | Description | | ------------- | ------- | --------------------------------------------- | | `Obj` | Object | Collection object (cCollection or Dictionary) | | `IsUrlEncode` | Boolean | Whether to URL-encode values (default True) | **Example:** ```vb Dim Dic As New Dictionary Dic.Add "username", "admin" Dic.Add "password", "123456" Dim FormData As String FormData = VBMAN.ToolsHttp.ToWwwFormUrlencoded(Dic) Debug.Print FormData ' Output: username=admin&password=123456 ``` #### FromWwwFormUrlencoded Parses `application/x-www-form-urlencoded` format into collection object. ```vb Public Function FromWwwFormUrlencoded(ByVal Content As String, ByRef Obj As Object, Optional ByVal IsUrlDecode As Boolean = True) As Boolean ``` **Example:** ```vb Dim Dic As New Dictionary Dim Success As Boolean Success = VBMAN.ToolsHttp.FromWwwFormUrlencoded("name=John&age=25", Dic) Debug.Print Dic("name") ' Output: John Debug.Print Dic("age") ' Output: 25 ``` *** ## HTTP Method Mapping #### MapMethod Maps HTTP method name to internal index. ```vb Public Function MapMethod(Name As String) As Long ``` **Mapping Table:** | Method Name | Index | | ----------- | ----- | | ANY | 0 | | POST | 1 | | GET | 2 | | PUT | 3 | | DELETE | 4 | | OPTIONS | 5 | **Example:** ```vb Dim Index As Long Index = VBMAN.ToolsHttp.MapMethod("GET") Debug.Print Index ' Output: 2 Index = VBMAN.ToolsHttp.MapMethod("POST") Debug.Print Index ' Output: 1 ``` #### MapMethodName Maps internal index to HTTP method name. ```vb Public Function MapMethodName(Index As Long) As String ``` **Example:** ```vb Dim MethodName As String MethodName = VBMAN.ToolsHttp.MapMethodName(2) Debug.Print MethodName ' Output: GET ``` *** ## cHttpCrossDomain - HTTP Cross-Origin Configuration ### Overview Used to configure CORS (Cross-Origin Resource Sharing) response headers for HTTP server. ### Properties | Property | Type | Default | Description | | ------------------ | ------- | -------- | ------------------------------------------- | | `Enable` | Boolean | False | Whether to enable cross-origin support | | `AllowOrigin` | String | "\*" | Allowed origin | | `AllowMethods` | String | "\*" | Allowed methods | | `AllowHeaders` | String | "\*" | Allowed request headers | | `AllowCredentials` | Boolean | True | Whether to allow credentials | | `MaxAge` | Long | 86400000 | Preflight request cache time (milliseconds) | ### Usage ```vb ' Enable cross-origin VBMAN.HttpCrossDomain.Enable = True ' Custom configuration With VBMAN.HttpCrossDomain .Enable = True .AllowOrigin = "https://example.com" .AllowMethods = "GET, POST, PUT, DELETE" .AllowHeaders = "Content-Type, Authorization" .AllowCredentials = True End With ``` ### Usage in HttpServer ```vb Private Sub Server_OnBeforeRequest(Request As cHttpServerRequest) ' Automatically add cross-origin headers VBMAN.HttpCrossDomain.AddTo Request.Response.Headers End Sub ``` *** ## Complete Example ```vb Private Sub HttpDemo() ' URL encoding Dim Url As String Url = "http://api.example.com/search?q=" & _ VBMAN.ToolsHttp.UrlEncodeUtf8("VB6 Programming") Debug.Print Url ' Build query parameters Dim Params As New Dictionary Params.Add "page", "1" Params.Add "size", "20" Params.Add "keyword", "VB6" Dim QueryString As String QueryString = VBMAN.ToolsHttp.MakeContent(Params) Url = "http://api.example.com/list?" & QueryString Debug.Print Url ' Parse query string Dim Parsed As New Dictionary VBMAN.ToolsHttp.ParseContent QueryString, Parsed Debug.Print "Page: " & Parsed("page") Debug.Print "Size: " & Parsed("size") ' Parse HTTP Headers Dim Headers As New Dictionary Dim HeaderText As String HeaderText = "Content-Type: application/json" & vbCrLf & _ "Authorization: Bearer xxx" VBMAN.ToolsHttp.ParseKeyValue HeaderText, Headers End Sub ``` --- --- url: /en/vbman/tools/math.md --- # Tools - Math Utility Class ## cToolsMath - Math Calculation Tools ### Overview Provides mathematical operations such as rounding, random numbers, and rounding to nearest. ### Enumeration #### EnumRoundingMode ```vb Public Enum EnumRoundingMode Rounding = 0 ' Round to nearest Upper = 1 ' Round up (ceiling) Downer = 2 ' Round down (floor) End Enum ``` ### Methods #### Ceil Rounds up (ceiling). ```vb Public Function Ceil( _ ByVal Num As Variant, _ Optional ByVal Dot As Long _ ) As Currency ``` **Parameters:** | Parameter | Type | Description | |-----------|------|-------------| | `Num` | Variant | Number to round | | `Dot` | Long | Decimal places to keep (default 0) | **Example:** ```vb Debug.Print VBMAN.ToolsMath.Ceil(3.14) ' Output: 4 Debug.Print VBMAN.ToolsMath.Ceil(3.14, 1) ' Output: 3.2 Debug.Print VBMAN.ToolsMath.Ceil(-3.14) ' Output: -3 ``` #### GetRandRange Gets random integer in specified range (inclusive). ```vb Public Function GetRandRange(a As Long, b As Long) As Long ``` **Example:** ```vb ' Random integer between 1-100 Dim Rand As Long Rand = VBMAN.ToolsMath.GetRandRange(1, 100) Debug.Print Rand ' Random boolean Dim IsTrue As Boolean IsTrue = (VBMAN.ToolsMath.GetRandRange(0, 1) = 1) ``` #### RoundCurrency Rounds to nearest (supports multiple rounding modes). ```vb Public Function RoundCurrency( _ ByVal Value As Variant, _ Optional ByVal DecimalPlaces As Integer = 0, _ Optional ByVal RoundingMode As EnumRoundingMode = 0 _ ) As Currency ``` **Parameters:** | Parameter | Type | Description | |-----------|------|-------------| | `Value` | Variant | Number to round | | `DecimalPlaces` | Integer | Decimal places (default 0, range -4~4) | | `RoundingMode` | EnumRoundingMode | Rounding mode | **Example:** ```vb ' Round to nearest Debug.Print VBMAN.ToolsMath.RoundCurrency(3.14159, 2) ' 3.14 Debug.Print VBMAN.ToolsMath.RoundCurrency(3.14159, 2, Rounding) ' 3.14 ' Round up (ceiling) Debug.Print VBMAN.ToolsMath.RoundCurrency(3.14159, 2, Upper) ' 3.15 ' Round down (floor) Debug.Print VBMAN.ToolsMath.RoundCurrency(3.14159, 2, Downer) ' 3.14 ' Negative decimal places (round to tens) Debug.Print VBMAN.ToolsMath.RoundCurrency(1234, -2, Rounding) ' 1200 ``` ### Complete Example ```vb Private Sub MathDemo() Dim Price As Currency Price = 123.456 ' Round product price to cents Debug.Print "Standard price: " & VBMAN.ToolsMath.RoundCurrency(Price, 2) ' Discount price rounded up (no loss) Debug.Print "Discount price: " & VBMAN.ToolsMath.RoundCurrency(Price * 0.95, 2, Upper) ' Generate random verification code Dim Code As String Code = Format(VBMAN.ToolsMath.GetRandRange(1000, 9999), "0000") Debug.Print "Verification code: " & Code End Sub ``` --- --- url: /en/vbman/tools/password.md --- # Tools - Password Utility Class ## cPassword - Password Hash Tool ### Overview Provides password hash generation and verification functionality, supporting MD5, SHA1, SHA256 algorithms, and custom salt values. ### Dependencies * `cCryptoHash` (src/Crypt/Hash) ### Properties | Property | Type | Description | |----------|------|-------------| | `Algorithm` | CryptoHashAlgorithm | Hash algorithm (default MD5) | | `Salt` | String | Salt value (default empty) | | `Encoding` | CryptoStringEncoding | String encoding (default UTF8) | | `LastError` | String | Last error message (read-only) | ### Enumeration Values #### CryptoHashAlgorithm ```vb HASH_ALG_MD5 = 0 HASH_ALG_SHA1 = 1 HASH_ALG_SHA256 = 2 ``` ### Methods #### Create Creates password hash. ```vb Public Function Create( _ ByVal Password As String, _ Optional ByRef Salt As Variant _ ) As String ``` **Parameters:** | Parameter | Type | Description | |-----------|------|-------------| | `Password` | String | Plain text password | | `Salt` | Variant | Optional, salt value (if not passed, uses property Salt) | **Returns:** Returns hash string in hexadecimal format. **Example:** ```vb Dim Pwd As New cPassword ' Using default MD5 Dim Hash1 As String Hash1 = Pwd.Create("myPassword") Debug.Print Hash1 ' Output: 34819d7beeabb9260a5c854bc85b3e44 ' Using SHA256 Pwd.Algorithm = HASH_ALG_SHA256 Dim Hash2 As String Hash2 = Pwd.Create("myPassword") Debug.Print Hash2 ' Using random salt Dim Salt As String Salt = VBMAN.CryptoRandom.GetString(16) ' Generate 16-char random salt Pwd.Salt = Salt Dim Hash3 As String Hash3 = Pwd.Create("myPassword") ``` #### Verify Verifies if password matches. ```vb Public Function Verify( _ ByVal Password As String, _ ByVal Hash As String, _ Optional ByRef Salt As Variant _ ) As Boolean ``` **Parameters:** | Parameter | Type | Description | |-----------|------|-------------| | `Password` | String | Plain text password | | `Hash` | String | Stored hash value | | `Salt` | Variant | Optional, salt value | **Returns:** * `True` - Password matches * `False` - Password does not match **Example:** ```vb Dim Pwd As New cPassword Pwd.Salt = "mysalt" ' Create hash Dim StoredHash As String StoredHash = Pwd.Create("myPassword") ' Verify password If Pwd.Verify("myPassword", StoredHash) Then Debug.Print "Password correct" Else Debug.Print "Password incorrect" End If ``` ### Complete Example ```vb Private Sub TestPassword() Dim Pwd As New cPassword ' Configuration Pwd.Algorithm = HASH_ALG_SHA256 Pwd.Salt = "AppSpecificSalt" Pwd.Encoding = ENCODING_UTF8 ' Store hash when user registers Dim UserHash As String UserHash = Pwd.Create(txtPassword.Text) SaveToDatabase txtUserName.Text, UserHash ' Verify when user logs in Dim StoredHash As String StoredHash = GetHashFromDatabase(txtUserName.Text) If Pwd.Verify(txtPassword.Text, StoredHash) Then MsgBox "Login successful" Else MsgBox "Password incorrect" End If End Sub ``` ### Security Recommendations 1. **Use strong hash algorithm** - Prefer SHA256 2. **Add random salt** - Prevents rainbow table attacks 3. **Salt uniqueness** - Each user should use a different salt 4. **Salt storage** - Salt should be stored together with the hash --- --- url: /en/vbman/tools/string.md --- # Tools - String Utility Class ## cToolsStr - String Processing Tools ### Overview Provides rich string processing functionality, including regex extraction, line splitting, encoding detection, string slicing, random string generation, etc. *** ### Text Splitting and Joining #### ParseNumbers Extracts numbers from string (supports decimals). ```vb Function ParseNumbers(inputString As String, Optional DecimalPlaces As Long = -1, Optional Count As Long) As Collection ``` **Parameters:** | Parameter | Type | Description | |-----------|------|-------------| | `inputString` | String | Input string | | `DecimalPlaces` | Long | Decimal places, -1 means no processing | | `Count` | Long | Extraction count limit, 0 means unlimited | **Example:** ```vb Dim Numbers As Collection Set Numbers = VBMAN.ToolsStr.ParseNumbers("Price: 123.5元, Quantity: 10个") Dim n As Variant For Each n In Numbers Debug.Print n ' Output: 123.5, 10 Next n ``` #### SplitLinesToCollection Splits text by lines into collection. ```vb Public Function SplitLinesToCollection(ByVal Text As String) As cCollection ``` **Example:** ```vb Dim Lines As cCollection Set Lines = VBMAN.ToolsStr.SplitLinesToCollection("Line1" & vbCrLf & "Line2") Debug.Print Lines(1) ' Output: Line1 ``` #### JoinLinesFromCollection Joins line collection into string. ```vb Public Function JoinLinesFromCollection(Coll As cCollection) As String ``` **Example:** ```vb Dim Lines As cCollection Set Lines = New cCollection Lines.Add "Line1" Lines.Add "Line2" Dim Text As String Text = VBMAN.ToolsStr.JoinLinesFromCollection(Lines) Debug.Print Text ' Output: Line1\r\nLine2 ``` #### SplitLines Splits text by lines into array. ```vb Public Function SplitLines(ByVal Text As String) As String() ``` **Example:** ```vb Dim Lines() As String Lines = VBMAN.ToolsStr.SplitLines("Line1" & vbCrLf & "Line2") Debug.Print Lines(0) ' Output: Line1 ``` *** ### String Query and Check #### HasStr Checks if string contains substring (returns position, 0 means not found). ```vb Public Function HasStr(ByVal FindStr As String, FullStr As String, Optional StartPos As Long = 1, Optional CompType As VbCompareMethod = vbTextCompare) As Long ``` **Example:** ```vb If VBMAN.ToolsStr.HasStr("test", "this is a test") > 0 Then Debug.Print "Contains 'test'" End If ' Specify start position Dim Pos As Long Pos = VBMAN.ToolsStr.HasStr("a", "banana", 2) Debug.Print Pos ' Output: 4 ``` #### HasStrFromRight Checks if string contains substring from right side. ```vb Public Function HasStrFromRight(ByVal FindStr As String, FullStr As String, Optional StartPos As Long = -1, Optional CompType As VbCompareMethod = vbTextCompare) As Long ``` **Example:** ```vb Dim Pos As Long Pos = VBMAN.ToolsStr.HasStrFromRight("a", "banana") Debug.Print Pos ' Output: 6 (position of last 'a') ``` #### IsEmptyEx Checks if string is empty (after trimming whitespace). ```vb Public Function IsEmptyEx(Text As String) As Boolean ``` **Example:** ```vb Debug.Print VBMAN.ToolsStr.IsEmptyEx(" ") ' Output: True Debug.Print VBMAN.ToolsStr.IsEmptyEx("hello") ' Output: False ``` #### IsString Checks if variable is string type. ```vb Public Function IsString(var As Variant) As Boolean ``` **Example:** ```vb Debug.Print VBMAN.ToolsStr.IsString("hello") ' Output: True Debug.Print VBMAN.ToolsStr.IsString(123) ' Output: False ``` *** ### String Slicing and Substring #### SliceString Processes String type slicing. ```vb Public Function SliceString(ByVal Arr As String, ByVal StartPos As Long, Optional ByVal EndPos As Long = -1) As String ``` **Parameters:** | Parameter | Type | Description | |-----------|------|-------------| | `Arr` | String | Source string | | `StartPos` | Long | Start position (0-based) | | `EndPos` | Long | End position (0-based), -1 means to end | **Example:** ```vb Dim str As String Dim sliced As String str = "Hello World" sliced = VBMAN.ToolsStr.SliceString(str, 0, 4) Debug.Print sliced ' Output: Hello ' From position 6 to end sliced = VBMAN.ToolsStr.SliceString(str, 6) Debug.Print sliced ' Output: World ``` #### SubStr Extracts substring by start and end markers. ```vb Public Function SubStr(ByVal Txt As String, ByVal txtFirst As String, Optional ByVal txtEnd As String, Optional RetInt As Boolean, Optional Method As VbCompareMethod = vbBinaryCompare, Optional FindFromEnd As Boolean) As String ``` **Parameters:** | Parameter | Type | Description | |-----------|------|-------------| | `Txt` | String | Source string | | `txtFirst` | String | Start marker | | `txtEnd` | String | End marker, empty means to end | | `RetInt` | Boolean | Return "0" when not found instead of empty string | | `Method` | VbCompareMethod | Comparison method | | `FindFromEnd` | Boolean | Find end marker from end | **Example:** ```vb Dim Text As String Dim Result As String Text = "
    Hello World
    " ' Extract content inside div tag Result = VBMAN.ToolsStr.SubStr(Text, "
    ", "
    ") Debug.Print Result ' Output: Hello World ' Find from end Result = VBMAN.ToolsStr.SubStr(Text, "<", ">", False, vbBinaryCompare, True) Debug.Print Result ' Output: /div ``` #### MidEx Extracts substring by start and end markers (with position tracking). ```vb Public Function MidEx(FullStr As String, Lstr As String, Rstr As String, Optional starindex As Long) As String ``` **Example:** ```vb Dim Text As String Text = "name[John]age[25]city[Beijing]" Dim Result As String Dim StartPos As Long Result = VBMAN.ToolsStr.MidEx(Text, "[", "]", StartPos) Debug.Print Result ' Output: John Debug.Print StartPos ' Output: Next search start position ``` #### ToArray Converts string to character array. ```vb Public Function ToArray(Text As String) As String() ``` **Example:** ```vb Dim CharArray() As String CharArray = VBMAN.ToolsStr.ToArray("Hello") Dim i As Long For i = LBound(CharArray) To UBound(CharArray) Debug.Print CharArray(i) ' Output: H e l l o Next i ``` *** ### String Trimming and Processing #### TrimEx Trims whitespace characters from beginning and end of string (including invisible characters). ```vb Public Function TrimEx(ByRef Text As String, Optional IsLeft As Boolean = True, Optional IsRight As Boolean = True) As String ``` **Parameters:** | Parameter | Type | Description | |-----------|------|-------------| | `Text` | String | Source string | | `IsLeft` | Boolean | Whether to trim left whitespace | | `IsRight` | Boolean | Whether to trim right whitespace | **Example:** ```vb Dim Text As String Text = vbCrLf & " Hello World " & vbTab Debug.Print VBMAN.ToolsStr.TrimEx(Text) ' Output: Hello World Debug.Print VBMAN.ToolsStr.TrimEx(Text, True, False) ' Output: Hello World \t Debug.Print VBMAN.ToolsStr.TrimEx(Text, False, True) ' Output: \r\n Hello World ``` #### RightEx / LeftEx Gets specified length of characters from right/left of string. ```vb Public Function RightEx(Text As Variant, Length As Long) As String Public Function LeftEx(Text As Variant, Length As Long) As String ``` **Example:** ```vb Dim Text As String Text = " Hello World " Debug.Print VBMAN.ToolsStr.RightEx(Text, 5) ' Output: World Debug.Print VBMAN.ToolsStr.LeftEx(Text, 5) ' Output: Hello ``` #### InsertSpan Inserts separator every specified number of characters. ```vb Public Function InsertSpan(ByRef inputStr As String, ByVal Span As String, ByVal SetpNum As Long, Optional HeadFoot As Boolean) As String ``` **Parameters:** | Parameter | Type | Description | |-----------|------|-------------| | `inputStr` | String | Source string | | `Span` | String | Separator | | `SetpNum` | Long | Insert separator every how many characters | | `HeadFoot` | Boolean | Whether to add separator at beginning and end | **Example:** ```vb Dim Text As String Text = "1234567890123456" ' Insert space every 4 characters Debug.Print VBMAN.ToolsStr.InsertSpan(Text, " ", 4) ' Output: 1234 5678 9012 3456 Debug.Print VBMAN.ToolsStr.InsertSpan(Text, "-", 4, True) ' Output: -1234-5678-9012-3456- ``` *** ### String Encoding Conversion #### PercentEncode / PercentDecode Percent encoding/decoding (converts numbers to % format). ```vb Public Function PercentEncode(inputStr As String) As String Function PercentDecode(encodedStr As String) As String ``` **Example:** ```vb Dim Text As String Text = "43068119891129321X" Dim Encoded As String Encoded = VBMAN.ToolsStr.PercentEncode(Text) Debug.Print Encoded ' Output: %34%33%30%36%38%31%31%39%38%39%31%31%32%39%33%32%31X Dim Decoded As String Decoded = VBMAN.ToolsStr.PercentDecode(Encoded) Debug.Print Decoded ' Output: 43068119891129321X ``` #### UnicodeEncode / UnicodeDecode Unicode encoding/decoding (\uXXXX format). ```vb Public Function UnicodeEncode(ByVal inputString As String, Optional PreFix As String = "\u") As String Public Function UnicodeDecode(Text As String, Optional PreFix As String = "\u") As String ``` **Example:** ```vb Dim Text As String Text = "你好 World" Dim Encoded As String Encoded = VBMAN.ToolsStr.UnicodeEncode(Text) Debug.Print Encoded ' Output: \u4F60\u597D World Dim Decoded As String Decoded = VBMAN.ToolsStr.UnicodeDecode(Encoded) Debug.Print Decoded ' Output: 你好 World ``` *** ### Byte Array Operations #### ToBytes Converts string to byte array (Unicode). ```vb Public Function ToBytes(inputString As String) As Byte() ``` **Example:** ```vb Dim Bytes() As Byte Bytes = VBMAN.ToolsStr.ToBytes("Hello") ``` #### FromByteArray Converts byte array to string. ```vb Public Function FromByteArray(inputArray() As Byte, Optional CharSet As String = "UTF-8") As String ``` **Example:** ```vb Dim Bytes() As Byte Bytes = VBMAN.ToolsStr.ToBytes("Hello") Dim Text As String Text = VBMAN.ToolsStr.FromByteArray(Bytes) Debug.Print Text ' Output: Hello ``` #### LenBytes Calculates byte array length. ```vb Public Function LenBytes(inputArray() As Byte) As Long ``` **Example:** ```vb Dim Bytes() As Byte Bytes = VBMAN.ToolsStr.ToBytes("Hello") Debug.Print VBMAN.ToolsStr.LenBytes(Bytes) ' Output: 5 ``` #### ToHex / FromHex String and hexadecimal conversion. ```vb Public Function ToHex(InputData As Variant, Optional CharSet As String = "UTF-8") As String Public Function FromHex(hexStr As String, Optional CharSet As String = "UTF-8") As String ``` **Example:** ```vb Dim Text As String Text = "Hello" ' Convert to hexadecimal Dim HexStr As String HexStr = VBMAN.ToolsStr.ToHex(Text) Debug.Print HexStr ' Output: 48656C6C6F ' Restore from hexadecimal Dim Original As String Original = VBMAN.ToolsStr.FromHex(HexStr) Debug.Print Original ' Output: Hello ``` *** ### Random String Generation #### GetRandStr Gets random string. ```vb Public Function GetRandStr(Optional ByVal Lens As Long = 32, Optional Zuhe As String = "1aA") As String ``` **Parameters:** | Parameter | Type | Description | |-----------|------|-------------| | `Lens` | Long | String length | | `Zuhe` | String | Character combination: 1=numbers, a=lowercase, A=uppercase, @=special characters | **Example:** ```vb ' Numbers only, 8 characters Debug.Print VBMAN.ToolsStr.GetRandStr(8, "1") ' Numbers + lowercase letters, 16 characters Debug.Print VBMAN.ToolsStr.GetRandStr(16, "1a") ' Numbers + uppercase/lowercase letters, 32 characters Debug.Print VBMAN.ToolsStr.GetRandStr(32, "1aA") ' Include special characters Debug.Print VBMAN.ToolsStr.GetRandStr(16, "1aA@") ``` #### GetRandByte / GetRandByteToHex Gets random byte array. ```vb Public Function GetRandByte(Optional ByteSize As Long = 32) As Byte() Public Function GetRandByteToHex(Optional ByteSize As Long = 32, Optional Span As String = "") As String ``` **Example:** ```vb ' Get 32-byte random array Dim Bytes() As Byte Bytes = VBMAN.ToolsStr.GetRandByte(32) ' Get 16-byte random string (hexadecimal) Dim HexStr As String HexStr = VBMAN.ToolsStr.GetRandByteToHex(16) Debug.Print HexStr ' Output: a3f7b2c8d1e5... ' With separator HexStr = VBMAN.ToolsStr.GetRandByteToHex(16, "-") Debug.Print HexStr ' Output: a3-f7-b2-c8-... ``` *** ### GUID Generation #### GetGUID Generates GUID string. ```vb Public Function GetGUID(Optional isFull As Boolean) As String ``` **Parameters:** | Parameter | Type | Description | |-----------|------|-------------| | `isFull` | Boolean | Whether to return full format (with brackets) | **Example:** ```vb ' Standard GUID format Debug.Print VBMAN.ToolsStr.GetGUID() ' Output: 550e8400-e29b-41d4-a716-446655440000 ' Full format (with brackets) Debug.Print VBMAN.ToolsStr.GetGUID(True) ' Output: {550e8400-e29b-41d4-a716-446655440000} ``` *** ### Helper Functions #### JoinStr Joins multiple strings with specified separator. ```vb Public Function JoinStr(Span As String, ParamArray Strings() As Variant) As String ``` **Example:** ```vb Dim Result As String Result = VBMAN.ToolsStr.JoinStr("-", "2024", "05", "17") Debug.Print Result ' Output: 2024-05-17 ``` #### UniVbCrLf Unifies line breaks to vbCrLf. ```vb Public Function UniVbCrLf(Text As String) As String ``` **Example:** ```vb Dim Text As String Text = "Line1" & vbLf & "Line2" & vbCr & "Line3" Dim Result As String Result = VBMAN.ToolsStr.UniVbCrLf(Text) ' Result: Line1\r\nLine2\r\nLine3 ``` #### GetFirstChar / GetLastChar Gets first/last valid character. ```vb Public Function GetFirstChar(Txt As String, Optional Length As Long = 1) As String Public Function GetLastChar(Txt As String, Optional Length As Long = 1) As String ``` **Example:** ```vb Dim Text As String Text = " Hello World " Debug.Print VBMAN.ToolsStr.GetFirstChar(Text) ' Output: H Debug.Print VBMAN.ToolsStr.GetLastChar(Text) ' Output: d Debug.Print VBMAN.ToolsStr.GetFirstChar(Text, 5) ' Output: Hello ``` *** ## cFormater - General Formatter ### Overview General-purpose formatter with chainable interface, can format file sizes, time, numbers, etc. ### Chain Entry #### Data Sets the data source to format. ```vb Public Function Data(ByVal Source As Variant) As cFormater ``` ### File Size Formatting #### ReturnFileSize Formats file size to human-readable format (B/KB/MB/GB/TB). ```vb Public Function ReturnFileSize(Optional ByVal DecimalPlaces As Long = 2, Optional ByVal ForceUnit As String = "") As String ``` **Example:** ```vb ' Auto-select unit Debug.Print VBMAN.Formater.Data(1536).ReturnFileSize() ' 1.50 KB Debug.Print VBMAN.Formater.Data(1572864).ReturnFileSize() ' 1.50 MB ' Force unit Debug.Print VBMAN.Formater.Data(1024).ReturnFileSize(2, "KB") ' 1.00 KB Debug.Print VBMAN.Formater.Data(1024).ReturnFileSize(2, "B") ' 1024.00 B ``` ### Time Formatting #### ReturnRelativeTime Returns relative time description (seconds ago, minutes ago, etc.). ```vb Public Function ReturnRelativeTime() As String ``` **Example:** ```vb Dim Ts As Currency Ts = VBMAN.ToolsDateTime.GetUnixTimestamp() - 60000 ' 1 minute ago Debug.Print VBMAN.Formater.Data(Ts).ReturnRelativeTime() ' 1 minute ago ``` #### ReturnDuration Formats duration. ```vb Public Function ReturnDuration(Optional ByVal Precision As String = "auto") As String ``` **Example:** ```vb Debug.Print VBMAN.Formater.Data(65000).ReturnDuration() ' 1m 5s Debug.Print VBMAN.Formater.Data(3661000).ReturnDuration() ' 1h 1m 1s ``` ### Number Formatting #### ReturnNumber Formats number (thousands separator, decimal places, etc.). ```vb Public Function ReturnNumber(Optional ByVal DecimalPlaces As Long = -1, Optional ByVal UseThousandSeparator As Boolean = True) As String ``` **Example:** ```vb Debug.Print VBMAN.Formater.Data(1234567.89).ReturnNumber() ' 1,234,567.89 Debug.Print VBMAN.Formater.Data(1234567.89).ReturnNumber(0) ' 1,234,568 ``` ### Complete Example ```vb Private Sub FormatterDemo() ' File size Dim FileSize As Currency FileSize = FileLen("C:\\largefile.zip") lblSize.Caption = VBMAN.Formater.Data(FileSize).ReturnFileSize() ' Number thousands separator Dim Amount As Currency Amount = 1234567.89 lblAmount.Caption = VBMAN.Formater.Data(Amount).ReturnNumber(2) ' Relative time Dim LastTime As Currency LastTime = GetLastLoginTime() ' Unix timestamp lblLastLogin.Caption = VBMAN.Formater.Data(LastTime).ReturnRelativeTime() End Sub ``` --- --- url: /en/vbman/tools/system.md --- # Tools - System Utility Class ## cToolsSystem - System Operation Tools ### Overview Provides system-level operations, such as running programs as administrator. ### Methods #### RunAsAdmin Runs the specified program as administrator. ```vb Public Function RunAsAdmin( _ ByRef Path As Variant, _ ParamArray StartArgs() As Variant _ ) As Long ``` **Parameters:** | Parameter | Type | Description | |-----------|------|-------------| | `Path` | Variant | Program path (supports App object or string) | | `StartArgs` | Variant | Optional, command line argument array | **Returns:** ShellExecute execution result. **Example:** ```vb ' Method 1: Pass App object VBMAN.ToolsSystem.RunAsAdmin App ' Method 2: Pass path string VBMAN.ToolsSystem.RunAsAdmin "C:\\Program Files\\MyApp\\MyApp.exe" ' Run with arguments VBMAN.ToolsSystem.RunAsAdmin App, "--config", "debug" ``` ### Complete Example ```vb Private Sub RestartAsAdmin() Dim Result As Long ' Check if already running as administrator (needs additional check logic) If Not IsAdmin() Then Result = VBMAN.ToolsSystem.RunAsAdmin(App) If Result > 32 Then ' Successfully started admin process, exit current process End Else MsgBox "Unable to elevate to administrator privileges", vbExclamation End If End If End Sub ``` ### Notes 1. Calling will trigger UAC (User Account Control) prompt 2. If user refuses to elevate privileges, program will not start 3. Return value greater than 32 indicates success --- --- url: /zh/vbman/tools/utf8.md --- # Tools - UTF-8 编码工具类 ## cToolsUtf8 - UTF-8 编解码 ### 概述 提供 Unicode 字符串与 UTF-8 字节数组之间的转换功能。 *** ## 基础编解码 #### Encode 将 Unicode 字符串编码为 UTF-8 字节数组。 ```vb Public Function Encode(ByVal UCS As String) As Byte() ``` **参数：** | 参数名 | 类型 | 说明 | |--------|------|------| | `UCS` | String | Unicode 字符串 | **返回值：** UTF-8 编码的字节数组。 **示例：** ```vb Dim Utf8Bytes() As Byte Utf8Bytes = VBMAN.ToolsUtf8.Encode("你好世界") ' 查看字节内容 Dim i As Long For i = LBound(Utf8Bytes) To UBound(Utf8Bytes) Debug.Print Hex(Utf8Bytes(i)); Next i ' 输出: E4 BD A0 E5 A5 BD E4 B8 96 E7 95 8C ``` #### Decode 将 UTF-8 字节数组解码为 Unicode 字符串。 ```vb Public Function Decode(ByRef Utf() As Byte) As String ``` **参数：** | 参数名 | 类型 | 说明 | |--------|------|------| | `Utf` | Byte() | UTF-8 字节数组 | **返回值：** 解码后的 Unicode 字符串。 **示例：** ```vb Dim Utf8Bytes() As Byte Utf8Bytes = VBMAN.ToolsUtf8.Encode("你好世界") Dim Text As String Text = VBMAN.ToolsUtf8.Decode(Utf8Bytes) Debug.Print Text ' 输出: 你好世界 ``` #### DecodeToByteArray 将 UTF-8 字节数组解码为 Unicode 字节数组（WideChar）。 ```vb Public Function DecodeToByteArray(ByRef Utf() As Byte) As Byte() ``` **说明：** * 将 UTF-8 字节转换为 Unicode（UTF-16LE）字节数组 * 每个字符占2字节 **示例：** ```vb Dim Utf8Bytes() As Byte Dim UnicodeBytes() As Byte Utf8Bytes = VBMAN.ToolsUtf8.Encode("Hello") UnicodeBytes = VBMAN.ToolsUtf8.DecodeToByteArray(Utf8Bytes) ' UnicodeBytes 现在包含 UTF-16LE 编码的字节 ' "H" = 0x48 0x00, "e" = 0x65 0x00, ... ``` *** ## 带 BOM 的编解码 #### EncodeWithBom 将字符串编码为带 BOM 的 UTF-8 字节数组。 ```vb Public Function EncodeWithBom(strIn As String) As Byte() ``` **说明：** * BOM（Byte Order Mark）为 `EF BB BF` * 某些 Windows 程序需要 BOM 来识别 UTF-8 编码 **示例：** ```vb Dim Utf8Bytes() As Byte Utf8Bytes = VBMAN.ToolsUtf8.EncodeWithBom("你好世界") ' 查看字节内容（前3字节是BOM） Dim i As Long For i = LBound(Utf8Bytes) To UBound(Utf8Bytes) Debug.Print Hex(Utf8Bytes(i)); Next i ' 输出: EF BB BF E4 BD A0 E5 A5 BD E4 B8 96 E7 95 8C ' [ BOM ] [ 你好世界（UTF-8） ] ``` #### DecodeWithBom 将带 BOM 的 UTF-8 字节数组解码为字符串。 ```vb Public Function DecodeWithBom(ByVal varIn As Variant) As String ``` **参数：** | 参数名 | 类型 | 说明 | |--------|------|------| | `varIn` | Variant | 字节数组或包含字节数组的 Variant | **说明：** * 自动检测并跳过 BOM * 支持带或不带 BOM 的数据 **示例：** ```vb Dim Utf8Bytes() As Byte Utf8Bytes = VBMAN.ToolsUtf8.EncodeWithBom("你好世界") Dim Text As String Text = VBMAN.ToolsUtf8.DecodeWithBom(Utf8Bytes) Debug.Print Text ' 输出: 你好世界 ' 不带 BOM 的数据也能解码 Dim NoBomBytes() As Byte NoBomBytes = VBMAN.ToolsUtf8.Encode("Hello") Text = VBMAN.ToolsUtf8.DecodeWithBom(NoBomBytes) Debug.Print Text ' 输出: Hello ``` *** ## 完整示例 ```vb Private Sub Utf8Demo() Dim Original As String Dim Utf8Bytes() As Byte Dim Decoded As String Original = "VBMAN 框架 v1.0" ' 编码为 UTF-8 Utf8Bytes = VBMAN.ToolsUtf8.Encode(Original) Debug.Print "UTF-8 字节数: " & (UBound(Utf8Bytes) + 1) ' 解码回字符串 Decoded = VBMAN.ToolsUtf8.Decode(Utf8Bytes) Debug.Print "解码结果: " & Decoded ' 验证 Debug.Print "是否一致: " & (Original = Decoded) ' ===== 带 BOM 的操作 ===== Dim Utf8BytesWithBom() As Byte Utf8BytesWithBom = VBMAN.ToolsUtf8.EncodeWithBom(Original) Debug.Print "带 BOM 的字节数: " & (UBound(Utf8BytesWithBom) + 1) ' 解码带 BOM 的数据 Decoded = VBMAN.ToolsUtf8.DecodeWithBom(Utf8BytesWithBom) Debug.Print "BOM 解码结果: " & Decoded End Sub Private Sub Utf8FileDemo() ' 保存 UTF-8 文件（不带 BOM） Dim Text As String Text = "你好，世界！" Dim Utf8Bytes() As Byte Utf8Bytes = VBMAN.ToolsUtf8.Encode(Text) ' 使用 cFileIO 保存 VBMAN.FileIO.SetBuffer(Utf8Bytes).SaveData "C:\\utf8_nobom.txt" ' 保存带 BOM 的 UTF-8 文件 Dim Utf8BytesWithBom() As Byte Utf8BytesWithBom = VBMAN.ToolsUtf8.EncodeWithBom(Text) VBMAN.FileIO.SetBuffer(Utf8BytesWithBom).SaveData "C:\\utf8_bom.txt" ' 读取并解码 Dim ReadBytes() As Byte VBMAN.FileIO.OpenFile("C:\\utf8_nobom.txt").ReadData() ReadBytes = VBMAN.FileIO.ReturnBytes() Dim ReadText As String ReadText = VBMAN.ToolsUtf8.Decode(ReadBytes) Debug.Print "读取内容: " & ReadText End Sub ``` *** ## 应用场景 | 场景 | 示例 | |------|------| | **网络传输** | 将字符串转为 UTF-8 字节后发送 | | **文件存储** | 将文本以 UTF-8 编码保存 | | **加密解密** | 先转 UTF-8 字节再加密 | | **数据校验** | 计算 UTF-8 字节的哈希值 | | **跨平台兼容** | 使用带 BOM 的 UTF-8 确保 Windows 程序正确识别 | *** ## 编码对比 | 编码方式 | 优点 | 缺点 | |----------|------|------| | **Encode** | 标准 UTF-8，兼容性好 | 部分 Windows 程序可能无法识别 | | **EncodeWithBom** | Windows 记事本等程序可正确识别 | 多3字节 BOM 开销 | *** ## 注意事项 1. **BOM 的使用** * Windows 记事本保存 UTF-8 文件会带 BOM * 部分程序（如某些 Unix 工具）可能不识别 BOM * Web 开发中通常推荐不带 BOM 2. **字节序** * UTF-8 没有字节序问题 * UTF-16 才有大端/小端之分 3. **内存占用** * 中文字符：UTF-8 通常占3字节，UTF-16 占2字节 * ASCII 字符：UTF-8 占1字节，UTF-16 占2字节 --- --- url: /en/vbman/tools/utf8.md --- # Tools - UTF-8 Encoding Utility Class ## cToolsUtf8 - UTF-8 Encoding and Decoding ### Overview Provides conversion functionality between Unicode strings and UTF-8 byte arrays. *** ## Basic Encoding and Decoding #### Encode Encodes Unicode string to UTF-8 byte array. ```vb Public Function Encode(ByVal UCS As String) As Byte() ``` **Parameters:** | Parameter | Type | Description | |-----------|------|-------------| | `UCS` | String | Unicode string | **Returns:** UTF-8 encoded byte array. **Example:** ```vb Dim Utf8Bytes() As Byte Utf8Bytes = VBMAN.ToolsUtf8.Encode("你好世界") ' View byte content Dim i As Long For i = LBound(Utf8Bytes) To UBound(Utf8Bytes) Debug.Print Hex(Utf8Bytes(i)); Next i ' Output: E4 BD A0 E5 A5 BD E4 B8 96 E7 95 8C ``` #### Decode Decodes UTF-8 byte array to Unicode string. ```vb Public Function Decode(ByRef Utf() As Byte) As String ``` **Parameters:** | Parameter | Type | Description | |-----------|------|-------------| | `Utf` | Byte() | UTF-8 byte array | **Returns:** Decoded Unicode string. **Example:** ```vb Dim Utf8Bytes() As Byte Utf8Bytes = VBMAN.ToolsUtf8.Encode("你好世界") Dim Text As String Text = VBMAN.ToolsUtf8.Decode(Utf8Bytes) Debug.Print Text ' Output: 你好世界 ``` #### DecodeToByteArray Decodes UTF-8 byte array to Unicode byte array (WideChar). ```vb Public Function DecodeToByteArray(ByRef Utf() As Byte) As Byte() ``` **Description:** * Converts UTF-8 bytes to Unicode (UTF-16LE) byte array * Each character occupies 2 bytes **Example:** ```vb Dim Utf8Bytes() As Byte Dim UnicodeBytes() As Byte Utf8Bytes = VBMAN.ToolsUtf8.Encode("Hello") UnicodeBytes = VBMAN.ToolsUtf8.DecodeToByteArray(Utf8Bytes) ' UnicodeBytes now contains UTF-16LE encoded bytes ' "H" = 0x48 0x00, "e" = 0x65 0x00, ... ``` *** ## Encoding and Decoding with BOM #### EncodeWithBom Encodes string to UTF-8 byte array with BOM. ```vb Public Function EncodeWithBom(strIn As String) As Byte() ``` **Description:** * BOM (Byte Order Mark) is `EF BB BF` * Some Windows programs need BOM to recognize UTF-8 encoding **Example:** ```vb Dim Utf8Bytes() As Byte Utf8Bytes = VBMAN.ToolsUtf8.EncodeWithBom("你好世界") ' View byte content (first 3 bytes are BOM) Dim i As Long For i = LBound(Utf8Bytes) To UBound(Utf8Bytes) Debug.Print Hex(Utf8Bytes(i)); Next i ' Output: EF BB BF E4 BD A0 E5 A5 BD E4 B8 96 E7 95 8C ' [ BOM ] [ 你好世界（UTF-8） ] ``` #### DecodeWithBom Decodes UTF-8 byte array with BOM to string. ```vb Public Function DecodeWithBom(ByVal varIn As Variant) As String ``` **Parameters:** | Parameter | Type | Description | |-----------|------|-------------| | `varIn` | Variant | Byte array or Variant containing byte array | **Description:** * Automatically detects and skips BOM * Supports data with or without BOM **Example:** ```vb Dim Utf8Bytes() As Byte Utf8Bytes = VBMAN.ToolsUtf8.EncodeWithBom("你好世界") Dim Text As String Text = VBMAN.ToolsUtf8.DecodeWithBom(Utf8Bytes) Debug.Print Text ' Output: 你好世界 ' Can also decode data without BOM Dim NoBomBytes() As Byte NoBomBytes = VBMAN.ToolsUtf8.Encode("Hello") Text = VBMAN.ToolsUtf8.DecodeWithBom(NoBomBytes) Debug.Print Text ' Output: Hello ``` *** ## Complete Example ```vb Private Sub Utf8Demo() Dim Original As String Dim Utf8Bytes() As Byte Dim Decoded As String Original = "VBMAN Framework v1.0" ' Encode to UTF-8 Utf8Bytes = VBMAN.ToolsUtf8.Encode(Original) Debug.Print "UTF-8 byte count: " & (UBound(Utf8Bytes) + 1) ' Decode back to string Decoded = VBMAN.ToolsUtf8.Decode(Utf8Bytes) Debug.Print "Decoded result: " & Decoded ' Verify Debug.Print "Match: " & (Original = Decoded) ' ===== Operations with BOM ===== Dim Utf8BytesWithBom() As Byte Utf8BytesWithBom = VBMAN.ToolsUtf8.EncodeWithBom(Original) Debug.Print "Bytes with BOM: " & (UBound(Utf8BytesWithBom) + 1) ' Decode data with BOM Decoded = VBMAN.ToolsUtf8.DecodeWithBom(Utf8BytesWithBom) Debug.Print "BOM decode result: " & Decoded End Sub Private Sub Utf8FileDemo() ' Save UTF-8 file (without BOM) Dim Text As String Text = "你好，世界！" Dim Utf8Bytes() As Byte Utf8Bytes = VBMAN.ToolsUtf8.Encode(Text) ' Save using cFileIO VBMAN.FileIO.SetBuffer(Utf8Bytes).SaveData "C:\\utf8_nobom.txt" ' Save UTF-8 file with BOM Dim Utf8BytesWithBom() As Byte Utf8BytesWithBom = VBMAN.ToolsUtf8.EncodeWithBom(Text) VBMAN.FileIO.SetBuffer(Utf8BytesWithBom).SaveData "C:\\utf8_bom.txt" ' Read and decode Dim ReadBytes() As Byte VBMAN.FileIO.OpenFile("C:\\utf8_nobom.txt").ReadData() ReadBytes = VBMAN.FileIO.ReturnBytes() Dim ReadText As String ReadText = VBMAN.ToolsUtf8.Decode(ReadBytes) Debug.Print "Read content: " & ReadText End Sub ``` *** ## Use Cases | Scenario | Example | |----------|---------| | **Network Transmission** | Convert string to UTF-8 bytes for sending | | **File Storage** | Save text with UTF-8 encoding | | **Encryption/Decryption** | Convert to UTF-8 bytes before encryption | | **Data Validation** | Calculate hash of UTF-8 bytes | | **Cross-platform Compatibility** | Use UTF-8 with BOM to ensure Windows programs correctly recognize | *** ## Encoding Comparison | Encoding Method | Advantages | Disadvantages | |-----------------|------------|---------------| | **Encode** | Standard UTF-8, good compatibility | Some Windows programs may not recognize | | **EncodeWithBom** | Windows Notepad and other programs can correctly identify | Additional 3-byte BOM overhead | *** ## Notes 1. **BOM Usage** * Windows Notepad saves UTF-8 files with BOM * Some programs (like some Unix tools) may not recognize BOM * BOM is usually not recommended in web development 2. **Byte Order** * UTF-8 has no byte order issues * UTF-16 has big-endian/little-endian distinction 3. **Memory Usage** * Chinese characters: UTF-8 usually occupies 3 bytes, UTF-16 occupies 2 bytes * ASCII characters: UTF-8 occupies 1 byte, UTF-16 occupies 2 bytes --- --- url: /en/vbman/tools/window.md --- # Tools - Window Utility Class ## cToolsWindow - Window Operation Tools ### Overview Provides window topmost, window switching, forced focus acquisition, and other functionality. ### Methods #### TopMost Sets window to topmost/remove topmost. ```vb Public Sub TopMost(ByVal hWnd As Long, Optional Cancel As Boolean) ``` **Parameters:** | Parameter | Type | Description | |-----------|------|-------------| | `hWnd` | Long | Window handle | | `Cancel` | Boolean | Whether to cancel topmost (default False) | **Example:** ```vb ' Set to topmost VBMAN.ToolsWindow.TopMost Me.hWnd ' Remove topmost VBMAN.ToolsWindow.TopMost Me.hWnd, True ``` #### SwitchToThis Switches to specified window (simulates Alt+Tab effect). ```vb Public Sub SwitchToThis(ByVal hWnd As Long, Optional IsAltTab As Boolean = True) ``` **Example:** ```vb ' Switch to current window VBMAN.ToolsWindow.SwitchToThis Me.hWnd ``` #### ActiveForm Forcibly sets window as foreground window (bypasses system restrictions). ```vb Public Sub ActiveForm(ByVal hWnd As Long) ``` **Description:** This method bypasses Windows restrictions on SetForegroundWindow by simulating Alt key press. It is recommended to call in `Form_LostFocus` event to achieve the effect of window never losing focus. **Example:** ```vb Private Sub Form_LostFocus() ' Force acquire focus VBMAN.ToolsWindow.ActiveForm Me.hWnd End Sub ``` ### Complete Example ```vb Private Sub Form_Load() ' Window topmost VBMAN.ToolsWindow.TopMost Me.hWnd ' Switch to this window VBMAN.ToolsWindow.SwitchToThis Me.hWnd End Sub Private Sub cmdToggleTopmost_Click() Static IsTopmost As Boolean IsTopmost = Not IsTopmost VBMAN.ToolsWindow.TopMost Me.hWnd, Not IsTopmost cmdToggleTopmost.Caption = IIf(IsTopmost, "Remove Topmost", "Set Topmost") End Sub ``` ### Use Cases | Scenario | Method to Use | |----------|---------------| | **Floating Window** | TopMost keeps window on top | | **Popup Notification** | SwitchToThis switches to notification window | | **Modal Dialog** | ActiveForm ensures dialog keeps focus | | **Fullscreen Application** | TopMost + ActiveForm combined | --- --- url: /zh/vbman/tools/README.md --- # Tools 工具类文档索引 本文档汇总了 `src/Tools` 目录下所有类组件的使用说明。 ## 文档列表 | 文档 | 类 | 说明 | |------|-----|------| | [array.md](./array.md) | `cToolsArray`, `cToolsList` | 数组操作、记录集转换 | | [base64.md](./base64.md) | `cToolsBase64` | Base64 编解码 | | [datetime.md](./datetime.md) | `cToolsDateTime`, `cTimeUse`, `cTimer`, `cTimers` | 日期时间、耗时统计、定时器 | | [dic.md](./dic.md) | `cToolsDic` | 字典操作工具 | | [fso.md](./fso.md) | `cToolsFso`, `cFileIO`, `cFileEx`, `cToolsStream` | 文件系统操作 | | [http.md](./http.md) | `cToolsHttp`, `cHttpCrossDomain` | HTTP 编码、跨域配置 | | [math.md](./math.md) | `cToolsMath` | 数学计算工具 | | [password.md](./password.md) | `cPassword` | 密码哈希工具 | | [string.md](./string.md) | `cToolsStr`, `cFormater` | 字符串处理、格式化 | | [utf8.md](./utf8.md) | `cToolsUtf8` | UTF-8 编解码 | | [system.md](./system.md) | `cToolsSystem` | 系统操作工具 | | [window.md](./window.md) | `cToolsWindow` | 窗口操作工具 | | [image.md](./image.md) | `cImage` | 图片数据互转（Byte/Base64/StdPicture） | ## 快速参考 ### 全局访问方式 所有 Tools 类都可通过 `VBMAN` 全局实例访问： ```vb ' 数组工具 VBMAN.ToolsArray.Remove MyArray, 0 ' Base64 编解码 Dim Encoded As String Encoded = VBMAN.ToolsBase64.Encode("Hello") ' 日期时间 Dim Ts As Currency Ts = VBMAN.ToolsDateTime.GetUnixTimestamp() ' 文件系统 VBMAN.ToolsFso.AutoMakeDir "C:\\MyApp\\Logs" ' 字符串格式化 Debug.Print VBMAN.Formater.Data(1024).ReturnFileSize() ' 1.00 KB ' 数学计算 Debug.Print VBMAN.ToolsMath.GetRandRange(1, 100) ' 窗口置顶 VBMAN.ToolsWindow.TopMost Me.hWnd ``` ### 独立实例方式 ```vb ' 创建独立实例 Dim Pwd As New cPassword Pwd.Algorithm = HASH_ALG_SHA256 Dim Hash As String Hash = Pwd.Create("password") ``` ## 已存在的其他文档 * `../Csv/` - CSV 处理（已存在） * `../Ini/` - INI 配置文件（已存在） * `../Json/` - JSON 处理（已存在） --- --- url: /en/vbman/tools/README.md --- # Tools Documentation Index This documentation summarizes usage instructions for all class components in the `src/Tools` directory. ## Documentation List | Document | Class | Description | |----------|-------|-------------| | [array.md](./array.md) | `cToolsArray`, `cToolsList` | Array operations, recordset conversion | | [base64.md](./base64.md) | `cToolsBase64` | Base64 encoding/decoding | | [datetime.md](./datetime.md) | `cToolsDateTime`, `cTimeUse`, `cTimer`, `cTimers` | Date/time, elapsed time, timers | | [dic.md](./dic.md) | `cToolsDic` | Dictionary operation tools | | [fso.md](./fso.md) | `cToolsFso`, `cFileIO`, `cFileEx`, `cToolsStream` | File system operations | | [http.md](./http.md) | `cToolsHttp`, `cHttpCrossDomain` | HTTP encoding, CORS config | | [math.md](./math.md) | `cToolsMath` | Math calculation tools | | [password.md](./password.md) | `cPassword` | Password hash tools | | [string.md](./string.md) | `cToolsStr`, `cFormater` | String processing, formatting | | [utf8.md](./utf8.md) | `cToolsUtf8` | UTF-8 encoding/decoding | | [system.md](./system.md) | `cToolsSystem` | System operation tools | | [window.md](./window.md) | `cToolsWindow` | Window operation tools | | [image.md](./image.md) | `cImage` | Image data conversion (Byte/Base64/StdPicture) | ## Quick Reference ### Global Access All Tools classes can be accessed via `VBMAN` global instance: ```vb ' Array tools VBMAN.ToolsArray.Remove MyArray, 0 ' Base64 encoding/decoding Dim Encoded As String Encoded = VBMAN.ToolsBase64.Encode("Hello") ' Date/time Dim Ts As Currency Ts = VBMAN.ToolsDateTime.GetUnixTimestamp() ' File system VBMAN.ToolsFso.AutoMakeDir "C:\\MyApp\\Logs" ' String formatting Debug.Print VBMAN.Formater.Data(1024).ReturnFileSize() ' 1.00 KB ' Math calculation Debug.Print VBMAN.ToolsMath.GetRandRange(1, 100) ' Window topmost VBMAN.ToolsWindow.TopMost Me.hWnd ``` ### Independent Instance ```vb ' Create independent instance Dim Pwd As New cPassword Pwd.Algorithm = HASH_ALG_SHA256 Dim Hash As String Hash = Pwd.Create("password") ``` ## Other Existing Documentation * `../Csv/` - CSV processing (exists) * `../Ini/` - INI configuration (exists) * `../Json/` - JSON processing (exists) --- --- url: /zh/vbman/tools/fso/ToolsFso.md --- # ToolsFso 模块 FSO 工具模块（当前为占位模块）。 ## 说明 `ToolsFso` 是一个标准 BAS 模块，目前为占位用途，没有实现具体功能。 文件系统相关功能主要在以下类中实现： | 类名 | 说明 | |------|------| | `cToolsFso` | 路径处理、目录管理 | | `cFileIO` | 基于 Win32 API 的文件操作 | | `cFileEx` | 基于 VB Open 语句的文件操作 | | `cToolsStream` | 基于 ADO Stream 的流式操作 | *** ## 相关文档 * [cToolsFso.md](./cToolsFso.md) - 文件系统工具类 * [cFileIO.md](./cFileIO.md) - API 文件操作类 * [cFileEx.md](./cFileEx.md) - VB 原生文件操作类 * [cToolsStream.md](./cToolsStream.md) - ADO Stream 文件操作类 --- --- url: /en/vbman/tools/fso/ToolsFso.md --- # ToolsFso Module FSO utility module (currently a placeholder module). ## Description `ToolsFso` is a standard BAS module, currently for placeholder use, with no specific functionality implemented. File system related functionality is mainly implemented in the following classes: | Class Name | Description | |------------|-------------| | `cToolsFso` | Path processing, directory management | | `cFileIO` | File operations based on Win32 API | | `cFileEx` | File operations based on VB Open statement | | `cToolsStream` | Stream operations based on ADO Stream | *** ## Related Documentation * [cToolsFso.md](./cToolsFso.md) - File System Tools Class * [cFileIO.md](./cFileIO.md) - API File Operations Class * [cFileEx.md](./cFileEx.md) - VB Native File Operations Class * [cToolsStream.md](./cToolsStream.md) - ADO Stream File Operations Class --- --- url: /en/vbman/redis/transaction.md --- # Transaction Operations Redis transactions allow executing multiple commands at once, ensuring atomicity. Commands in a transaction are either all executed or none are executed. ## Multi - Start Transaction ```vb ' Start transaction oRedis.Multi ``` ## Exec - Commit Transaction ```vb ' Commit transaction and get execution results Dim vResults As Variant vResults = oRedis.Exec() If IsArray(vResults) Then Dim i As Long For i = 0 To UBound(vResults) Debug.Print vResults(i) Next End If ``` ## Discard - Cancel Transaction ```vb ' Cancel transaction oRedis.Discard ``` ## Basic Usage ### Simple Transaction Example ```vb Sub SimpleTransaction() Dim oRedis As New cRedisClient If Not oRedis.Connect() Then Debug.Print "Connection failed: " & oRedis.LastError Exit Sub End If ' Start transaction oRedis.Multi ' Execute multiple commands (not executed immediately) oRedis.Set_ "key1", "value1" oRedis.Set_ "key2", "value2" oRedis.Incr "counter" ' Commit transaction Dim vResults As Variant vResults = oRedis.Exec() Debug.Print "Transaction execution results:" If IsArray(vResults) Then For i = 0 To UBound(vResults) Debug.Print " Operation " & (i + 1) & " result: " & vResults(i) Next End If oRedis.DisConnect End Sub ``` ## Use Cases ### 1. Atomic Counter ```vb Sub AtomicCounter() Dim oRedis As New cRedisClient If Not oRedis.Connect() Then Exit Sub ' Initialize counter oRedis.Set_ "counter", "0" Debug.Print "Initial count: " & oRedis.Get_("counter") ' Start transaction oRedis.Multi ' Execute multiple increment operations oRedis.Incr "counter" oRedis.Incr "counter" oRedis.Incr "counter" ' Commit transaction Dim vResults As Variant vResults = oRedis.Exec() Debug.Print vbCrLf & "Transaction execution results:" If IsArray(vResults) Then For i = 0 To UBound(vResults) Debug.Print " Operation " & (i + 1) & " result: " & vResults(i) Next End If Debug.Print "Final count: " & oRedis.Get_("counter") oRedis.DisConnect End Sub ``` ### 2. Bank Transfer ```vb Sub BankTransfer() Dim oRedis As New cRedisClient If Not oRedis.Connect() Then Exit Sub ' Initialize account balances oRedis.Set_ "account:A", "1000" oRedis.Set_ "account:B", "500" Debug.Print "Before transfer:" Debug.Print " Account A: " & oRedis.Get_("account:A") Debug.Print " Account B: " & oRedis.Get_("account:B") Dim lAmount As Long lAmount = 200 ' Start transaction oRedis.Multi ' Deduct from account A oRedis.DecrBy "account:A", lAmount ' Add to account B oRedis.IncrBy "account:B", lAmount ' Commit transaction Dim vResults As Variant vResults = oRedis.Exec() Debug.Print vbCrLf & "After transfer:" Debug.Print " Account A: " & oRedis.Get_("account:A") Debug.Print " Account B: " & oRedis.Get_("account:B") oRedis.DisConnect End Sub ``` ### 3. Batch Update ```vb Sub BatchUpdate() Dim oRedis As New cRedisClient If Not oRedis.Connect() Then Exit Sub ' Start transaction oRedis.Multi ' Batch set multiple keys oRedis.Set_ "user:1", "Zhang San" oRedis.Set_ "user:2", "Li Si" oRedis.Set_ "user:3", "Wang Wu" oRedis.Set_ "user:4", "Zhao Liu" oRedis.Set_ "user:5", "Qian Qi" ' Batch set expiration times oRedis.Expire "user:1", 3600 oRedis.Expire "user:2", 3600 oRedis.Expire "user:3", 3600 oRedis.Expire "user:4", 3600 oRedis.Expire "user:5", 3600 ' Commit transaction Dim vResults As Variant vResults = oRedis.Exec() Debug.Print "Batch update completed, executed " & (UBound(vResults) + 1) & " operations" oRedis.DisConnect End Sub ``` ### 4. Conditional Update ```vb Sub ConditionalUpdate() Dim oRedis As New cRedisClient If Not oRedis.Connect() Then Exit Sub ' Initialize stock oRedis.Set_ "product:1001:stock", "10" Debug.Print "Initial stock: " & oRedis.Get_("product:1001:stock") Dim lBuyAmount As Long lBuyAmount = 3 ' Check if stock is sufficient Dim lCurrentStock As Long lCurrentStock = CLng(oRedis.Get_("product:1001:stock")) If lCurrentStock >= lBuyAmount Then ' Stock sufficient, start transaction oRedis.Multi ' Reduce stock oRedis.DecrBy "product:1001:stock", lBuyAmount ' Increase sales oRedis.IncrBy "product:1001:sold", lBuyAmount ' Record sales log oRedis.RPush "sales:log", "Sold " & lBuyAmount & " items" ' Commit transaction Dim vResults As Variant vResults = oRedis.Exec() Debug.Print vbCrLf & "Purchase successful!" Debug.Print "Remaining stock: " & oRedis.Get_("product:1001:stock") Debug.Print "Total sold: " & oRedis.Get_("product:1001:sold") Else Debug.Print "Insufficient stock, cannot purchase" End If oRedis.DisConnect End Sub ``` ### 5. Data Consistency Check ```vb Sub DataConsistency() Dim oRedis As New cRedisClient If Not oRedis.Connect() Then Exit Sub ' Initialize data oRedis.HSet "order:1001", "amount", "100" oRedis.HSet "order:1001", "status", "pending" oRedis.HSet "order:1001", "user", "user:123" oRedis.HSet "user:123", "balance", "500" ' Start transaction oRedis.Multi ' Get order amount oRedis.HGet "order:1001", "amount" ' Get user balance oRedis.HGet "user:123", "balance" ' Execute transaction to get data Dim vResults As Variant vResults = oRedis.Exec() ' Check if balance is sufficient If IsArray(vResults) And UBound(vResults) >= 1 Then Dim lOrderAmount As Long Dim lUserBalance As Long lOrderAmount = CLng(vResults(0)) lUserBalance = CLng(vResults(1)) If lUserBalance >= lOrderAmount Then ' Balance sufficient, execute payment oRedis.Multi ' Deduct user balance oRedis.HSet "user:123", "balance", CStr(lUserBalance - lOrderAmount) ' Update order status oRedis.HSet "order:1001", "status", "paid" ' Record payment log oRedis.RPush "payment:log", "Order 1001 payment " & lOrderAmount ' Commit transaction vResults = oRedis.Exec() Debug.Print "Payment successful" Debug.Print "Remaining balance: " & oRedis.HGet("user:123", "balance") Debug.Print "Order status: " & oRedis.HGet("order:1001", "status") Else Debug.Print "Insufficient balance, payment failed" End If End If oRedis.DisConnect End Sub ``` ### 6. Cancel Transaction ```vb Sub CancelTransaction() Dim oRedis As New cRedisClient If Not oRedis.Connect() Then Exit Sub ' Initialize data oRedis.Set_ "counter", "10" Debug.Print "Initial value: " & oRedis.Get_("counter") ' Start transaction oRedis.Multi ' Execute multiple operations oRedis.Incr "counter" oRedis.Incr "counter" oRedis.Incr "counter" ' Cancel transaction oRedis.Discard Debug.Print "Value after canceling transaction: " & oRedis.Get_("counter") oRedis.DisConnect End Sub ``` ## Transaction Features ### 1. Atomicity Commands in a transaction are either all executed or none are executed: ```vb Sub AtomicityExample() Dim oRedis As New cRedisClient If Not oRedis.Connect() Then Exit Sub oRedis.Multi ' These commands either all succeed or all fail oRedis.Set_ "key1", "value1" oRedis.Set_ "key2", "value2" oRedis.Set_ "key3", "value3" oRedis.Exec oRedis.DisConnect End Sub ``` ### 2. Isolation During transaction execution, other clients cannot see intermediate states: ```vb Sub IsolationExample() Dim oRedis As New cRedisClient If Not oRedis.Connect() Then Exit Sub ' Set initial value oRedis.Set_ "balance", "100" ' Start transaction oRedis.Multi ' Decrease balance (other clients still see 100 at this point) oRedis.Decr "balance" ' Can do other operations here... ' Commit transaction (other clients can now see changes) oRedis.Exec oRedis.DisConnect End Sub ``` ## Notes 1. **No Rollback**: Redis transactions do not support rollback; even if a command fails, other commands will still be executed 2. **Error Handling**: Validate parameters before executing transaction 3. **Performance Consideration**: Transactions block other operations, avoid long-running transactions 4. **Nested Transactions**: Redis does not support nested transactions 5. **Optimistic Locking**: Can use `WATCH` command to implement optimistic locking (requires extended implementation) ## Complete Example ```vb Sub Example_Transaction() Dim oRedis As New cRedisClient If Not oRedis.Connect() Then Debug.Print "Connection failed: " & oRedis.LastError Exit Sub End If ' Initialize counter oRedis.Set_ "counter", "0" Debug.Print "Initial count: " & oRedis.Get_("counter") ' Start transaction oRedis.Multi ' Execute multiple increment operations oRedis.Incr "counter" oRedis.Incr "counter" oRedis.Incr "counter" ' Commit transaction Dim vResults As Variant vResults = oRedis.Exec() Debug.Print "Transaction execution results:" If IsArray(vResults) Then For i = 0 To UBound(vResults) Debug.Print " Operation " & (i + 1) & " result: " & vResults(i) Next End If Debug.Print "Final count: " & oRedis.Get_("counter") oRedis.DisConnect End Sub ``` ## Transaction vs Single Command | Scenario | Recommended Method | Reason | | ----------------------- | ----------------- | ----------------------------------------- | | Single operation | Single command | Simple and direct | | Multiple related ops | Transaction | Ensure atomicity | | Unrelated operations | Single command | Reduce blocking | | Need intermediate results | Step-by-step | More flexible | | Batch update | Transaction or batch commands | Improve performance | --- --- url: /en/vbman/database/transaction.md --- # Transaction Processing This document details the transaction processing features of the cDataBase class, including transaction start, commit, rollback, etc. *** ## Table of Contents * [Transaction Overview](#transaction-overview) * [Transaction Methods](#transaction-methods) * [Basic Usage](#basic-usage) * [Error Handling](#error-handling) * [Nested Transactions](#nested-transactions) * [Best Practices](#best-practices) *** ## Transaction Overview ### What is a Transaction A transaction is a set of database operations that either all succeed or all fail. Transactions have the following characteristics (ACID): * **Atomicity** - All operations in a transaction either execute completely or not at all * **Consistency** - Database maintains consistent state before and after transaction execution * **Isolation** - Concurrent transactions are isolated from each other * **Durability** - After transaction commit, data is permanently saved ### Transaction States ``` Start Transaction │ ▼ Execute Operation 1 │ ▼ Execute Operation 2 │ ▼ Execute Operation 3 │ ▼ Commit Transaction ──→ Success: All operations take effect │ └──→ Failure: Auto rollback, all operations reverted ``` *** ## Transaction Methods ### TransBegin Method The `TransBegin` method starts a new transaction. #### Syntax ```vb Function TransBegin() As Boolean ``` #### Return Value * `True` - Transaction started successfully * `False` - Transaction start failed (view error via `LastErr`) #### Example ```vb ' Start transaction If db.TransBegin Then Debug.Print "Transaction started" Else Debug.Print "Transaction start failed: " & db.LastErr End If ``` ### TransCommit Method The `TransCommit` method commits a transaction. #### Syntax ```vb Function TransCommit() As Boolean ``` #### Functionality * Commit all operations in the transaction * If commit fails, auto rollback * Clear transaction flag #### Return Value * `True` - Commit successful * `False` - Commit failed (already auto rolled back) #### Example ```vb ' Commit transaction If db.TransCommit Then Debug.Print "Transaction committed successfully" Else Debug.Print "Transaction commit failed, auto rolled back: " & db.LastErr End If ``` ### TransRollback Method The `TransRollback` method rolls back a transaction. #### Syntax ```vb Function TransRollback() As Boolean ``` #### Functionality * Revert all operations in the transaction * Clear transaction flag #### Return Value * `True` - Rollback successful * `False` - Rollback failed (view error via `LastErr`) #### Example ```vb ' Rollback transaction If db.TransRollback Then Debug.Print "Transaction rolled back" Else Debug.Print "Rollback failed: " & db.LastErr End If ``` *** ## Basic Usage ### Example 1: Simple Transaction ```vb ' Start transaction If db.TransBegin Then ' Execute operation 1 If db.Sql("INSERT INTO users (name) VALUES ('John')").Exec Then ' Execute operation 2 If db.Sql("INSERT INTO posts (user_id, title) VALUES (1, 'Title')").Exec Then ' Commit transaction If db.TransCommit Then Debug.Print "Transaction committed successfully" Else Debug.Print "Commit failed, auto rolled back" End If Else ' Operation 2 failed, rollback db.TransRollback End If Else ' Operation 1 failed, rollback db.TransRollback End If End If ``` ### Example 2: Using Error Handling ```vb On Error GoTo ErrHandler ' Start transaction If Not db.TransBegin Then Debug.Print "Transaction start failed: " & db.LastErr Exit Sub End If ' Execute multiple operations db.Sql("INSERT INTO users (name) VALUES ('John')").Exec db.Sql("INSERT INTO users (name) VALUES ('Mary')").Exec db.Sql("UPDATE users SET status = 'active' WHERE name = 'John'").Exec ' Commit transaction If db.TransCommit Then Debug.Print "All operations successful" Else Debug.Print "Commit failed: " & db.LastErr End If Exit Sub ErrHandler: ' Error occurred, rollback transaction db.TransRollback Debug.Print "Error occurred, transaction rolled back: " & Err.Description ``` ### Example 3: Transfer Operation ```vb ' Transfer operation: Transfer 100 from account A to account B Function TransferMoney(lFromAccount As Long, lToAccount As Long, dAmount As Double) As Boolean On Error GoTo ErrHandler ' Start transaction If Not db.TransBegin Then TransferMoney = False Exit Function End If ' Deduct amount from account A Dim sSql As String sSql = "UPDATE accounts SET balance = balance - " & dAmount & _ " WHERE id = " & lFromAccount & " AND balance >= " & dAmount If Not db.Sql(sSql).Exec Then db.TransRollback TransferMoney = False Exit Function End If ' Check if records were updated Dim lAffected As Long If db.Sql("SELECT @@ROWCOUNT").Query Then If db.Rs.EOF Or db.Rs(0) = 0 Then db.TransRollback TransferMoney = False Exit Function End If End If ' Add amount to account B sSql = "UPDATE accounts SET balance = balance + " & dAmount & _ " WHERE id = " & lToAccount If Not db.Sql(sSql).Exec Then db.TransRollback TransferMoney = False Exit Function End If ' Log transfer sSql = "INSERT INTO transfers (from_account, to_account, amount) VALUES (" & _ lFromAccount & ", " & lToAccount & ", " & dAmount & ")" If Not db.Sql(sSql).Exec Then db.TransRollback TransferMoney = False Exit Function End If ' Commit transaction If db.TransCommit Then TransferMoney = True Else TransferMoney = False End If Exit Function ErrHandler: db.TransRollback TransferMoney = False End Function ``` *** ## Error Handling ### Auto Rollback Mechanism The library provides an auto rollback mechanism: 1. **Auto rollback on commit failure** - `TransCommit` automatically calls `TransRollback` when failed 2. **Auto rollback on disconnect** - `Disconnect` automatically rolls back incomplete transactions ```vb ' Auto rollback on commit failure If db.TransBegin Then db.Sql("INSERT INTO users (name) VALUES ('John')").Exec ' If commit fails, auto rollback If Not db.TransCommit Then Debug.Print "Commit failed, auto rolled back: " & db.LastErr End If End If ``` ### Error Handling Example ```vb Function ExecuteTransaction() As Boolean On Error GoTo ErrHandler ' Start transaction If Not db.TransBegin Then Debug.Print "Transaction start failed: " & db.LastErr ExecuteTransaction = False Exit Function End If ' Execute operation If Not db.Sql("INSERT INTO users (name) VALUES ('John')").Exec Then db.TransRollback Debug.Print "Operation failed: " & db.LastErr ExecuteTransaction = False Exit Function End If ' Commit transaction If db.TransCommit Then ExecuteTransaction = True Else Debug.Print "Commit failed: " & db.LastErr ExecuteTransaction = False End If Exit Function ErrHandler: ' Exception occurred, rollback transaction db.TransRollback Debug.Print "Exception occurred, rolled back: " & Err.Description ExecuteTransaction = False End Function ``` *** ## Nested Transactions ### Notes ADO supports nested transactions, but needs attention: 1. **Nesting levels** - ADO supports multi-level nested transactions 2. **Commit order** - Must commit in reverse order (inner first) 3. **Rollback impact** - Rollback affects all nesting levels ### Nested Transaction Example ```vb ' Outer transaction If db.TransBegin Then db.Sql("INSERT INTO users (name) VALUES ('User1')").Exec ' Inner transaction (nested) If db.TransBegin Then db.Sql("INSERT INTO posts (user_id, title) VALUES (1, 'Title1')").Exec ' Commit inner transaction If db.TransCommit Then Debug.Print "Inner transaction committed successfully" End If End If ' Commit outer transaction If db.TransCommit Then Debug.Print "Outer transaction committed successfully" End If End If ``` *** ## Best Practices ### 1. Always Use Transactions for Multiple Related Operations ```vb ' Recommended: Use transactions to ensure consistency db.TransBegin db.Sql("INSERT INTO users (name) VALUES ('John')").Exec db.Sql("INSERT INTO posts (user_id, title) VALUES (1, 'Title')").Exec db.TransCommit ' Not recommended: Without transactions db.Sql("INSERT INTO users (name) VALUES ('John')").Exec db.Sql("INSERT INTO posts (user_id, title) VALUES (1, 'Title')").Exec ' If second operation fails, first operation already committed, data inconsistent ``` ### 2. Check Return Value of Each Operation ```vb ' Recommended: Check each operation db.TransBegin If Not db.Sql("INSERT INTO users (name) VALUES ('John')").Exec Then db.TransRollback Exit Sub End If If Not db.Sql("INSERT INTO posts (user_id, title) VALUES (1, 'Title')").Exec Then db.TransRollback Exit Sub End If db.TransCommit ``` ### 3. Use Error Handling ```vb ' Recommended: Use error handling On Error GoTo ErrHandler db.TransBegin db.Sql("INSERT INTO users (name) VALUES ('John')").Exec db.Sql("INSERT INTO posts (user_id, title) VALUES (1, 'Title')").Exec db.TransCommit Exit Sub ErrHandler: db.TransRollback Debug.Print "Error: " & Err.Description ``` ### 4. Commit or Rollback Promptly ```vb ' Recommended: Commit or rollback immediately after operations db.TransBegin ' ... execute operations ... db.TransCommit ' Or db.TransRollback ' Not recommended: Keep transaction open for long time db.TransBegin ' ... execute operations ... ' Wait for user input (transaction remains open) ' ... db.TransCommit ``` ### 5. Use Transactions for Batch Operations ```vb ' Recommended: Use transactions for batch operations db.TransBegin Dim i As Long For i = 1 To 1000 If Not db.Sql("INSERT INTO users (name) VALUES ('User" & i & "')").Exec Then db.TransRollback Exit For End If Next If i > 1000 Then db.TransCommit End If ``` *** ## Common Questions ### Q1: Data not saved after transaction commit? **Cause**: Database may not support transactions, or connection string configuration issue. **Solution**: * Check if database type supports transactions * Verify connection string configuration ### Q2: How to check transaction status? ```vb ' Note: Library internally uses IsTrans flag but does not expose it ' Can check by attempting to commit If db.TransCommit Then Debug.Print "Transaction exists and committed successfully" Else Debug.Print "No transaction or commit failed" End If ``` ### Q3: Do transactions affect performance? **Answer**: Yes, transactions lock resources and affect concurrent performance. **Recommendations**: * Minimize transaction duration * Only include necessary operations * Avoid long operations in transactions *** **Last Updated**: 2026-01-21 --- --- url: /en/packages/vbccr/views/treeview.md description: >- TreeView Control - VBCCR Developer Reference, complete API documentation based on source code --- # TreeView Control Provides a hierarchical tree display of data, supporting node expand/collapse, checkboxes, multi-select, image lists, label editing, sorting, and OLE drag-and-drop. ## Enumerations ### TvwStyleConstants Tree view style constants. | Constant | Value | Description | |----------|-------|-------------| | TvwStyleTextOnly | 0 | Text only | | TvwStylePictureText | 1 | Picture and text | | TvwStylePlusMinusText | 2 | Plus/minus signs and text | | TvwStylePlusMinusPictureText | 3 | Plus/minus signs, picture, and text | | TvwStyleTreeLinesText | 4 | Tree lines and text | | TvwStyleTreeLinesPictureText | 5 | Tree lines, picture, and text | | TvwStyleTreeLinesPlusMinusText | 6 | Tree lines, plus/minus signs, and text | | TvwStyleTreeLinesPlusMinusPictureText | 7 | Tree lines, plus/minus signs, picture, and text | ### TvwLineStyleConstants Line style constants. | Constant | Value | Description | |----------|-------|-------------| | TvwLineStyleTreeLines | 0 | Show tree lines | | TvwLineStyleRootLines | 1 | Show root lines (lines shown between root nodes as well) | ### TvwLabelEditConstants Label edit mode constants. | Constant | Value | Description | |----------|-------|-------------| | TvwLabelEditAutomatic | 0 | Automatic label edit (click to select, click again to edit) | | TvwLabelEditManual | 1 | Manual label edit (requires code to call StartLabelEdit) | | TvwLabelEditDisabled | 2 | Label edit disabled | ### TvwNodeRelationshipConstants Node relationship constants, used by the Add and Move methods. | Constant | Value | Description | |----------|-------|-------------| | TvwNodeFirst | 0 | First node | | TvwNodeLast | 1 | Last node | | TvwNodeNext | 2 | Next node (same level) | | TvwNodePrevious | 3 | Previous node (same level) | | TvwNodeChild | 4 | Child node | ### TvwSortOrderConstants Sort order constants. | Constant | Value | Description | |----------|-------|-------------| | TvwSortAscending | 0 | Ascending order | | TvwSortDescending | 1 | Descending order | ### TvwSortTypeConstants Sort type constants. | Constant | Value | Description | |----------|-------|-------------| | TvwSortBinary | 0 | Binary sort (case-sensitive) | | TvwSortText | 1 | Text sort (case-insensitive) | ### TvwMultiSelectConstants Multi-select mode constants. | Constant | Value | Description | |----------|-------|-------------| | TvwMultiSelectNone | 0 | Multi-select not allowed | | TvwMultiSelectAll | 1 | Allow selecting all nodes | | TvwMultiSelectVisibleOnly | 2 | Allow selecting visible nodes only | | TvwMultiSelectRestrictSiblings | 3 | Allow selecting sibling nodes only | ### TvwVisualThemeConstants Visual theme constants. | Constant | Value | Description | |----------|-------|-------------| | TvwVisualThemeStandard | 0 | Standard theme | | TvwVisualThemeExplorer | 1 | Explorer theme | ## Properties ### Name ```vb Public Property Get Name() As String ``` Returns the name used to identify the object in code. ### Tag ```vb Public Property Get Tag() As String Public Property Let Tag(ByVal Value As String) ``` Stores extra data needed by the program. ### Parent ```vb Public Property Get Parent() As Object ``` Returns the object that contains this object. ### Container ```vb Public Property Get Container() As Object Public Property Set Container(ByVal Value As Object) ``` Returns/sets the object's container. ### Left ```vb Public Property Get Left() As Single Public Property Let Left(ByVal Value As Single) ``` Returns/sets the distance between the object and the left edge of its container. ### Top ```vb Public Property Get Top() As Single Public Property Let Top(ByVal Value As Single) ``` Returns/sets the distance between the object and the top edge of its container. ### Width ```vb Public Property Get Width() As Single Public Property Let Width(ByVal Value As Single) ``` Returns/sets the width of the object. ### Height ```vb Public Property Get Height() As Single Public Property Let Height(ByVal Value As Single) ``` Returns/sets the height of the object. ### Visible ```vb Public Property Get Visible() As Boolean Public Property Let Visible(ByVal Value As Boolean) ``` Returns/sets whether the object is visible. ### ToolTipText ```vb Public Property Get ToolTipText() As String Public Property Let ToolTipText(ByVal Value As String) ``` Returns/sets the tooltip text displayed when the mouse hovers over the control. ### HelpContextID ```vb Public Property Get HelpContextID() As Long Public Property Let HelpContextID(ByVal Value As Long) ``` Returns/sets the help context ID. ### WhatsThisHelpID ```vb Public Property Get WhatsThisHelpID() As Long Public Property Let WhatsThisHelpID(ByVal Value As Long) ``` Returns/sets the associated context-sensitive help ID. ### Align ```vb Public Property Get Align() As Integer Public Property Let Align(ByVal Value As Integer) ``` Returns/sets the alignment of the control on its form. ### DragIcon ```vb Public Property Get DragIcon() As IPictureDisp Public Property Let DragIcon(ByVal Value As IPictureDisp) Public Property Set DragIcon(ByVal Value As IPictureDisp) ``` Returns/sets the icon displayed during a drag-and-drop operation. ### DragMode ```vb Public Property Get DragMode() As Integer Public Property Let DragMode(ByVal Value As Integer) ``` Returns/sets the drag mode. ### hWnd ```vb Public Property Get hWnd() As LongPtr ``` Returns the control handle. ### hWndUserControl ```vb Public Property Get hWndUserControl() As LongPtr ``` Returns the UserControl handle. ### hWndLabelEdit ```vb Public Property Get hWndLabelEdit() As LongPtr ``` Returns the label edit box handle. ### Font ```vb Public Property Get Font() As StdFont Public Property Let Font(ByVal NewFont As StdFont) Public Property Set Font(ByVal NewFont As StdFont) ``` Returns/sets the font. ### VisualStyles ```vb Public Property Get VisualStyles() As Boolean Public Property Let VisualStyles(ByVal Value As Boolean) ``` Returns/sets whether visual styles are enabled. Requires comctl32.dll 6.0 or later. ### VisualTheme ```vb Public Property Get VisualTheme() As TvwVisualThemeConstants Public Property Let VisualTheme(ByVal Value As TvwVisualThemeConstants) ``` Returns/sets the visual theme. ### Enabled ```vb Public Property Get Enabled() As Boolean Public Property Let Enabled(ByVal Value As Boolean) ``` Returns/sets whether the object can respond to user-generated events. ### OLEDragMode ```vb Public Property Get OLEDragMode() As VBRUN.OLEDragConstants Public Property Let OLEDragMode(ByVal Value As VBRUN.OLEDragConstants) ``` Returns/sets the OLE drag mode. ### OLEDragDropScroll ```vb Public Property Get OLEDragDropScroll() As Boolean Public Property Let OLEDragDropScroll(ByVal Value As Boolean) ``` Returns/sets whether automatic scrolling is enabled during OLE drag-and-drop. ### OLEDragExpandTime ```vb Public Property Get OLEDragExpandTime() As Long Public Property Let OLEDragExpandTime(ByVal Value As Long) ``` Returns/sets the hover duration before expanding a node during OLE drag-and-drop (milliseconds). ### OLEDropMode ```vb Public Property Get OLEDropMode() As OLEDropModeConstants Public Property Let OLEDropMode(ByVal Value As OLEDropModeConstants) ``` Returns/sets whether the object can act as an OLE drop target. ### MousePointer ```vb Public Property Get MousePointer() As CCMousePointerConstants Public Property Let MousePointer(ByVal Value As CCMousePointerConstants) ``` Returns/sets the pointer type displayed when the mouse hovers over the control. See common enumerations. ### MouseIcon ```vb Public Property Get MouseIcon() As IPictureDisp Public Property Let MouseIcon(ByVal Value As IPictureDisp) Public Property Set MouseIcon(ByVal Value As IPictureDisp) ``` Returns/sets the custom mouse icon. ### MouseTrack ```vb Public Property Get MouseTrack() As Boolean Public Property Let MouseTrack(ByVal Value As Boolean) ``` Returns/sets whether events are raised when the mouse enters or leaves the control. ### RightToLeft ```vb Public Property Get RightToLeft() As Boolean Public Property Let RightToLeft(ByVal Value As Boolean) ``` Returns/sets the right-to-left display direction. ### RightToLeftLayout ```vb Public Property Get RightToLeftLayout() As Boolean Public Property Let RightToLeftLayout(ByVal Value As Boolean) ``` Returns/sets the right-to-left layout. ### RightToLeftMode ```vb Public Property Get RightToLeftMode() As CCRightToLeftModeConstants Public Property Let RightToLeftMode(ByVal Value As CCRightToLeftModeConstants) ``` Returns/sets the right-to-left mode. See common enumerations. ### ImageList ```vb Public Property Get ImageList() As Variant Public Property Let ImageList(ByVal Value As Variant) Public Property Set ImageList(ByVal Value As Variant) ``` Returns/sets the associated ImageList control. Can be an object reference, a string key name, or a LongPtr handle. ### BorderStyle ```vb Public Property Get BorderStyle() As CCBorderStyleConstants Public Property Let BorderStyle(ByVal Value As CCBorderStyleConstants) ``` Returns/sets the border style. See common enumerations. ### BackColor ```vb Public Property Get BackColor() As OLE_COLOR Public Property Let BackColor(ByVal Value As OLE_COLOR) ``` Returns/sets the background color. ### ForeColor ```vb Public Property Get ForeColor() As OLE_COLOR Public Property Let ForeColor(ByVal Value As OLE_COLOR) ``` Returns/sets the foreground color. ### Redraw ```vb Public Property Get Redraw() As Boolean Public Property Let Redraw(ByVal Value As Boolean) ``` Returns/sets whether redrawing is enabled. Disabling can accelerate bulk operations. ### Style ```vb Public Property Get Style() As TvwStyleConstants Public Property Let Style(ByVal Value As TvwStyleConstants) ``` Returns/sets the tree view style. ### LineStyle ```vb Public Property Get LineStyle() As TvwLineStyleConstants Public Property Let LineStyle(ByVal Value As TvwLineStyleConstants) ``` Returns/sets the line style. ### LineColor ```vb Public Property Get LineColor() As OLE_COLOR Public Property Let LineColor(ByVal Value As OLE_COLOR) ``` Returns/sets the line color. ### LabelEdit ```vb Public Property Get LabelEdit() As TvwLabelEditConstants Public Property Let LabelEdit(ByVal Value As TvwLabelEditConstants) ``` Returns/sets the label edit mode. ### Checkboxes ```vb Public Property Get Checkboxes() As Boolean Public Property Let Checkboxes(ByVal Value As Boolean) ``` Returns/sets whether checkboxes are displayed next to nodes. ### ShowTips ```vb Public Property Get ShowTips() As Boolean Public Property Let ShowTips(ByVal Value As Boolean) ``` Returns/sets whether tooltips are displayed. ### HideSelection ```vb Public Property Get HideSelection() As Boolean Public Property Let HideSelection(ByVal Value As Boolean) ``` Returns/sets whether the selection highlight is hidden when the control loses focus. ### FullRowSelect ```vb Public Property Get FullRowSelect() As Boolean Public Property Let FullRowSelect(ByVal Value As Boolean) ``` Returns/sets whether full row selection is enabled. ### HotTracking ```vb Public Property Get HotTracking() As Boolean Public Property Let HotTracking(ByVal Value As Boolean) ``` Returns/sets whether hot tracking is enabled. ### Indentation ```vb Public Property Get Indentation() As Single Public Property Let Indentation(ByVal Value As Single) ``` Returns/sets the child node indentation amount. ### PathSeparator ```vb Public Property Get PathSeparator() As String Public Property Let PathSeparator(ByVal Value As String) ``` Returns/sets the path separator used by the FullPath property. ### Scroll ```vb Public Property Get Scroll() As Boolean Public Property Let Scroll(ByVal Value As Boolean) ``` Returns/sets whether scroll bars are displayed. ### SingleSel ```vb Public Property Get SingleSel() As Boolean Public Property Let SingleSel(ByVal Value As Boolean) ``` Returns/sets whether clicking a node expands it and collapses other nodes. ### Sorted ```vb Public Property Get Sorted() As Boolean Public Property Let Sorted(ByVal Value As Boolean) ``` Returns/sets whether root nodes are sorted. ### SortOrder ```vb Public Property Get SortOrder() As TvwSortOrderConstants Public Property Let SortOrder(ByVal Value As TvwSortOrderConstants) ``` Returns/sets the sort order. ### SortType ```vb Public Property Get SortType() As TvwSortTypeConstants Public Property Let SortType(ByVal Value As TvwSortTypeConstants) ``` Returns/sets the sort type. ### InsertMarkColor ```vb Public Property Get InsertMarkColor() As OLE_COLOR Public Property Let InsertMarkColor(ByVal Value As OLE_COLOR) ``` Returns/sets the insert mark color. ### DoubleBuffer ```vb Public Property Get DoubleBuffer() As Boolean Public Property Let DoubleBuffer(ByVal Value As Boolean) ``` Returns/sets whether double-buffered drawing is enabled. ### IMEMode ```vb Public Property Get IMEMode() As CCIMEModeConstants Public Property Let IMEMode(ByVal Value As CCIMEModeConstants) ``` Returns/sets the input method editor mode. See common enumerations. ### MultiSelect ```vb Public Property Get MultiSelect() As TvwMultiSelectConstants Public Property Let MultiSelect(ByVal Value As TvwMultiSelectConstants) ``` Returns/sets the multi-select mode. ### Nodes ```vb Public Property Get Nodes() As TvwNodes ``` Returns the nodes collection. ## Methods ### OLEDrag ```vb Public Sub OLEDrag() ``` Initiates an OLE drag-and-drop operation. ### Drag ```vb Public Sub Drag(Optional ByRef Action As Variant) ``` Starts, ends, or cancels a drag operation. ### SetFocus ```vb Public Sub SetFocus() ``` Moves focus to the specified object. ### ZOrder ```vb Public Sub ZOrder(Optional ByRef Position As Variant) ``` Sets the Z-order. ### Refresh ```vb Public Sub Refresh() ``` Forces a complete redraw of the object. ## Events ### Click ```vb Public Event Click() ``` Raised when the user clicks the control. ### DblClick ```vb Public Event DblClick() ``` Raised when the user double-clicks the control. ### NodeClick ```vb Public Event NodeClick(ByVal Node As TvwNode, ByVal Button As Integer) ``` Raised when the user clicks a node. Button indicates the mouse button. ### NodeDblClick ```vb Public Event NodeDblClick(ByVal Node As TvwNode, ByVal Button As Integer) ``` Raised when the user double-clicks a node. ### NodeBeforeCheck ```vb Public Event NodeBeforeCheck(ByVal Node As TvwNode, ByRef Cancel As Boolean) ``` Raised before a node's checkbox is about to change. Set Cancel to True to cancel the operation. ### NodeCheck ```vb Public Event NodeCheck(ByVal Node As TvwNode) ``` Raised after a node's checkbox state has changed. ### NodeDrag ```vb Public Event NodeDrag(ByVal Node As TvwNode, ByVal Button As Integer) ``` Raised when the user drags a node. ### NodeBeforeSelect ```vb Public Event NodeBeforeSelect(ByVal Node As TvwNode, ByRef Cancel As Boolean) ``` Raised before a node is about to be selected. Set Cancel to True to cancel the selection. ### NodeSelect ```vb Public Event NodeSelect(ByVal Node As TvwNode) ``` Raised after a node has been selected. ### NodeRangeSelect ```vb Public Event NodeRangeSelect(ByVal Node As TvwNode, ByRef Cancel As Boolean) ``` Raised during a range selection. Set Cancel to True to cancel. ### BeforeCollapse ```vb Public Event BeforeCollapse(ByVal Node As TvwNode, ByRef Cancel As Boolean) ``` Raised before a node is about to collapse. Set Cancel to True to cancel the collapse. ### Collapse ```vb Public Event Collapse(ByVal Node As TvwNode) ``` Raised after a node has collapsed. ### BeforeExpand ```vb Public Event BeforeExpand(ByVal Node As TvwNode, ByRef Cancel As Boolean) ``` Raised before a node is about to expand. Set Cancel to True to cancel the expansion. ### Expand ```vb Public Event Expand(ByVal Node As TvwNode) ``` Raised after a node has expanded. ### BeforeLabelEdit ```vb Public Event BeforeLabelEdit(ByRef Cancel As Boolean) ``` Raised before a label is about to be edited. Set Cancel to True to cancel the edit. ### AfterLabelEdit ```vb Public Event AfterLabelEdit(ByRef Cancel As Boolean, ByRef NewString As String) ``` Raised after label editing is complete. Set Cancel to True to cancel the modification; NewString is the edited text. ### PreviewKeyDown ```vb Public Event PreviewKeyDown(ByVal KeyCode As Integer, ByRef IsInputKey As Boolean) ``` Key preview event. Set IsInputKey to True to mark the key as an input key. ### PreviewKeyUp ```vb Public Event PreviewKeyUp(ByVal KeyCode As Integer, ByRef IsInputKey As Boolean) ``` Key release preview event. ### KeyDown ```vb Public Event KeyDown(KeyCode As Integer, Shift As Integer) ``` Raised when a keyboard key is pressed. ### KeyUp ```vb Public Event KeyUp(KeyCode As Integer, Shift As Integer) ``` Raised when a keyboard key is released. ### KeyPress ```vb Public Event KeyPress(KeyChar As Integer) ``` Raised when an ANSI key is pressed and released. ### MouseDown ```vb Public Event MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` Raised when a mouse button is pressed. ### MouseMove ```vb Public Event MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` Raised when the mouse is moved. ### MouseUp ```vb Public Event MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` Raised when a mouse button is released. ### MouseEnter ```vb Public Event MouseEnter() ``` Raised when the mouse enters the control area. ### MouseLeave ```vb Public Event MouseLeave() ``` Raised when the mouse leaves the control area. ### OLECompleteDrag ```vb Public Event OLECompleteDrag(Effect As Long) ``` Raised when an OLE drag-and-drop operation is completed. ### OLEDragDrop ```vb Public Event OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single) ``` Raised when an OLE drag-and-drop operation is dropped. ### OLEDragOver ```vb Public Event OLEDragOver(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single, State As Integer) ``` Raised during an OLE drag-and-drop hover. ### OLEGiveFeedback ```vb Public Event OLEGiveFeedback(Effect As Long, DefaultCursors As Boolean) ``` Raised when OLE drag-and-drop gives feedback. ### OLESetData ```vb Public Event OLESetData(Data As DataObject, DataFormat As Integer) ``` Raised when OLE drag-and-drop sets data. ### OLEStartDrag ```vb Public Event OLEStartDrag(Data As DataObject, AllowedEffects As Long) ``` Raised when an OLE drag-and-drop operation starts. ## Sub-Objects ### TvwNode Class Tree view node object. #### TvwNode Properties ##### Index ```vb Public Property Get Index() As Long ``` The index of the node in the collection. ##### Key ```vb Public Property Get Key() As String Public Property Let Key(ByVal Value As String) ``` Unique identifier key. ##### Tag ```vb Public Property Get Tag() As Variant Public Property Let Tag(ByVal Value As Variant) ``` Extra data. ##### Handle ```vb Public Property Get Handle() As LongPtr ``` Node handle. ##### Text ```vb Public Property Get Text() As String Public Property Let Text(ByVal Value As String) ``` Node text. ##### ToolTipText ```vb Public Property Get ToolTipText() As String Public Property Let ToolTipText(ByVal Value As String) ``` ToolTip text. ##### BackColor ```vb Public Property Get BackColor() As OLE_COLOR Public Property Let BackColor(ByVal Value As OLE_COLOR) ``` Background color. ##### ForeColor ```vb Public Property Get ForeColor() As OLE_COLOR Public Property Let ForeColor(ByVal Value As OLE_COLOR) ``` Foreground color. ##### Image ```vb Public Property Get Image() As Variant Public Property Let Image(ByVal Value As Variant) ``` Node image. ##### ImageIndex ```vb Public Property Get ImageIndex() As Long ``` Image index. ##### SelectedImage ```vb Public Property Get SelectedImage() As Variant Public Property Let SelectedImage(ByVal Value As Variant) ``` Selected state image. ##### SelectedImageIndex ```vb Public Property Get SelectedImageIndex() As Long ``` Selected image index. ##### ExpandedImage ```vb Public Property Get ExpandedImage() As Variant Public Property Let ExpandedImage(ByVal Value As Variant) ``` Expanded state image. ##### ExpandedImageIndex ```vb Public Property Get ExpandedImageIndex() As Long ``` Expanded image index. ##### NoImages ```vb Public Property Get NoImages() As Boolean Public Property Let NoImages(ByVal Value As Boolean) ``` Whether no image is displayed. ##### Selected ```vb Public Property Get Selected() As Boolean Public Property Let Selected(ByVal Value As Boolean) ``` Whether selected. ##### CheckBox ```vb Public Property Get CheckBox() As Boolean Public Property Let CheckBox(ByVal Value As Boolean) ``` Whether a checkbox is displayed. ##### Checked ```vb Public Property Get Checked() As Boolean Public Property Let Checked(ByVal Value As Boolean) ``` Whether checked. ##### Bold ```vb Public Property Get Bold() As Boolean Public Property Let Bold(ByVal Value As Boolean) ``` Whether bold. ##### Ghosted ```vb Public Property Get Ghosted() As Boolean Public Property Let Ghosted(ByVal Value As Boolean) ``` Whether ghosted. ##### Expanded ```vb Public Property Get Expanded() As Boolean Public Property Let Expanded(ByVal Value As Boolean) ``` Whether expanded. ##### Enabled ```vb Public Property Get Enabled() As Boolean Public Property Let Enabled(ByVal Value As Boolean) ``` Whether enabled. ##### Sorted ```vb Public Property Get Sorted() As Boolean Public Property Let Sorted(ByVal Value As Boolean) ``` Whether child nodes are sorted. ##### SortOrder ```vb Public Property Get SortOrder() As TvwSortOrderConstants Public Property Let SortOrder(ByVal Value As TvwSortOrderConstants) ``` Sort order. ##### SortType ```vb Public Property Get SortType() As TvwSortTypeConstants Public Property Let SortType(ByVal Value As TvwSortTypeConstants) ``` Sort type. ##### Children ```vb Public Property Get Children() As Long ``` Number of child nodes. ##### Child ```vb Public Property Get Child() As TvwNode ``` First child node. ##### Level ```vb Public Property Get Level() As Long ``` Node level (root node is 0). ##### Parent ```vb Public Property Get Parent() As TvwNode Public Property Set Parent(ByVal Value As TvwNode) ``` Parent node. ##### Root ```vb Public Property Get Root() As TvwNode ``` Root node. ##### NextSibling ```vb Public Property Get NextSibling() As TvwNode ``` Next sibling node. ##### PreviousSibling ```vb Public Property Get PreviousSibling() As TvwNode ``` Previous sibling node. ##### FirstSibling ```vb Public Property Get FirstSibling() As TvwNode ``` First sibling node. ##### LastSibling ```vb Public Property Get LastSibling() As TvwNode ``` Last sibling node. ##### FirstVisibleSibling ```vb Public Property Get FirstVisibleSibling() As TvwNode ``` First visible sibling node. ##### LastVisibleSibling ```vb Public Property Get LastVisibleSibling() As TvwNode ``` Last visible sibling node. ##### NextVisibleSibling ```vb Public Property Get NextVisibleSibling() As TvwNode ``` Next visible sibling node. ##### PreviousVisibleSibling ```vb Public Property Get PreviousVisibleSibling() As TvwNode ``` Previous visible sibling node. ##### FullPath ```vb Public Property Get FullPath() As String ``` The full path from the root to the current node. ##### Visible ```vb Public Property Get Visible() As Boolean ``` Whether the node is visible. #### TvwNode Methods ##### Move ```vb Public Sub Move(ByVal Relative As Variant, ByVal Relationship As TvwNodeRelationshipConstants) ``` Moves the node to a new position. ##### EnsureVisible ```vb Public Sub EnsureVisible() ``` Ensures the node is visible (expands parent nodes and scrolls into view). ##### CreateDragImage ```vb Public Function CreateDragImage() As LongPtr ``` Creates a drag image for the node; returns the image list handle. ##### SelectedIndex ```vb Public Function SelectedIndex() As Long ``` Returns the selected item index. ### TvwNodes Class Tree view nodes collection. #### TvwNodes Members ##### NewEnum ```vb Public Function NewEnum() As IUnknown ``` Enumerator (hidden). ##### Add ```vb Public Function Add(Optional ByVal Relative As Variant, Optional ByVal Relationship As Variant, Optional ByVal Key As Variant, Optional ByVal Text As Variant, Optional ByVal Image As Variant, Optional ByVal SelectedImage As Variant) As TvwNode ``` Adds a node. ##### Item ```vb Public Function Item(ByVal Index As Variant) As TvwNode ``` Gets a node (default member). ##### Exists ```vb Public Function Exists(ByVal Index As Variant) As Boolean ``` Checks if a node exists. ##### Count ```vb Public Property Get Count() As Long ``` Node count. ##### Clear ```vb Public Sub Clear() ``` Clears all nodes. ##### Remove ```vb Public Sub Remove(ByVal Index As Variant) ``` Removes a node. ### TvwSelectedNodes Class Selected nodes collection (multi-select mode). #### TvwSelectedNodes Members ##### NewEnum ```vb Public Function NewEnum() As IUnknown ``` Enumerator (hidden). ##### Item ```vb Public Function Item(ByVal Index As Long) As TvwNode ``` Gets a selected node (default member). ##### Exists ```vb Public Function Exists(ByVal Index As Long) As Boolean ``` Checks if a selected node exists. ##### Count ```vb Public Property Get Count() As Long ``` Selected node count. ## Code Examples ### Basic Usage ```vb ' Add tree nodes Dim root As TvwNode Set root = TreeView1.Nodes.Add(, , "root", "Root Node", 1) root.Expanded = True TreeView1.Nodes.Add "root", TvwNodeChild, "child1", "Child 1", 2 TreeView1.Nodes.Add "root", TvwNodeChild, "child2", "Child 2", 2 ' Handle node click Private Sub TreeView1_NodeClick(ByVal Node As TvwNode, ByVal Button As Integer) MsgBox "Clicked: " & Node.Text End Sub ' Control node expansion Private Sub TreeView1_BeforeExpand(ByVal Node As TvwNode, ByRef Cancel As Boolean) If Node.Children = 0 Then Cancel = True End If End Sub ' Node selection change Private Sub TreeView1_NodeSelect(ByVal Node As TvwNode) Debug.Print "Selected: " & Node.FullPath End Sub ``` --- --- url: /zh/packages/vbccr/text/labelw.md description: Unicode 标签控件（LabelW） - VBCCR 开发手册，基于源码的完整 API 参考 --- # Unicode 标签控件（LabelW） 增强型 Unicode 标签控件，替代 VB6 标准 Label 控件，提供文本效果、边框效果、鼠标跟踪等增强功能。 ## 枚举 ### LblTextEffectsConstants | 常量 | 值 | 说明 | |------|-----|------| | LblTextEffectNone | 0 | 无效果 | | LblTextEffectShadow | 1 | 阴影 | | LblTextEffectEmboss | 2 | 浮雕 | | LblTextEffectEngrave | 3 | 刻纹 | ### LblBorderEffectsConstants | 常量 | 值 | 说明 | |------|-----|------| | LblBorderEffectNone | 0 | 无边框效果 | | LblBorderEffectSoftEdge | 1 | 柔和边缘 | | LblBorderEffectEtched | 2 | 蚀刻 | ### CCBackStyleConstants 参见通用枚举。 ### CCAppearanceConstants 参见通用枚举。 ### CCBorderStyleConstants 参见通用枚举。 ### CCMousePointerConstants 参见通用枚举。 ### CCVerticalAlignmentConstants 参见通用枚举。 ### CCRightToLeftModeConstants 参见通用枚举。 ## 属性 ### Alignment ```vb Property Get Alignment() As Long Property Let Alignment(ByVal Value As Long) ``` 文本对齐方式。0 = 左对齐，1 = 右对齐，2 = 居中。 ### AutoSize ```vb Property Get AutoSize() As Boolean Property Let AutoSize(ByVal Value As Boolean) ``` 是否自动调整大小以适应内容。 ### BackColor ```vb Property Get BackColor() As OLE_COLOR Property Let BackColor(ByVal Value As OLE_COLOR) ``` 背景颜色。 ### BackStyle ```vb Property Get BackStyle() As CCBackStyleConstants Property Let BackStyle(ByVal Value As CCBackStyleConstants) ``` 背景样式。参见通用枚举。 ### BorderStyle ```vb Property Get BorderStyle() As CCBorderStyleConstants Property Let BorderStyle(ByVal Value As CCBorderStyleConstants) ``` 边框样式。参见通用枚举。 ### Caption ```vb Property Get Caption() As String Property Let Caption(ByVal Value As String) ``` 显示文本。 ### Enabled ```vb Property Get Enabled() As Boolean Property Let Enabled(ByVal Value As Boolean) ``` 是否可用。 ### Font ```vb Property Get Font() As StdFont Property Let Font(ByVal NewFont As StdFont) Property Set Font(ByVal NewFont As StdFont) ``` 字体。 ### ForeColor ```vb Property Get ForeColor() As OLE_COLOR Property Let ForeColor(ByVal Value As OLE_COLOR) ``` 前景颜色。 ### MousePointer ```vb Property Get MousePointer() As CCMousePointerConstants Property Let MousePointer(ByVal Value As CCMousePointerConstants) ``` 鼠标指针样式。参见通用枚举。 ### MouseIcon ```vb Property Get MouseIcon() As IPictureDisp Property Let MouseIcon(ByVal Value As IPictureDisp) Property Set MouseIcon(ByVal Value As IPictureDisp) ``` 自定义鼠标图标。 ### MouseTrack ```vb Property Get MouseTrack() As Boolean Property Let MouseTrack(ByVal Value As Boolean) ``` 是否启用鼠标进入/离开跟踪。 ### UseMnemonic ```vb Property Get UseMnemonic() As Boolean Property Let UseMnemonic(ByVal Value As Boolean) ``` 是否将 & 字符解释为快捷键前缀。 ### TextEffect ```vb Property Get TextEffect() As LblTextEffectsConstants Property Let TextEffect(ByVal Value As LblTextEffectsConstants) ``` 文本效果。 ### TextEffectColor ```vb Property Get TextEffectColor() As OLE_COLOR Property Let TextEffectColor(ByVal Value As OLE_COLOR) ``` 文本效果颜色。 ### BorderEffect ```vb Property Get BorderEffect() As LblBorderEffectsConstants Property Let BorderEffect(ByVal Value As LblBorderEffectsConstants) ``` 边框效果。 ### BorderEffectColor ```vb Property Get BorderEffectColor() As OLE_COLOR Property Let BorderEffectColor(ByVal Value As OLE_COLOR) ``` 边框效果颜色。 ### WordWrap ```vb Property Get WordWrap() As Boolean Property Let WordWrap(ByVal Value As Boolean) ``` 是否自动换行。 ### RightToLeft ```vb Property Get RightToLeft() As Boolean Property Let RightToLeft(ByVal Value As Boolean) ``` 从右到左显示方向。 ### RightToLeftLayout ```vb Property Get RightToLeftLayout() As Boolean Property Let RightToLeftLayout(ByVal Value As Boolean) ``` 从右到左镜像布局。 ### RightToLeftMode ```vb Property Get RightToLeftMode() As CCRightToLeftModeConstants Property Let RightToLeftMode(ByVal Value As CCRightToLeftModeConstants) ``` 从右到左模式。参见通用枚举。 ### Appearance ```vb Property Get Appearance() As CCAppearanceConstants Property Let Appearance(ByVal Value As CCAppearanceConstants) ``` 外观样式。参见通用枚举。 ### VerticalAlignment ```vb Property Get VerticalAlignment() As CCVerticalAlignmentConstants Property Let VerticalAlignment(ByVal Value As CCVerticalAlignmentConstants) ``` 垂直对齐方式。参见通用枚举。 ### hWnd ```vb Property Get hWnd() As LongPtr ``` 窗口句柄。只读。 ### ToolTipText ```vb Property Get ToolTipText() As String Property Let ToolTipText(ByVal Value As String) ``` 工具提示文本。 ### Name ```vb Property Get Name() As String ``` 控件名称。只读。 ### Tag ```vb Property Get Tag() As Variant Property Let Tag(ByVal Value As Variant) Property Set Tag(ByVal Value As Variant) ``` 自定义数据。 ### Parent ```vb Property Get Parent() As Object ``` 父对象。只读。 ### Container ```vb Property Get Container() As Object Property Set Container(ByVal Value As Object) ``` 容器对象。 ### Left ```vb Property Get Left() As Single Property Let Left(ByVal Value As Single) ``` 左边距。 ### Top ```vb Property Get Top() As Single Property Let Top(ByVal Value As Single) ``` 顶边距。 ### Width ```vb Property Get Width() As Single Property Let Width(ByVal Value As Single) ``` 宽度。 ### Height ```vb Property Get Height() As Single Property Let Height(ByVal Value As Single) ``` 高度。 ### Visible ```vb Property Get Visible() As Boolean Property Let Visible(ByVal Value As Boolean) ``` 可见性。 ## 方法 ### Refresh ```vb Sub Refresh() ``` 强制重绘。 ### AboutBox ```vb Sub AboutBox() ``` 显示关于对话框。 ## 事件 ### Click ```vb Event Click() ``` 单击时触发。 ### DblClick ```vb Event DblClick() ``` 双击时触发。 ### MouseDown ```vb Event MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) ``` 鼠标按下时触发。 ### MouseUp ```vb Event MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) ``` 鼠标释放时触发。 ### MouseMove ```vb Event MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) ``` 鼠标移动时触发。 ### MouseEnter ```vb Event MouseEnter() ``` 鼠标进入控件时触发。 ### MouseLeave ```vb Event MouseLeave() ``` 鼠标离开控件时触发。 ### OLEStartDrag ```vb Event OLEStartDrag(Data As DataObject, AllowedEffects As Long) ``` OLE 拖拽开始时触发。 ### OLEGiveFeedback ```vb Event OLEGiveFeedback(Effect As Long, DefaultCursors As Boolean) ``` OLE 拖拽反馈。 ### OLESetData ```vb Event OLESetData(Data As DataObject, DataFormat As Integer) ``` OLE 设置数据。 ### OLECompleteDrag ```vb Event OLECompleteDrag(Effect As Long) ``` OLE 拖拽完成。 ### OLEDragOver ```vb Event OLEDragOver(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single, State As Integer) ``` OLE 拖拽经过时触发。 ### OLEDragDrop ```vb Event OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single) ``` OLE 拖放时触发。 ## 代码示例 ```vb ' 带阴影效果的标签 With LabelW1 .Caption = "欢迎使用 VBCCR" .TextEffect = LblTextEffectShadow .TextEffectColor = vbGrayText .Font.Size = 14 .Font.Bold = True End With ' 响应鼠标进入/离开 Private Sub LabelW1_MouseEnter() LabelW1.ForeColor = vbBlue End Sub Private Sub LabelW1_MouseLeave() LabelW1.ForeColor = vbWindowText End Sub ' 垂直居中的蚀刻边框标签 With LabelW2 .Caption = "设置" .VerticalAlignment = ccVCenter .BorderEffect = LblBorderEffectEtched .BorderEffectColor = vb3DShadow End With ``` --- --- url: /donate/list.md --- | 日期 Date | 捐赠者 Donor | 金额 Amount | 留言 Message | | ---------- | ---------------------------- | ----------- | -------------------------------------------------------------------------------------------------- | | 2024-06-20 | VbsGirl（土妹） | ￥ 200 | vbsgirl 娟 200 元 | | 2024-06-21 | 匿名 VB 群友 | ￥ 10 | 暂无 | | 2024-06-27 | 赞助商 码农库 | ￥ 200 | 码农库 MaNongKu.com 捐 200 元 | | 2024-06-28 | VbsGirl（土妹） | ￥ 100 | 过 500 了，怀念 VB 的人务必支持一下，人生有情，情怀无价！ | | 2024-08-06 | twinbasic 群友：TONMIN | ￥ 100 | 支持一下 | | 2024-09-26 | ASP 群友：天子 | ￥ 10 | (马鞍山市的徐磊)支持一下 | | 2024-09-29 | 好友：郑春来 | ￥ 200 | 捐助￥ 200 开发 VBMAN 服务器 demo | | 2024-09-29 | VB 群友：Kimi | ￥ 500 | 捐助开发 JSON 服务器 demo | | 2024-10-11 | VB 群友：流云 | ￥ 100 | 你们这种精神需要鼓励。 | | 2024-10-16 | VB 群友: Edward | ￥ 10 | 暂无 | | 2024-10-19 | VB 群友: 静咫流云 | ￥ 200 | 我看好 VBMAN, 加油干 | | 2024-09-29 | 好友：郑春来 | ￥ 200 | 捐助￥ 200 开发 VBMAN 客户端 HTTP 分块上传文件的 demo | | 2024-12-12 | QQ 群友: 守望者 | ￥ 6.66 | 捐赠 6.66 | | 2024-12-12 | QQ 群友: 码农库 MaNongKu.com | ￥ 1.66 | 捐赠 1.66 | | 2024-12-18 | QQ 群友: mature | ￥ 50.00 | 期待后续的开发，特别是对网页的视频的控制，如播放，暂停，快进，拖放等，看视频中途有题出现时的处理。 | | 2024-12-20 | QQ 群友: 郑春来 | ￥ 88.00 | 捐赠 vbman2。 | | 2024-12-28 | QQ 群友: moonboy | ￥ 66.00 | 小小支持一下，祝越做越好。 | | 2025-03-07 | 微信：\*翼 | ￥ 10.00 | 太棒了，期待更强。 | | 2025-01-11 | QQ 群友：绵阳汪汪 | ￥ 66.66 | 暂无。 | | 2025-01-07 | 微信：\*尔 | ￥ 10.80 | 暂无。 | | 2025-01-07 | 微信：\*尔（支付 2 次） | ￥ 10.80 | 暂无。 | | 2025-06-14 | 微信：贺文龙 | ￥ 500.00 | 把 vb 瘸了的那条腿给接上了。 | | 2025-06-16 | QQ 群友：cuieaor | ￥ 18.00 | 请大神喝杯奶茶。 | | 2025-06-18 | QQ 群友：上海二毛 | ￥ 188.00 | 守住国内 VB6 最后的领地。 | | 2025-12-15 | QQ 群友：蓝海岸 | ￥ 10.00 | 暂无。 | | 2025-12-22 | QQ 群友：Man.兔子 ღ o О | ￥ 50.00 | 暂无。 | | 2026-01-12 | QQ 群友：你到底说不说 | ￥ 50.00 | 再接再厉，继续加油! | | 2026-01-16 | QQ 群友: 码农库 MaNongKu.com | ￥ 20.00 | for vbman | | 2026-01-17 | QQ 群友: 往事随风 | ￥ 100.00 | VBMAN 加油 | | 2026-01-30 | QQ 群友: 小鱼 | ￥ 100.00 | 以图鼓励 嘎嘎 | | 2026-01-30 | QQ 群友: xxdoc | ￥ 20.00 | vbmen牛 | | 2026-02-08 | QQ 群友: 老白 | ￥ 200.00 | 过年了赞助你点 | | 2026-02-09 | QQ 群友: 南赡部洲 | ￥ 100.00 | 大佬，赞助了100 | | 2026-02-16 | QQ 群友: 松林 | ￥ 100.00 | 捐献给本网站 | | 2026-02-18 | QQ 群友: 游戏玩家 | ￥ 6.66 | vbman2，一点点感谢 | | 2026-03-02 | 微信: y\*w | ￥ 20.00 | （无留言） | | 2026-03-02 | QQ 群友: ck^er | ￥ 6.66 | 有空把winsock例程分开吧^O^ | | 2026-03-19 | 微信: 德\*d | ￥ 30.00 | （无留言） | | 2026-03-26 | QQ 群友: norman | ￥ 50.00 | 希望给vb6多续两年命 | | 2026-05-08 | QQ 群友: 小熊软糖 | ￥ 500.00 | 小小心意 | | 2026-05-21 | QQ 群友: 小熊软糖 | ￥ 300.00 | 咖啡费已捐赠 | | 2026-06-01 | QQ 群友: 橙子 | ￥ 100.00 | (无留言) | | 2026-06-25 | QQ 群友: 自学成柴 | ￥ 10.00 | 喝杯红牛 | | 2026-07-19 | QQ 匿名网友（1） | ￥ 200.00 | 辛苦 | | 2026-07-23 | 好友：郑春来 | ￥ 200.00 | VBMAN | | 2026-08-16 | QQ 群友：后悔（2） | ￥ 50.00 | 支持大佬，请大佬喝咖 | --- --- url: /en.md --- ::::: tip 🎉 Big News: VBMAN is Now Open Source! **June 1, 2026** - After nine years of refinement, VBMAN is officially open sourced under the **[GPL v3](/en/vbman/LICENSE_GUIDE)** license! > From an idea in 2017 to today's open source project, VBMAN has always adhered to one belief: > **Make BASIC language still powerful in the network era.** * **Binaries Free Forever** — No usage restrictions on compiled DLL/OCX files * **Open Source** — Following [GPL v3 protocol](/en/vbman/LICENSE_GUIDE), welcome to Fork, contribute and build the ecosystem together * **Commercial Licensing Available** — Use VBMAN.dllin closed-source commercial projects with zero restrictions. For source code embedding, please [Contact us](/en/vbman/LICENSE_GUIDE) [**Visit Repository**](https://github.com/woeoio/vbman) ::::: ## 🎯 Why Choose VBMAN? ```vb ' A complete web server in just a few lines of code ' === 1. Create Business Class (bDemo.cls) === Public Sub Hello(ctx As cHttpServerContext) Dim id As Long: id = ctx.Request.QueryString("id") ctx.Response.Text "Hello VBMAN! id=" & id End Sub ' === 2. Start Server (Form1.frm) === Dim HttpServer As New cHttpServer With HttpServer .Router.Reg "Demo", New bDemo ' Register business class .Router.AutoRoute = True ' Enable auto-routing .Start 800 ' Start server, listen on port 800 End With MsgBox "Server running at http://localhost:800" ' Visit: http://127.0.0.1:800/demo/hello?id=123 ``` VBMAN is a **full-stack network development framework** built specifically for VB6 / TwinBasic developers: | Capability | Traditional VB6 | With VBMAN | | --------------------- | ------------------------------- | ----------------------------------------- | | HTTP Server | ❌ Requires external components | ✅ Built-in, start with a few lines | | WebSocket | ❌ Not supported | ✅ Native support | | JSON Processing | ❌ Manual parsing | ✅ Built-in serialization/deserialization | | Modern Browser Kernel | ❌ Outdated WebBrowser | ✅ WebView2 (VBMAN2) | | Database Operations | ⚠️ Verbose ADO | ✅ Simplified wrapper, ready to use | > The business class doesn't need to be in a separate cls file. You can write the hello function directly in the form, then: ```vb .Router.Reg "Demo", Me ' Register the form itself as business class ``` ## 📦 Feature Matrix | Module | Description | Status | | ------------- | ---------------------------------- | ------------------------- | | `cHttpServer` | Embedded HTTP/HTTPS server | ✅ Stable | | `cWebView2` | Modern browser control (VBMAN2) | ✅ Stable | | `cJson` | JSON parsing and generation | ✅ Stable | | `cHttpClient` | HTTP request client | ✅ Stable | | `cLogger` | Graded logging system | ✅ Stable | | `cDatabase` | Database operation wrapper | ✅ Stable | | `cSocket` | Asynchronous network communication | ✅ Based on VbAsyncSocket | | `cAI` | AI capability integration | 🚧 VBMAN2 Planning | | MQTT/Modbus | IoT protocol support | 🚧 In development | ## 🏗️ Project History ``` 2017 ── Project conceived, BSMAN framework blueprint born | 2023 ── ASPMAN first sub-project launched | 2024 ── VBMAN official development started | 2025 ── TBMAN TwinBasic migration started | 2026.06.01 ── VBMAN officially open sourced 🎉 ``` ## 🌟 Technical Acknowledgments VBMAN would not exist without these excellent open source projects: | Project | License | Purpose | | -------------------------------------------------------- | ------- | ------------------------------- | | [VbAsyncSocket](https://github.com/wqweto/VbAsyncSocket) | MIT | Underlying Socket communication | | [VBA-JSON](https://github.com/VBA-tools/VBA-JSON) | MIT | JSON processing engine | | [cTimer](http://sandsprite.com) | - | High-precision timer | [View Full Credits List](/en/CREDITS) ::::: info 📌 Usage Notice VBMAN products are **for legal use only**. Strictly prohibited for any illegal activities. * Downloading and using constitutes agreement to the [End User License Agreement](/en/EULA) * Users bear their own legal responsibility for usage * This site will cooperate with relevant national regulatory requirements as required by law **This website has no affiliation or partnership with Microsoft Corporation.** ::::: ::::: info 🌐 Service Status Real-time monitoring: ::::: *** **Made with ❤️ by Deng Wei · [a-vi.com](https://a-vi.com)** [![License: GPL v3](https://img.shields.io/badge/License-GPLv3-blue.svg)](https://github.com/woeoio/vbman/blob/main/LICENSE) [![Platform](https://img.shields.io/badge/Platform-Windows-orange.svg)](https://www.microsoft.com/windows) --- --- url: /donate/list-aspman.md --- | 日期 Date | 捐赠者 Donor | 金额 Amount | 留言 Message | | ---------- | ------------------- | ------------- | ---------------------- | | 2025-08-09 | 天天Asp站长（大仙） | ￥100\[`已退`] | 造福大家 | | 2025-08-10 | A00陈陈（微信群友） | ￥200\[`已退`] | 不管能不能用我都支持你 | --- --- url: /donate/list-c3.md --- | 日期 Date | 捐赠者 Donor | 金额 Amount | 留言 Message | | ---------- | ------------ | ----------- | ---------------------------- | | 2026-07-07 | QQ群友：落叶 | ￥16 | 请大佬喝杯咖啡，提提速！！！ | | 2026-07-20 | QQ群友：★UF● | ￥20 | 虽然现在VB不怎么用了，先支持下！ | --- --- url: /donate/list-aspman-old.md --- | 日期 Date | 捐赠者 Donor | 金额 Amount | 留言 Message | | ---------- | ------------------- | ----------- | ------------ | | 2024-xx-xx | PopAsp 作者（风歌） | ￥100 | 支持 | | 2024-xx-xx | PopAsp 群友（功陈） | ￥100 | 支持 | --- --- url: /en/vbman/LICENSE.md --- GNU GENERAL PUBLIC LICENSE Version 3, 29 June 2007 Copyright (C) 2024-2026 邓伟 (VBMAN Project) This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . \============================================================================== VBMAN 项目许可补充说明 ============== 本软件采用 GNU General Public License v3.0 (GPL-3.0) 协议开源。 ## 一、二进制文件 本项目编译后的二进制文件（DLL、EXE 等）永久免费，无任何使用限制。 ## 二、源代码使用 1. 个人使用 个人用户可以免费使用本项目的源代码，但必须遵守 GPL 协议的规定， 包括但不限于： * 分发时必须附带 LICENSE 文件 * 修改后的作品也必须采用 GPL 兼容协议开源 2. 商业使用 * 如果您的商业项目基于本项目进行修改或二次开发，并且对外发布/销售， 则必须将整个项目的源代码开源，并采用 GPL 兼容协议。 * 如果您希望在闭源商业项目中使用本项目的源代码，必须联系作者购买 商业授权。 ## 三、商业授权 如需闭源商业授权，请联系： * 作者：邓伟 * 网站：https://a-vi.com 商业授权费用根据具体使用场景和范围协商确定。 ## 四、免责声明 本软件按"原样"提供，作者不对因使用本软件而产生的任何直接或间接损失 承担责任。 \============================================================================== 以下附上完整的 GNU GENERAL PUBLIC LICENSE Version 3 原文： *** GNU GENERAL PUBLIC LICENSE Version 3, 29 June 2007 Copyright (C) 2007 Free Software Foundation, Inc. Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. ``` Preamble ``` The GNU General Public License is a free, copyleft license for software and other kinds of works. The licenses for most software and other practical works are designed to take away your freedom to share and change the works. By contrast, the GNU General Public License is intended to guarantee your freedom to share and change all versions of a program--to make sure it remains free software for all its users. We, the Free Software Foundation, use the GNU General Public License for most of our software; it applies also to any other work released this way by its authors. You can apply it to your programs, too. When we speak of free software, we are referring to freedom, not price. Our General Public Licenses are designed to make sure that you have the freedom to distribute copies of free software (and charge for them if you wish), that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs, and that you know you can do these things. To protect your rights, we need to prevent others from denying you these rights or asking you to surrender the rights. Therefore, you have certain responsibilities if you distribute copies of the software, or if you modify it: responsibilities to respect the freedom of others. For example, if you distribute copies of such a program, whether gratis or for a fee, you must pass on to the recipients the same freedoms that you received. You must make sure that they, too, receive or can get the source code. And you must show them these terms so they know their rights. Developers that use the GNU GPL protect your rights with two steps: (1) assert copyright on the software, and (2) offer you this License giving you legal permission to copy, distribute and/or modify it. For the developers' and authors' protection, the GPL clearly explains that there is no warranty for this free software. For both users' and authors' sake, the GPL requires that modified versions be marked as changed, so that their problems will not be attributed erroneously to authors of previous versions. Some devices are designed to deny users access to install or run modified versions of the software inside them, although the manufacturer can do so. This is fundamentally incompatible with the aim of protecting users' freedom to change the software. The systematic pattern of such abuse occurs in the area of products for individuals to use, which is precisely where it is most unacceptable. Therefore, we have designed this version of the GPL to prohibit the practice for those products. If such problems arise substantially in other domains, we stand ready to extend this provision to those domains in future versions of the GPL, as needed to protect the freedom of users. Finally, every program is threatened constantly by software patents. States should not allow patents to restrict development and use of software on general-purpose computers, but in those that do, we wish to avoid the special danger that patents applied to a free program could make it effectively proprietary. To prevent this, the GPL assures that patents cannot be used to render the program non-free. The precise terms and conditions for copying, distribution and modification follow. ``` TERMS AND CONDITIONS ``` 0\. Definitions. "This License" refers to version 3 of the GNU General Public License. "Copyright" also means copyright-like laws that apply to other kinds of works, such as semiconductor masks. "The Program" refers to any copyrightable work licensed under this License. Each licensee is addressed as "you". "Licensees" and "recipients" may be individuals or organizations. To "modify" a work means to copy from or adapt all or part of the work in a fashion requiring copyright permission, other than the making of an exact copy. The resulting work is called a "modified version" of the earlier work or a work "based on" the earlier work. A "covered work" means either the unmodified Program or a work based on the Program. To "propagate" a work means to do anything with it that, without permission, would make you directly or secondarily liable for infringement under applicable copyright law, except executing it on a computer or modifying a private copy. Propagation includes copying, distribution (with or without modification), making available to the public, and in some countries other activities as well. To "convey" a work means any kind of propagation that enables other parties to make or receive copies. Mere interaction with a user through a computer network, with no transfer of a copy, is not conveying. An interactive user interface displays "Appropriate Legal Notices" to the extent that it includes a convenient and prominently visible feature that (1) displays an appropriate copyright notice, and (2) tells the user that there is no warranty for the work (except to the extent that warranties are provided), that licensees may convey the work under this License, and how to view a copy of this License. If the interface presents a list of user commands or options, such as a menu, a prominent item in the list meets this criterion. 1. Source Code. The "source code" for a work means the preferred form of the work for making modifications to it. "Object code" means any non-source form of a work. A "Standard Interface" means an interface that either is an official standard defined by a recognized standards body, or, in the case of interfaces specified for a particular programming language, one that is widely used among developers working in that language. The "System Libraries" of an executable work include anything, other than the work as a whole, that (a) is included in the normal form of packaging a Major Component, but which is not part of that Major Component, and (b) serves only to enable use of the work with that Major Component, or to implement a Standard Interface for which an implementation is available to the public in source code form. A "Major Component", in this context, means a major essential component (kernel, window system, and so on) of the specific operating system (if any) on which the executable work runs, or a compiler used to produce the work, or an object code interpreter used to run it. The "Corresponding Source" for a work in object code form means all the source code needed to generate, install, and (for an executable work) run the object code and to modify the work, including scripts to control those activities. However, it does not include the work's System Libraries, or general-purpose tools or generally available free programs which are used unmodified in performing those activities but which are not part of the work. For example, Corresponding Source includes interface definition files associated with source files for the work, and the source code for shared libraries and dynamically linked subprograms that the work is specifically designed to require, such as by intimate data communication or control flow between those subprograms and other parts of the work. The Corresponding Source need not include anything that users can regenerate automatically from other parts of the Corresponding Source. The Corresponding Source for a work in source code form is that same work. 2. Basic Permissions. All rights granted under this License are granted for the term of copyright on the Program, and are irrevocable provided the stated conditions are met. This License explicitly affirms your unlimited permission to run the unmodified Program. The output from running a covered work is covered by this License only if the output, given its content, constitutes a covered work. This License acknowledges your rights of fair use or other equivalent, as provided by copyright law. You may make, run and propagate covered works that you do not convey, without conditions so long as your license otherwise remains in force. You may convey covered works to others for the sole purpose of having them make modifications exclusively for you, or provide you with facilities for running those works, provided that you comply with the terms of this License in conveying all material for which you do not control copyright. Those thus making or running the covered works for you must do so exclusively on your behalf, under your direction and control, on terms that prohibit them from making any copies of your copyrighted material outside their relationship with you. Conveying under any other circumstances is permitted solely under the conditions stated below. Sublicensing is not allowed; section 10 makes it unnecessary. 3. Protecting Users' Legal Rights From Anti-Circumvention Law. No covered work shall be deemed part of an effective technological measure under any applicable law fulfilling obligations under article 11 of the WIPO copyright treaty adopted on 20 December 1996, or similar laws prohibiting or restricting circumvention of such measures. When you convey a covered work, you waive any legal power to forbid circumvention of technological measures to the extent such circumvention is effected by exercising rights under this License with respect to the covered work, and you disclaim any intention to limit operation or modification of the work as a means of enforcing, against the work's users, your or third parties' legal rights to forbid circumvention of technological measures. 4. Conveying Verbatim Copies. You may convey verbatim copies of the Program's source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice; keep intact all notices stating that this License and any non-permissive terms added in accord with section 7 apply to the code; keep intact all notices of the absence of any warranty; and give all recipients a copy of this License along with the Program. You may charge any price or no price for each copy that you convey, and you may offer support or warranty protection for a fee. 5. Conveying Modified Source Versions. You may convey a work based on the Program, or the modifications to produce it from the Program, in the form of source code under the terms of section 4, provided that you also meet all of these conditions: ``` a) The work must carry prominent notices stating that you modified it, and giving a relevant date. b) The work must carry prominent notices stating that it is released under this License and any conditions added under section 7. This requirement modifies the requirement in section 4 to "keep intact all notices". c) You must license the entire work, as a whole, under this License to anyone who comes into possession of a copy. This License will therefore apply, along with any applicable section 7 additional terms, to the whole of the work, and all its parts, regardless of how they are packaged. This License gives no permission to license the work in any other way, but it does not invalidate such permission if you have separately received it. d) If the work has interactive user interfaces, each must display Appropriate Legal Notices; however, if the Program has interactive interfaces that do not display Appropriate Legal Notices, your work need not make them do so. ``` A compilation of a covered work with other separate and independent works, which are not by their nature extensions of the covered work, and which are not combined with it such as to form a larger program, in or on a volume of a storage or distribution medium, is called an "aggregate" if the compilation and its resulting copyright are not used to limit the access or legal rights of the compilation's users beyond what the individual works permit. Inclusion of a covered work in an aggregate does not cause this License to apply to the other parts of the aggregate. 6. Conveying Non-Source Forms. You may convey a covered work in object code form under the terms of sections 4 and 5, provided that you also convey the machine-readable Corresponding Source under the terms of this License, in one of these ways: ``` a) Convey the object code in, or embodied in, a physical product (including a physical distribution medium), accompanied by the Corresponding Source fixed on a durable physical medium customarily used for software interchange. b) Convey the object code in, or embodied in, a physical product (including a physical distribution medium), accompanied by a written offer, valid for at least three years and valid for as long as you offer spare parts or customer support for that product model, to give anyone who possesses the object code either (1) a copy of the Corresponding Source for all the software in the product that is covered by this License, on a durable physical medium customarily used for software interchange, for a price no more than your reasonable cost of physically performing this conveying of source, or (2) access to copy the Corresponding Source from a network server at no charge. c) Convey individual copies of the object code with a copy of the written offer to provide the Corresponding Source. This alternative is allowed only occasionally and noncommercially, and only if you received the object code with such an offer, in accord with subsection 6b. d) Convey the object code by offering access from a designated place (gratis or for a charge), and offer equivalent access to the Corresponding Source in the same way through the same place at no further charge. You need not require recipients to copy the Corresponding Source along with the object code. If the place to copy the object code is a network server, the Corresponding Source may be on a different server (operated by you or a third party) that supports equivalent copying facilities, provided you maintain clear directions next to the object code saying where to find the Corresponding Source. Regardless of what server hosts the Corresponding Source, you remain obligated to ensure that it is available for as long as needed to satisfy these requirements. e) Convey the object code using peer-to-peer transmission, provided you inform other peers where the object code and Corresponding Source of the work are being offered to the general public at no charge under subsection 6d. ``` A separable portion of the object code, whose source code is excluded from the Corresponding Source as a System Library, need not be included in conveying the object code work. A "User Product" is either (1) a "consumer product", which means any tangible personal property which is normally used for personal, family, or household purposes, or (2) anything designed or sold for incorporation into a dwelling. In determining whether a product is a consumer product, doubtful cases shall be resolved in favor of coverage. For a particular product received by a particular user, "normally used" refers to a typical or common use of that class of product, regardless of the status of the particular user or of the way in which the particular user actually uses, or expects or is expected to use, the product. A product is a consumer product regardless of whether the product has substantial commercial, industrial or non-consumer uses, unless such uses represent the only significant mode of use of the product. "Installation Information" for a User Product means any methods, procedures, authorization keys, or other information required to install and execute modified versions of a covered work in that User Product from a modified version of its Corresponding Source. The information must suffice to ensure that the continued functioning of the modified object code is in no case prevented or interfered with solely because modification has been made. If you convey an object code work under this section in, or with, or specifically for use in, a User Product, and the conveying occurs as part of a transaction in which the right of possession and use of the User Product is transferred to the recipient in perpetuity or for a fixed term (regardless of how the transaction is characterized), the Corresponding Source conveyed under this section must be accompanied by the Installation Information. But this requirement does not apply if neither you nor any third party retains the ability to install modified object code on the User Product (for example, the work has been installed in ROM). The requirement to provide Installation Information does not include a requirement to continue to provide support service, warranty, or updates for a work that has been modified or installed by the recipient, or for the User Product in which it has been modified or installed. Access to a network may be denied when the modification itself materially and adversely affects the operation of the network or violates the rules and protocols for communication across the network. Corresponding Source conveyed, and Installation Information provided, in accord with this section must be in a format that is publicly documented (and with an implementation available to the public in source code form), and must require no special password or key for unpacking, reading or copying. 7. Additional Terms. "Additional permissions" are terms that supplement the terms of this License by making exceptions from one or more of its conditions. Additional permissions that are applicable to the entire Program shall be treated as though they were included in this License, to the extent that they are valid under applicable law. If additional permissions apply only to part of the Program, that part may be used separately under those permissions, but the entire Program remains governed by this License without regard to the additional permissions. When you convey a copy of a covered work, you may at your option remove any additional permissions from that copy, or from any part of it. (Additional permissions may be written to require their own removal in certain cases when you modify the work.) You may place additional permissions on material, added by you to a covered work, for which you have or can give appropriate copyright permission. Notwithstanding any other provision of this License, for material you add to a covered work, you may (if authorized by the copyright holders of that material) supplement the terms of this License with terms: ``` a) Disclaiming warranty or limiting liability differently from the terms of sections 15 and 16 of this License; or b) Requiring preservation of specified reasonable legal notices or author attributions in that material or in the Appropriate Legal Notices displayed by works containing it; or c) Prohibiting misrepresentation of the origin of that material, or requiring that modified versions of such material be marked in reasonable ways as different from the original version; or d) Limiting the use for publicity purposes of names of licensors or authors of the material; or e) Declining to grant rights under trademark law for use of some trade names, trademarks, or service marks; or f) Requiring indemnification of licensors and authors of that material by anyone who conveys the material (or modified versions of it) with contractual assumptions of liability to the recipient, for any liability that these contractual assumptions directly impose on those licensors and authors. ``` All other non-permissive additional terms are considered "further restrictions" within the meaning of section 10. If the Program as you received it, or any part of it, contains a notice stating that it is governed by this License along with a term that is a further restriction, you may remove that term. If a license document contains a further restriction but permits relicensing or conveying under this License, you may add to a covered work material governed by the terms of that license document, provided that the further restriction does not survive such relicensing or conveying. If you add terms to a covered work in accord with this section, you must place, in the relevant source files, a statement of the additional terms that apply to those files, or a notice indicating where to find the applicable terms. Additional terms, permissive or non-permissive, may be stated in the form of a separately written license, or stated as exceptions; the above requirements apply either way. 8. Termination. You may not propagate or modify a covered work except as expressly provided under this License. Any attempt otherwise to propagate or modify it is void, and will automatically terminate your rights under this License (including any patent licenses granted under the third paragraph of section 11). However, if you cease all violation of this License, then your license from a particular copyright holder is reinstated (a) provisionally, unless and until the copyright holder explicitly and finally terminates your license, and (b) permanently, if the copyright holder fails to notify you of the violation by some reasonable means prior to 60 days after the cessation. Moreover, your license from a particular copyright holder is reinstated permanently if the copyright holder notifies you of the violation by some reasonable means, this is the first time you have received notice of violation of this License (for any work) from that copyright holder, and you cure the violation prior to 30 days after your receipt of the notice. Termination of your rights under this section does not terminate the licenses of parties who have received copies or rights from you under this License. If your rights have been terminated and not permanently reinstated, you do not qualify to receive new licenses for the same material under section 10. 9. Acceptance Not Required for Having Copies. You are not required to accept this License in order to receive or run a copy of the Program. Ancillary propagation of a covered work occurring solely as a consequence of using peer-to-peer transmission to receive a copy likewise does not require acceptance. However, nothing other than this License grants you permission to propagate or modify any covered work. These actions infringe copyright if you do not accept this License. Therefore, by modifying or propagating a covered work, you indicate your acceptance of this License to do so. 10. Automatic Licensing of Downstream Recipients. Each time you convey a covered work, the recipient automatically receives a license from the original licensors, to run, modify and propagate that work, subject to this License. You are not responsible for enforcing compliance by third parties with this License. An "entity transaction" is a transaction transferring control of an organization, or substantially all assets of one, or subdividing an organization, or merging organizations. If propagation of a covered work results from an entity transaction, each party to that transaction who receives a copy of the work also receives whatever licenses to the work the party's predecessor in interest had or could give under the previous paragraph, plus a right to possession of the Corresponding Source of the work from the predecessor in interest, if the predecessor has it or can get it with reasonable efforts. You may not impose any further restrictions on the exercise of the rights granted or affirmed under this License. For example, you may not impose a license fee, royalty, or other charge for exercise of rights granted under this License, and you may not initiate litigation (including a cross-claim or counterclaim in a lawsuit) alleging that any patent claim is infringed by making, using, selling, offering for sale, or importing the Program or any portion of it. 11. Patents. A "contributor" is a copyright holder who authorizes use under this License of the Program or a work on which the Program is based. The work thus licensed is called the contributor's "contributor version". A contributor's "essential patent claims" are all patent claims owned or controlled by the contributor, whether already acquired or hereafter acquired, that would be infringed by some manner, permitted by this License, of making, using, or selling its contributor version, but do not include claims that would be infringed only as a consequence of further modification of the contributor version. For purposes of this definition, "control" includes the right to grant patent sublicenses in a manner consistent with the requirements of this License. Each contributor grants you a non-exclusive, worldwide, royalty-free patent license under the contributor's essential patent claims, to make, use, sell, offer for sale, import and otherwise run, modify and propagate the contents of its contributor version. In the following three paragraphs, a "patent license" is any express agreement or commitment, however denominated, not to enforce a patent (such as an express permission to practice a patent or covenant not to sue for patent infringement). To "grant" such a patent license to a party means to make such an agreement or commitment not to enforce a patent against the party. If you convey a covered work, knowingly relying on a patent license, and the Corresponding Source of the work is not available for anyone to copy, free of charge and under the terms of this License, through a publicly available network server or other readily accessible means, then you must either (1) cause the Corresponding Source to be so available, or (2) arrange to deprive yourself of the benefit of the patent license for this particular work, or (3) arrange, in a manner consistent with the requirements of this License, to extend the patent license to downstream recipients. "Knowingly relying" means you have actual knowledge that, but for the patent license, your conveying the covered work in a country, or your recipient's use of the covered work in a country, would infringe one or more identifiable patents in that country that you have reason to believe are valid. If, pursuant to or in connection with a single transaction or arrangement, you convey, or propagate by procuring conveyance of, a covered work, and grant a patent license to some of the parties receiving the covered work authorizing them to use, propagate, modify or convey a specific copy of the covered work, then the patent license you grant is automatically extended to all recipients of the covered work and works based on it. A patent license is "discriminatory" if it does not include within the scope of its coverage, prohibits the exercise of, or is conditioned on the non-exercise of one or more of the rights that are specifically granted under this License. You may not convey a covered work if you are a party to an arrangement with a third party that is in the business of distributing software, under which you make payment to the third party based on the extent of your activity of conveying the work, and under which the third party grants, to any of the parties who would receive the covered work from you, a discriminatory patent license (a) in connection with copies of the covered work conveyed by you (or copies made from those copies), or (b) primarily for and in connection with specific products or compilations that contain the covered work, unless you entered into that arrangement, or that patent license was granted, prior to 28 March 2007. Nothing in this License shall be construed as excluding or limiting any implied license or other defenses to infringement that may otherwise be available to you under applicable patent law. 12. No Surrender of Others' Freedom. If conditions are imposed on you (whether by court order, agreement or otherwise) that contradict the conditions of this License, they do not excuse you from the conditions of this License. If you cannot convey a covered work so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not convey it at all. For example, if you agree to terms that obligate you to collect a royalty for further conveying from those to whom you convey the Program, the only way you could satisfy both those terms and this License would be to refrain entirely from conveying the Program. 13. Use with the GNU Affero General Public License. Notwithstanding any other provision of this License, you have permission to link or combine any covered work with a work licensed under version 3 of the GNU Affero General Public License into a single combined work, and to convey the resulting work. The terms of this License will continue to apply to the part which is the covered work, but the special requirements of the GNU Affero General Public License, section 13, concerning interaction through a network will apply to the combination as such. 14. Revised Versions of this License. The Free Software Foundation may publish revised and/or new versions of the GNU General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Program specifies that a certain numbered version of the GNU General Public License "or any later version" applies to it, you have the option of following the terms and conditions either of that numbered version or of any later version published by the Free Software Foundation. If the Program does not specify a version number of the GNU General Public License, you may choose any version ever published by the Free Software Foundation. If the Program specifies that a proxy can decide which future versions of the GNU General Public License can be used, that proxy's public statement of acceptance of a version permanently authorizes you to choose that version for the Program. Later license versions may give you additional or different permissions. However, no additional obligations are imposed on any author or copyright holder as a result of your choosing to follow a later version. 15. Disclaimer of Warranty. THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 16. Limitation of Liability. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. 17. Interpretation of Sections 15 and 16. If the disclaimer of warranty and limitation of liability provided above cannot be given local legal effect according to their terms, reviewing courts shall apply local law that most closely approximates an absolute waiver of all civil liability in connection with the Program, unless a warranty or assumption of liability accompanies a copy of the Program in return for a fee. ``` END OF TERMS AND CONDITIONS How to Apply These Terms to Your New Programs ``` If you develop a new program, and you want it to be of the greatest possible use to the public, the best way to achieve this is to make it free software which everyone can redistribute and change under these terms. To do so, attach the following notices to the program. It is safest to attach them to the start of each source file to most effectively state the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. ``` Copyright (C) This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . ``` Also add information on how to contact you by electronic and paper mail. If the program does terminal interaction, make it output a short notice like this when it starts in an interactive mode: ``` Copyright (C) This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'. This is free software, and you are welcome to redistribute it under certain conditions; type `show c' for details. ``` The hypothetical commands `show w' and `show c' should show the appropriate parts of the General Public License. Of course, your program's commands might be different; for a GUI interface, you would use an "about box". You should also get your employer (if you work as a programmer) or school, if any, to sign a "copyright disclaimer" for the program, if necessary. For more information on this, and how to apply and follow the GNU GPL, see . The GNU General Public License does not permit incorporating your program into proprietary programs. If your program is a subroutine library, you may consider it more useful to permit linking proprietary applications with the library. If this is what you want to do, use the GNU Lesser General Public License instead of this License. But first, please read . --- --- url: /en/vbman/filesystem/zip.md --- ## cZipArchive A pure VB6 single-class library for ZIP archive management. > Open source: https://github.com/wqweto/ZipArchive > Author: wqweto@gmail.com > License: MIT ### Usage Just add `cZipArchive.cls` to your project, then use it like this: #### Simple Compression ```vb With New cZipArchive .AddFile App.Path & "\your_file" .CompressArchive App.Path & "\test.zip" End With ``` #### Compress All Files and Subfolders ```vb With New cZipArchive .AddFromFolder "C:\Path\To\*.*", Recursive:=True .CompressArchive App.Path & "\archive.zip" End With ``` #### Extract All Files from an Archive ```vb With New cZipArchive .OpenArchive App.Path & "\test.zip" .Extract "C:\Path\To\extract_folder" End With ``` The `Extract` method can filter by file mask (e.g. `Filter:="*.doc"`), file index (e.g. `Filter:=15`), or a Boolean array (setting indexes to extract to `True`). #### Extract a Single File to a Specified Filename `OutputTarget` can include the target `new_filename`, used to rename when extracting a specific file from the archive. ```vb With New cZipArchive .OpenArchive App.Path & "\test.zip" .Extract "C:\Path\To\extract_folder\new_filename", Filter:="your_file" End With ``` #### Get Uncompressed Size of an Archive Entry Via the `FileInfo` property, using the entry filename as the first parameter and `zipIdxSize`: ```vb With New cZipArchive .OpenArchive App.Path & "\test.zip" Debug.Print .FileInfo("report.pdf", zipIdxSize) End With ``` #### List Files in a ZIP Archive Via the `FileInfo` property, using a numeric index as the first parameter: ```vb Dim lIdx As Long With New cZipArchive .OpenArchive App.Path & "\test.zip" For lIdx = 0 To .FileCount - 1 Debug.Print "FileName=" & .FileInfo(lIdx, zipIdxFileName) & ", Size=" & .FileInfo(lIdx, zipIdxSize) Next End With ``` Available values for the second parameter of `FileInfo`: | Value | Name | |-------|------| | `0` | `zipIdxFileName` | | `1` | `zipIdxAttributes` | | `2` | `zipIdxCrc32` | | `3` | `zipIdxSize` | | `4` | `zipIdxCompressedSize` | | `5` | `zipIdxComment` | | `6` | `zipIdxLastModified` | | `7` | `zipIdxMethod` | | `8` | `zipIdxOffset` | | `9` | `zipIdxFlags` | #### Encryption Support Make sure to set the conditional compilation argument `ZIP_CRYPTO = 1` in the "Make" tab of your project properties to compile encryption support from source. By default, encryption support is not compiled to reduce the final executable size. ```vb With New cZipArchive .OpenArchive App.Path & "\test.zip" .Extract App.Path & "\test", Password:="123456" End With ``` Use the `Password` parameter on the `AddFile` method, along with the `EncrStrength` parameter to set the encryption mode used when creating an archive. | EncrStrength | Mode | |-------------|------| | `0` | ZipCrypto (default) | | `1` | AES-128 | | `2` | AES-192 | | `3` | AES-256 (recommended) | Note: The default ZipCrypto encryption is weak, but it is the only option compatible with Windows Explorer's built-in zip folder support. #### Memory Operations The example utility function `ReadBinaryFile` in `/test/basic/Form1.frm` returns a byte array of file contents. ```vb Dim baZip() As Byte With New cZipArchive .AddFile ReadBinaryFile("sample.pdf"), "report.pdf" .CompressArchive baZip End With WriteBinaryFile "test.zip", baZip ``` The `Extract` method also supports a byte array as the target. ```vb Dim baOutput() As Byte With New cZipArchive .OpenArchive ReadBinaryFile("test.zip") .Extract baOutput, Filter:=0 '--- only the first file in the archive End With ``` ### TODO (Not Yet Supported) * Deflate64 (de)compressor * VBA7 (x64) support --- --- url: /zh.md --- :::::: tip 🎉 重磅消息：VBMAN 正式开源 **2026年6月1日**，历时九年打磨的 VBMAN 正式以 **[GPL v3](/vbman/LICENSE_GUIDE)** 协议开源！ > 从 2017 年的一个念头，到今天的开源项目，VBMAN 始终秉承一个信念： > **让 BASIC 语言在网络时代依然好用。** * **二进制永久免费** — 编译后的 DLL/OCX 无任何使用限制 * **源代码开放** — 遵循 [GPL v3 协议](/vbman/LICENSE_GUIDE)，欢迎 Fork、贡献、共建生态 * **商业授权可选** — 闭源商业项目直接使用 VBMAN.dll 完全无限制，如需嵌入源码可[联系获取授权](/vbman/LICENSE_GUIDE) [**访问代码仓库**](https://gitcode.com/woeoio/vbman) :::::: ## 🎯 为什么选择 VBMAN？ ```vb ' 几行代码，一个完整的 Web 服务器 ' === 1. 创建业务类 (bDemo.cls) === Public Sub Hello(ctx As cHttpServerContext) Dim id As Long: id = ctx.Request.QueryString("id") ctx.Response.Text "Hello VBMAN! id=" & id End Sub ' === 2. 启动服务器 (Form1.frm) === Dim HttpServer As New cHttpServer With HttpServer .Router.Reg "Demo", New bDemo ' 注册业务类 .Router.AutoRoute = True ' 开启自动路由 .Start 800 ' 启动服务器，监听 800 端口 End With MsgBox "Server running at http://localhost:800" ' 访问: http://127.0.0.1:800/demo/hello?id=123 ``` > 业务类不一定要独立的 cls 文件，你可以在 窗体内直接写 hello 函数，然后： ```vb .Router.Reg "Demo", Me ' 注册业务类 ``` VBMAN 是专为 VB6 / TwinBasic（TBMAN） 开发者打造的 **网络相关开发框架**： | 能力 | 传统 VB6 | VBMAN 加持 | | -------------- | ------------------ | ------------------------ | | HTTP 服务器 | ❌ 需外部组件 | ✅ 内置，几行代码启动 | | WebSocket | ❌ 不支持 | ✅ 原生支持 | | JSON 处理 | ❌ 手动解析 | ✅ 内置序列化/反序列化 | | 现代浏览器内核 | ❌ WebBrowser 老旧 | ✅ WebView2 (VBMAN2提供) | | 数据库操作 | ⚠️ ADO 繁琐 | ✅ 简化封装，开箱即用 | ## 📦 功能矩阵 | 模块 | 功能描述 | 状态 | | ------------- | ------------------------ | --------------------- | | `cHttpServer` | 嵌入式 HTTP/HTTPS 服务器 | ✅ 稳定可用 | | `cWebView2` | 现代浏览器控件 (VBMAN2) | ✅ 稳定可用 | | `cJson` | JSON 解析与生成 | ✅ 稳定可用 | | `cHttpClient` | HTTP 请求客户端 | ✅ 稳定可用 | | `cLogger` | 分级日志系统 | ✅ 稳定可用 | | `cDatabase` | 数据库操作封装 | ✅ 稳定可用 | | `cSocket` | 异步网络通信 | ✅ 基于 VbAsyncSocket | | `cAI` | AI 能力集成 | 🚧 VBMAN2 规划中 | | MQTT/Modbus | 物联网协议支持 | 🚧 开发中 | ## 🏗️ 项目历程 ``` 2017 ── 项目构思，BSMAN 框架蓝图诞生 │ 2023 ── ASPMAN 首个子项目落地 │ 2024 ── VBMAN 正式开发启动 │ 2025 ── TBMAN TwinBasic 迁移启动 │ 2026.06.01 ── VBMAN 正式开源 🎉 ``` ## 🌟 技术致谢 VBMAN 的诞生离不开以下优秀开源项目： | 项目 | 许可证 | 用途 | | -------------------------------------------------------- | ------ | ---------------- | | [VbAsyncSocket](https://github.com/wqweto/VbAsyncSocket) | MIT | 底层 Socket 通信 | | [VBA-JSON](https://github.com/VBA-tools/VBA-JSON) | MIT | JSON 处理引擎 | | [cTimer](http://sandsprite.com) | - | 高精度定时器 | [查看完整致谢列表](/CREDITS) :::::: info 📌 使用须知 VBMAN 系列产品**仅限合法用途**，严禁用于任何违法违规活动。 * 下载使用即代表同意 [最终用户许可协议](/EULA) * 使用者需自行承担使用过程中的法律责任 * 本站将依法配合国家有关部门的监管要求 **本网站与微软公司 (Microsoft Corporation) 无任何隶属或合作关系。** :::::: :::::: info 🌐 服务状态 实时监控： :::::: *** **Made with ❤️ by 邓伟 · [a-vi.com](https://a-vi.com)** [![License: GPL v3](https://img.shields.io/badge/License-GPLv3-blue.svg)](https://gitcode.com/woeoio/vbman/blob/main/LICENSE) [![Platform](https://img.shields.io/badge/Platform-Windows-orange.svg)](https://www.microsoft.com/windows) --- --- url: /zh/vbman/LICENSE.md --- GNU GENERAL PUBLIC LICENSE Version 3, 29 June 2007 Copyright (C) 2024-2026 邓伟 (VBMAN Project) This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . \============================================================================== VBMAN 项目许可补充说明 ============== 本软件采用 GNU General Public License v3.0 (GPL-3.0) 协议开源。 ## 一、二进制文件 本项目编译后的二进制文件（DLL、EXE 等）永久免费，无任何使用限制。 ## 二、源代码使用 1. 个人使用 个人用户可以免费使用本项目的源代码，但必须遵守 GPL 协议的规定， 包括但不限于： * 分发时必须附带 LICENSE 文件 * 修改后的作品也必须采用 GPL 兼容协议开源 2. 商业使用 * 如果您的商业项目基于本项目进行修改或二次开发，并且对外发布/销售， 则必须将整个项目的源代码开源，并采用 GPL 兼容协议。 * 如果您希望在闭源商业项目中使用本项目的源代码，必须联系作者购买 商业授权。 ## 三、商业授权 如需闭源商业授权，请联系： * 作者：邓伟 * 网站：https://a-vi.com 商业授权费用根据具体使用场景和范围协商确定。 ## 四、免责声明 本软件按"原样"提供，作者不对因使用本软件而产生的任何直接或间接损失 承担责任。 \============================================================================== 以下附上完整的 GNU GENERAL PUBLIC LICENSE Version 3 原文： *** GNU GENERAL PUBLIC LICENSE Version 3, 29 June 2007 Copyright (C) 2007 Free Software Foundation, Inc. Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. ``` Preamble ``` The GNU General Public License is a free, copyleft license for software and other kinds of works. The licenses for most software and other practical works are designed to take away your freedom to share and change the works. By contrast, the GNU General Public License is intended to guarantee your freedom to share and change all versions of a program--to make sure it remains free software for all its users. We, the Free Software Foundation, use the GNU General Public License for most of our software; it applies also to any other work released this way by its authors. You can apply it to your programs, too. When we speak of free software, we are referring to freedom, not price. Our General Public Licenses are designed to make sure that you have the freedom to distribute copies of free software (and charge for them if you wish), that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs, and that you know you can do these things. To protect your rights, we need to prevent others from denying you these rights or asking you to surrender the rights. Therefore, you have certain responsibilities if you distribute copies of the software, or if you modify it: responsibilities to respect the freedom of others. For example, if you distribute copies of such a program, whether gratis or for a fee, you must pass on to the recipients the same freedoms that you received. You must make sure that they, too, receive or can get the source code. And you must show them these terms so they know their rights. Developers that use the GNU GPL protect your rights with two steps: (1) assert copyright on the software, and (2) offer you this License giving you legal permission to copy, distribute and/or modify it. For the developers' and authors' protection, the GPL clearly explains that there is no warranty for this free software. For both users' and authors' sake, the GPL requires that modified versions be marked as changed, so that their problems will not be attributed erroneously to authors of previous versions. Some devices are designed to deny users access to install or run modified versions of the software inside them, although the manufacturer can do so. This is fundamentally incompatible with the aim of protecting users' freedom to change the software. The systematic pattern of such abuse occurs in the area of products for individuals to use, which is precisely where it is most unacceptable. Therefore, we have designed this version of the GPL to prohibit the practice for those products. If such problems arise substantially in other domains, we stand ready to extend this provision to those domains in future versions of the GPL, as needed to protect the freedom of users. Finally, every program is threatened constantly by software patents. States should not allow patents to restrict development and use of software on general-purpose computers, but in those that do, we wish to avoid the special danger that patents applied to a free program could make it effectively proprietary. To prevent this, the GPL assures that patents cannot be used to render the program non-free. The precise terms and conditions for copying, distribution and modification follow. ``` TERMS AND CONDITIONS ``` 0\. Definitions. "This License" refers to version 3 of the GNU General Public License. "Copyright" also means copyright-like laws that apply to other kinds of works, such as semiconductor masks. "The Program" refers to any copyrightable work licensed under this License. Each licensee is addressed as "you". "Licensees" and "recipients" may be individuals or organizations. To "modify" a work means to copy from or adapt all or part of the work in a fashion requiring copyright permission, other than the making of an exact copy. The resulting work is called a "modified version" of the earlier work or a work "based on" the earlier work. A "covered work" means either the unmodified Program or a work based on the Program. To "propagate" a work means to do anything with it that, without permission, would make you directly or secondarily liable for infringement under applicable copyright law, except executing it on a computer or modifying a private copy. Propagation includes copying, distribution (with or without modification), making available to the public, and in some countries other activities as well. To "convey" a work means any kind of propagation that enables other parties to make or receive copies. Mere interaction with a user through a computer network, with no transfer of a copy, is not conveying. An interactive user interface displays "Appropriate Legal Notices" to the extent that it includes a convenient and prominently visible feature that (1) displays an appropriate copyright notice, and (2) tells the user that there is no warranty for the work (except to the extent that warranties are provided), that licensees may convey the work under this License, and how to view a copy of this License. If the interface presents a list of user commands or options, such as a menu, a prominent item in the list meets this criterion. 1. Source Code. The "source code" for a work means the preferred form of the work for making modifications to it. "Object code" means any non-source form of a work. A "Standard Interface" means an interface that either is an official standard defined by a recognized standards body, or, in the case of interfaces specified for a particular programming language, one that is widely used among developers working in that language. The "System Libraries" of an executable work include anything, other than the work as a whole, that (a) is included in the normal form of packaging a Major Component, but which is not part of that Major Component, and (b) serves only to enable use of the work with that Major Component, or to implement a Standard Interface for which an implementation is available to the public in source code form. A "Major Component", in this context, means a major essential component (kernel, window system, and so on) of the specific operating system (if any) on which the executable work runs, or a compiler used to produce the work, or an object code interpreter used to run it. The "Corresponding Source" for a work in object code form means all the source code needed to generate, install, and (for an executable work) run the object code and to modify the work, including scripts to control those activities. However, it does not include the work's System Libraries, or general-purpose tools or generally available free programs which are used unmodified in performing those activities but which are not part of the work. For example, Corresponding Source includes interface definition files associated with source files for the work, and the source code for shared libraries and dynamically linked subprograms that the work is specifically designed to require, such as by intimate data communication or control flow between those subprograms and other parts of the work. The Corresponding Source need not include anything that users can regenerate automatically from other parts of the Corresponding Source. The Corresponding Source for a work in source code form is that same work. 2. Basic Permissions. All rights granted under this License are granted for the term of copyright on the Program, and are irrevocable provided the stated conditions are met. This License explicitly affirms your unlimited permission to run the unmodified Program. The output from running a covered work is covered by this License only if the output, given its content, constitutes a covered work. This License acknowledges your rights of fair use or other equivalent, as provided by copyright law. You may make, run and propagate covered works that you do not convey, without conditions so long as your license otherwise remains in force. You may convey covered works to others for the sole purpose of having them make modifications exclusively for you, or provide you with facilities for running those works, provided that you comply with the terms of this License in conveying all material for which you do not control copyright. Those thus making or running the covered works for you must do so exclusively on your behalf, under your direction and control, on terms that prohibit them from making any copies of your copyrighted material outside their relationship with you. Conveying under any other circumstances is permitted solely under the conditions stated below. Sublicensing is not allowed; section 10 makes it unnecessary. 3. Protecting Users' Legal Rights From Anti-Circumvention Law. No covered work shall be deemed part of an effective technological measure under any applicable law fulfilling obligations under article 11 of the WIPO copyright treaty adopted on 20 December 1996, or similar laws prohibiting or restricting circumvention of such measures. When you convey a covered work, you waive any legal power to forbid circumvention of technological measures to the extent such circumvention is effected by exercising rights under this License with respect to the covered work, and you disclaim any intention to limit operation or modification of the work as a means of enforcing, against the work's users, your or third parties' legal rights to forbid circumvention of technological measures. 4. Conveying Verbatim Copies. You may convey verbatim copies of the Program's source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice; keep intact all notices stating that this License and any non-permissive terms added in accord with section 7 apply to the code; keep intact all notices of the absence of any warranty; and give all recipients a copy of this License along with the Program. You may charge any price or no price for each copy that you convey, and you may offer support or warranty protection for a fee. 5. Conveying Modified Source Versions. You may convey a work based on the Program, or the modifications to produce it from the Program, in the form of source code under the terms of section 4, provided that you also meet all of these conditions: ``` a) The work must carry prominent notices stating that you modified it, and giving a relevant date. b) The work must carry prominent notices stating that it is released under this License and any conditions added under section 7. This requirement modifies the requirement in section 4 to "keep intact all notices". c) You must license the entire work, as a whole, under this License to anyone who comes into possession of a copy. This License will therefore apply, along with any applicable section 7 additional terms, to the whole of the work, and all its parts, regardless of how they are packaged. This License gives no permission to license the work in any other way, but it does not invalidate such permission if you have separately received it. d) If the work has interactive user interfaces, each must display Appropriate Legal Notices; however, if the Program has interactive interfaces that do not display Appropriate Legal Notices, your work need not make them do so. ``` A compilation of a covered work with other separate and independent works, which are not by their nature extensions of the covered work, and which are not combined with it such as to form a larger program, in or on a volume of a storage or distribution medium, is called an "aggregate" if the compilation and its resulting copyright are not used to limit the access or legal rights of the compilation's users beyond what the individual works permit. Inclusion of a covered work in an aggregate does not cause this License to apply to the other parts of the aggregate. 6. Conveying Non-Source Forms. You may convey a covered work in object code form under the terms of sections 4 and 5, provided that you also convey the machine-readable Corresponding Source under the terms of this License, in one of these ways: ``` a) Convey the object code in, or embodied in, a physical product (including a physical distribution medium), accompanied by the Corresponding Source fixed on a durable physical medium customarily used for software interchange. b) Convey the object code in, or embodied in, a physical product (including a physical distribution medium), accompanied by a written offer, valid for at least three years and valid for as long as you offer spare parts or customer support for that product model, to give anyone who possesses the object code either (1) a copy of the Corresponding Source for all the software in the product that is covered by this License, on a durable physical medium customarily used for software interchange, for a price no more than your reasonable cost of physically performing this conveying of source, or (2) access to copy the Corresponding Source from a network server at no charge. c) Convey individual copies of the object code with a copy of the written offer to provide the Corresponding Source. This alternative is allowed only occasionally and noncommercially, and only if you received the object code with such an offer, in accord with subsection 6b. d) Convey the object code by offering access from a designated place (gratis or for a charge), and offer equivalent access to the Corresponding Source in the same way through the same place at no further charge. You need not require recipients to copy the Corresponding Source along with the object code. If the place to copy the object code is a network server, the Corresponding Source may be on a different server (operated by you or a third party) that supports equivalent copying facilities, provided you maintain clear directions next to the object code saying where to find the Corresponding Source. Regardless of what server hosts the Corresponding Source, you remain obligated to ensure that it is available for as long as needed to satisfy these requirements. e) Convey the object code using peer-to-peer transmission, provided you inform other peers where the object code and Corresponding Source of the work are being offered to the general public at no charge under subsection 6d. ``` A separable portion of the object code, whose source code is excluded from the Corresponding Source as a System Library, need not be included in conveying the object code work. A "User Product" is either (1) a "consumer product", which means any tangible personal property which is normally used for personal, family, or household purposes, or (2) anything designed or sold for incorporation into a dwelling. In determining whether a product is a consumer product, doubtful cases shall be resolved in favor of coverage. For a particular product received by a particular user, "normally used" refers to a typical or common use of that class of product, regardless of the status of the particular user or of the way in which the particular user actually uses, or expects or is expected to use, the product. A product is a consumer product regardless of whether the product has substantial commercial, industrial or non-consumer uses, unless such uses represent the only significant mode of use of the product. "Installation Information" for a User Product means any methods, procedures, authorization keys, or other information required to install and execute modified versions of a covered work in that User Product from a modified version of its Corresponding Source. The information must suffice to ensure that the continued functioning of the modified object code is in no case prevented or interfered with solely because modification has been made. If you convey an object code work under this section in, or with, or specifically for use in, a User Product, and the conveying occurs as part of a transaction in which the right of possession and use of the User Product is transferred to the recipient in perpetuity or for a fixed term (regardless of how the transaction is characterized), the Corresponding Source conveyed under this section must be accompanied by the Installation Information. But this requirement does not apply if neither you nor any third party retains the ability to install modified object code on the User Product (for example, the work has been installed in ROM). The requirement to provide Installation Information does not include a requirement to continue to provide support service, warranty, or updates for a work that has been modified or installed by the recipient, or for the User Product in which it has been modified or installed. Access to a network may be denied when the modification itself materially and adversely affects the operation of the network or violates the rules and protocols for communication across the network. Corresponding Source conveyed, and Installation Information provided, in accord with this section must be in a format that is publicly documented (and with an implementation available to the public in source code form), and must require no special password or key for unpacking, reading or copying. 7. Additional Terms. "Additional permissions" are terms that supplement the terms of this License by making exceptions from one or more of its conditions. Additional permissions that are applicable to the entire Program shall be treated as though they were included in this License, to the extent that they are valid under applicable law. If additional permissions apply only to part of the Program, that part may be used separately under those permissions, but the entire Program remains governed by this License without regard to the additional permissions. When you convey a copy of a covered work, you may at your option remove any additional permissions from that copy, or from any part of it. (Additional permissions may be written to require their own removal in certain cases when you modify the work.) You may place additional permissions on material, added by you to a covered work, for which you have or can give appropriate copyright permission. Notwithstanding any other provision of this License, for material you add to a covered work, you may (if authorized by the copyright holders of that material) supplement the terms of this License with terms: ``` a) Disclaiming warranty or limiting liability differently from the terms of sections 15 and 16 of this License; or b) Requiring preservation of specified reasonable legal notices or author attributions in that material or in the Appropriate Legal Notices displayed by works containing it; or c) Prohibiting misrepresentation of the origin of that material, or requiring that modified versions of such material be marked in reasonable ways as different from the original version; or d) Limiting the use for publicity purposes of names of licensors or authors of the material; or e) Declining to grant rights under trademark law for use of some trade names, trademarks, or service marks; or f) Requiring indemnification of licensors and authors of that material by anyone who conveys the material (or modified versions of it) with contractual assumptions of liability to the recipient, for any liability that these contractual assumptions directly impose on those licensors and authors. ``` All other non-permissive additional terms are considered "further restrictions" within the meaning of section 10. If the Program as you received it, or any part of it, contains a notice stating that it is governed by this License along with a term that is a further restriction, you may remove that term. If a license document contains a further restriction but permits relicensing or conveying under this License, you may add to a covered work material governed by the terms of that license document, provided that the further restriction does not survive such relicensing or conveying. If you add terms to a covered work in accord with this section, you must place, in the relevant source files, a statement of the additional terms that apply to those files, or a notice indicating where to find the applicable terms. Additional terms, permissive or non-permissive, may be stated in the form of a separately written license, or stated as exceptions; the above requirements apply either way. 8. Termination. You may not propagate or modify a covered work except as expressly provided under this License. Any attempt otherwise to propagate or modify it is void, and will automatically terminate your rights under this License (including any patent licenses granted under the third paragraph of section 11). However, if you cease all violation of this License, then your license from a particular copyright holder is reinstated (a) provisionally, unless and until the copyright holder explicitly and finally terminates your license, and (b) permanently, if the copyright holder fails to notify you of the violation by some reasonable means prior to 60 days after the cessation. Moreover, your license from a particular copyright holder is reinstated permanently if the copyright holder notifies you of the violation by some reasonable means, this is the first time you have received notice of violation of this License (for any work) from that copyright holder, and you cure the violation prior to 30 days after your receipt of the notice. Termination of your rights under this section does not terminate the licenses of parties who have received copies or rights from you under this License. If your rights have been terminated and not permanently reinstated, you do not qualify to receive new licenses for the same material under section 10. 9. Acceptance Not Required for Having Copies. You are not required to accept this License in order to receive or run a copy of the Program. Ancillary propagation of a covered work occurring solely as a consequence of using peer-to-peer transmission to receive a copy likewise does not require acceptance. However, nothing other than this License grants you permission to propagate or modify any covered work. These actions infringe copyright if you do not accept this License. Therefore, by modifying or propagating a covered work, you indicate your acceptance of this License to do so. 10. Automatic Licensing of Downstream Recipients. Each time you convey a covered work, the recipient automatically receives a license from the original licensors, to run, modify and propagate that work, subject to this License. You are not responsible for enforcing compliance by third parties with this License. An "entity transaction" is a transaction transferring control of an organization, or substantially all assets of one, or subdividing an organization, or merging organizations. If propagation of a covered work results from an entity transaction, each party to that transaction who receives a copy of the work also receives whatever licenses to the work the party's predecessor in interest had or could give under the previous paragraph, plus a right to possession of the Corresponding Source of the work from the predecessor in interest, if the predecessor has it or can get it with reasonable efforts. You may not impose any further restrictions on the exercise of the rights granted or affirmed under this License. For example, you may not impose a license fee, royalty, or other charge for exercise of rights granted under this License, and you may not initiate litigation (including a cross-claim or counterclaim in a lawsuit) alleging that any patent claim is infringed by making, using, selling, offering for sale, or importing the Program or any portion of it. 11. Patents. A "contributor" is a copyright holder who authorizes use under this License of the Program or a work on which the Program is based. The work thus licensed is called the contributor's "contributor version". A contributor's "essential patent claims" are all patent claims owned or controlled by the contributor, whether already acquired or hereafter acquired, that would be infringed by some manner, permitted by this License, of making, using, or selling its contributor version, but do not include claims that would be infringed only as a consequence of further modification of the contributor version. For purposes of this definition, "control" includes the right to grant patent sublicenses in a manner consistent with the requirements of this License. Each contributor grants you a non-exclusive, worldwide, royalty-free patent license under the contributor's essential patent claims, to make, use, sell, offer for sale, import and otherwise run, modify and propagate the contents of its contributor version. In the following three paragraphs, a "patent license" is any express agreement or commitment, however denominated, not to enforce a patent (such as an express permission to practice a patent or covenant not to sue for patent infringement). To "grant" such a patent license to a party means to make such an agreement or commitment not to enforce a patent against the party. If you convey a covered work, knowingly relying on a patent license, and the Corresponding Source of the work is not available for anyone to copy, free of charge and under the terms of this License, through a publicly available network server or other readily accessible means, then you must either (1) cause the Corresponding Source to be so available, or (2) arrange to deprive yourself of the benefit of the patent license for this particular work, or (3) arrange, in a manner consistent with the requirements of this License, to extend the patent license to downstream recipients. "Knowingly relying" means you have actual knowledge that, but for the patent license, your conveying the covered work in a country, or your recipient's use of the covered work in a country, would infringe one or more identifiable patents in that country that you have reason to believe are valid. If, pursuant to or in connection with a single transaction or arrangement, you convey, or propagate by procuring conveyance of, a covered work, and grant a patent license to some of the parties receiving the covered work authorizing them to use, propagate, modify or convey a specific copy of the covered work, then the patent license you grant is automatically extended to all recipients of the covered work and works based on it. A patent license is "discriminatory" if it does not include within the scope of its coverage, prohibits the exercise of, or is conditioned on the non-exercise of one or more of the rights that are specifically granted under this License. You may not convey a covered work if you are a party to an arrangement with a third party that is in the business of distributing software, under which you make payment to the third party based on the extent of your activity of conveying the work, and under which the third party grants, to any of the parties who would receive the covered work from you, a discriminatory patent license (a) in connection with copies of the covered work conveyed by you (or copies made from those copies), or (b) primarily for and in connection with specific products or compilations that contain the covered work, unless you entered into that arrangement, or that patent license was granted, prior to 28 March 2007. Nothing in this License shall be construed as excluding or limiting any implied license or other defenses to infringement that may otherwise be available to you under applicable patent law. 12. No Surrender of Others' Freedom. If conditions are imposed on you (whether by court order, agreement or otherwise) that contradict the conditions of this License, they do not excuse you from the conditions of this License. If you cannot convey a covered work so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not convey it at all. For example, if you agree to terms that obligate you to collect a royalty for further conveying from those to whom you convey the Program, the only way you could satisfy both those terms and this License would be to refrain entirely from conveying the Program. 13. Use with the GNU Affero General Public License. Notwithstanding any other provision of this License, you have permission to link or combine any covered work with a work licensed under version 3 of the GNU Affero General Public License into a single combined work, and to convey the resulting work. The terms of this License will continue to apply to the part which is the covered work, but the special requirements of the GNU Affero General Public License, section 13, concerning interaction through a network will apply to the combination as such. 14. Revised Versions of this License. The Free Software Foundation may publish revised and/or new versions of the GNU General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Program specifies that a certain numbered version of the GNU General Public License "or any later version" applies to it, you have the option of following the terms and conditions either of that numbered version or of any later version published by the Free Software Foundation. If the Program does not specify a version number of the GNU General Public License, you may choose any version ever published by the Free Software Foundation. If the Program specifies that a proxy can decide which future versions of the GNU General Public License can be used, that proxy's public statement of acceptance of a version permanently authorizes you to choose that version for the Program. Later license versions may give you additional or different permissions. However, no additional obligations are imposed on any author or copyright holder as a result of your choosing to follow a later version. 15. Disclaimer of Warranty. THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 16. Limitation of Liability. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. 17. Interpretation of Sections 15 and 16. If the disclaimer of warranty and limitation of liability provided above cannot be given local legal effect according to their terms, reviewing courts shall apply local law that most closely approximates an absolute waiver of all civil liability in connection with the Program, unless a warranty or assumption of liability accompanies a copy of the Program in return for a fee. ``` END OF TERMS AND CONDITIONS How to Apply These Terms to Your New Programs ``` If you develop a new program, and you want it to be of the greatest possible use to the public, the best way to achieve this is to make it free software which everyone can redistribute and change under these terms. To do so, attach the following notices to the program. It is safest to attach them to the start of each source file to most effectively state the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. ``` Copyright (C) This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . ``` Also add information on how to contact you by electronic and paper mail. If the program does terminal interaction, make it output a short notice like this when it starts in an interactive mode: ``` Copyright (C) This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'. This is free software, and you are welcome to redistribute it under certain conditions; type `show c' for details. ``` The hypothetical commands `show w' and `show c' should show the appropriate parts of the General Public License. Of course, your program's commands might be different; for a GUI interface, you would use an "about box". You should also get your employer (if you work as a programmer) or school, if any, to sign a "copyright disclaimer" for the program, if necessary. For more information on this, and how to apply and follow the GNU GPL, see . The GNU General Public License does not permit incorporating your program into proprietary programs. If your program is a subroutine library, you may consider it more useful to permit linking proprietary applications with the library. If this is what you want to do, use the GNU Lesser General Public License instead of this License. But first, please read . --- --- url: /zh/vbman/devlog/_bak/dev.log.md --- 2025-01-23 v1.0.147 1. �޸��� UrlEncodeUtf8 �������� 2024-11-05 16:44:44 1. �Ż��� cJson ���� 2. ### ����ͳһ������, ���д��󶼻�ͨ����������� 3. ### ���Ӹ��ٶ�ջ, ֧�ִ����ջ, ���ܶ�ջ 4. ### ����ȫ���û����������������, ����û������������ 2024-10-27 16:44:44 1. �Ż��� cJson ���� 2024-10-15 14:08:08 1. #### �������Ӧ���ṩ��ѡ����, ������ļ�Ӧ���Զ�ʶ�� 2. #### ���ݿ��Page��ҳ����ûд�� 3. #### ·������"������"+"Ĭ���ĵ�" 2024-10-14 19:19:05 1. �޸��� ·�ɷ����޶�����ö��ֵ���� 2. �޸��� Db.Rows ������Ϊ˽�� 3. �޸��� ��� UTF8 �������� --- --- url: /zh/vbman/filesystem/zip.md --- ## cZipArchive 一个纯 VB6 单类库，用于 ZIP 压缩包管理。 > 开源来源：\ > 作者：wqweto@gmail.com\ > 许可证：MIT ### 使用方法 只需将 `cZipArchive.cls` 添加到你的项目中，然后像这样使用： #### 简单压缩 ```vb With New cZipArchive .AddFile App.Path & "\your_file" .CompressArchive App.Path & "\test.zip" End With ``` #### 压缩所有文件和子文件夹 ```vb With New cZipArchive .AddFromFolder "C:\Path\To\*.*", Recursive:=True .CompressArchive App.Path & "\archive.zip" End With ``` #### 解压压缩包中的所有文件 ```vb With New cZipArchive .OpenArchive App.Path & "\test.zip" .Extract "C:\Path\To\extract_folder" End With ``` `Extract` 方法可以按文件掩码（如 `Filter:="*.doc"`）、文件索引（如 `Filter:=15`）或布尔数组（需要解压的索引设为 `True`）进行过滤。 #### 提取单个文件到指定文件名 `OutputTarget` 可以包含目标 `new_filename`，用于从压缩包中提取特定文件时重命名。 ```vb With New cZipArchive .OpenArchive App.Path & "\test.zip" .Extract "C:\Path\To\extract_folder\new_filename", Filter:="your_file" End With ``` #### 获取压缩包条目未压缩大小 通过 `FileInfo` 属性，以条目文件名作为第一个参数，并使用 `zipIdxSize`： ```vb With New cZipArchive .OpenArchive App.Path & "\test.zip" Debug.Print .FileInfo("report.pdf", zipIdxSize) End With ``` #### 列出 ZIP 压缩包中的文件 通过 `FileInfo` 属性，以数字索引作为第一个参数： ```vb Dim lIdx As Long With New cZipArchive .OpenArchive App.Path & "\test.zip" For lIdx = 0 To .FileCount - 1 Debug.Print "FileName=" & .FileInfo(lIdx, zipIdxFileName) & ", Size=" & .FileInfo(lIdx, zipIdxSize) Next End With ``` `FileInfo` 第二个参数的可用值： | 值 | 名称 | |----|------| | `0` | `zipIdxFileName` | | `1` | `zipIdxAttributes` | | `2` | `zipIdxCrc32` | | `3` | `zipIdxSize` | | `4` | `zipIdxCompressedSize` | | `5` | `zipIdxComment` | | `6` | `zipIdxLastModified` | | `7` | `zipIdxMethod` | | `8` | `zipIdxOffset` | | `9` | `zipIdxFlags` | #### 加密支持 确保在项目属性的“生成”选项卡中设置条件编译参数 `ZIP_CRYPTO = 1`，以从源码编译加密支持。默认情况下不编译加密支持，以减小最终可执行文件的体积。 ```vb With New cZipArchive .OpenArchive App.Path & "\test.zip" .Extract App.Path & "\test", Password:="123456" End With ``` 在 `AddFile` 方法上使用 `Password` 参数，并配合 `EncrStrength` 参数来设置创建压缩包时使用的加密方式。 | EncrStrength | 模式 | |-------------|------| | `0` | ZipCrypto（默认） | | `1` | AES-128 | | `2` | AES-192 | | `3` | AES-256（推荐） | 注意：默认的 ZipCrypto 加密较弱，但它是唯一与 Windows 资源管理器内置 zip 文件夹支持兼容的选项。 #### 内存操作 `/test/basic/Form1.frm` 中的示例工具函数 `ReadBinaryFile` 返回文件内容的字节数组。 ```vb Dim baZip() As Byte With New cZipArchive .AddFile ReadBinaryFile("sample.pdf"), "report.pdf" .CompressArchive baZip End With WriteBinaryFile "test.zip", baZip ``` `Extract` 方法也支持字节数组作为目标。 ```vb Dim baOutput() As Byte With New cZipArchive .OpenArchive ReadBinaryFile("test.zip") .Extract baOutput, Filter:=0 '--- 仅压缩包中的第一个文件 End With ``` ### 待办事项（尚未支持） * Deflate64 (解)压缩器 * VBA7 (x64) 支持 --- --- url: /en/packages/vbccr/ranges/updown.md description: >- UpDown Control - VBCCR Development Manual, complete API reference based on source code --- # UpDown Control Provides a spin button for incrementing/decrementing numeric values, supporting buddy control synchronization, wrapping, and hexadecimal display. ## Enumerations ### UdnOrientationConstants Control orientation constants. | Constant | Value | Description | |----------|-------|-------------| | UdnOrientationVertical | 0 | Vertical orientation | | UdnOrientationHorizontal | 1 | Horizontal orientation | ### UdnNumberStyleConstants Number display style constants. | Constant | Value | Description | |----------|-------|-------------| | UdnNumberStyleDecimal | 0 | Decimal | | UdnNumberStyleHexadecimal | 1 | Hexadecimal | ## Properties ### Name ```vb Public Property Get Name() As String ``` Returns the name used to identify the object in code. ### Tag ```vb Public Property Get Tag() As String Public Property Let Tag(ByVal Value As String) ``` Stores extra data needed by the program. ### Parent ```vb Public Property Get Parent() As Object ``` Returns the object that contains this object. ### Container ```vb Public Property Get Container() As Object Public Property Set Container(ByVal Value As Object) ``` Returns/sets the container of the object. ### Left ```vb Public Property Get Left() As Single Public Property Let Left(ByVal Value As Single) ``` Returns/sets the distance between the left edge of the object and the left edge of its container. ### Top ```vb Public Property Get Top() As Single Public Property Let Top(ByVal Value As Single) ``` Returns/sets the distance between the top edge of the object and the top edge of its container. ### Width ```vb Public Property Get Width() As Single Public Property Let Width(ByVal Value As Single) ``` Returns/sets the width of the object. ### Height ```vb Public Property Get Height() As Single Public Property Let Height(ByVal Value As Single) ``` Returns/sets the height of the object. ### Visible ```vb Public Property Get Visible() As Boolean Public Property Let Visible(ByVal Value As Boolean) ``` Returns/sets whether the object is visible. ### ToolTipText ```vb Public Property Get ToolTipText() As String Public Property Let ToolTipText(ByVal Value As String) ``` Returns/sets the tooltip text displayed when the mouse hovers. ### WhatsThisHelpID ```vb Public Property Get WhatsThisHelpID() As Long Public Property Let WhatsThisHelpID(ByVal Value As Long) ``` Returns/sets the associated context help ID. ### DragIcon ```vb Public Property Get DragIcon() As IPictureDisp Public Property Let DragIcon(ByVal Value As IPictureDisp) Public Property Set DragIcon(ByVal Value As IPictureDisp) ``` Returns/sets the icon displayed during a drag-and-drop operation. ### DragMode ```vb Public Property Get DragMode() As Integer Public Property Let DragMode(ByVal Value As Integer) ``` Returns/sets the drag mode. ### hWnd ```vb Public Property Get hWnd() As LongPtr ``` Returns the control handle. ### hWndUserControl ```vb Public Property Get hWndUserControl() As LongPtr ``` Returns the UserControl handle. ### VisualStyles ```vb Public Property Get VisualStyles() As Boolean Public Property Let VisualStyles(ByVal Value As Boolean) ``` Returns/sets whether visual styles are enabled. Requires comctl32.dll version 6.0 or later. ### Enabled ```vb Public Property Get Enabled() As Boolean Public Property Let Enabled(ByVal Value As Boolean) ``` Returns/sets whether the object can respond to user events. ### OLEDropMode ```vb Public Property Get OLEDropMode() As OLEDropModeConstants Public Property Let OLEDropMode(ByVal Value As OLEDropModeConstants) ``` Returns/sets whether the object can act as an OLE drop target. ### MousePointer ```vb Public Property Get MousePointer() As CCMousePointerConstants Public Property Let MousePointer(ByVal Value As CCMousePointerConstants) ``` Returns/sets the type of mouse pointer displayed when hovering. See common enumerations. ### MouseIcon ```vb Public Property Get MouseIcon() As IPictureDisp Public Property Let MouseIcon(ByVal Value As IPictureDisp) Public Property Set MouseIcon(ByVal Value As IPictureDisp) ``` Returns/sets the custom mouse icon. ### MouseTrack ```vb Public Property Get MouseTrack() As Boolean Public Property Let MouseTrack(ByVal Value As Boolean) ``` Returns/sets whether events are fired when the mouse enters or leaves the control. ### RightToLeft ```vb Public Property Get RightToLeft() As Boolean Public Property Let RightToLeft(ByVal Value As Boolean) ``` Returns/sets the right-to-left display direction. ### RightToLeftLayout ```vb Public Property Get RightToLeftLayout() As Boolean Public Property Let RightToLeftLayout(ByVal Value As Boolean) ``` Returns/sets the right-to-left layout. ### RightToLeftMode ```vb Public Property Get RightToLeftMode() As CCRightToLeftModeConstants Public Property Let RightToLeftMode(ByVal Value As CCRightToLeftModeConstants) ``` Returns/sets the right-to-left mode. See common enumerations. ### BuddyControl ```vb Public Property Get BuddyControl() As Variant Public Property Let BuddyControl(ByVal Value As Variant) Public Property Set BuddyControl(ByVal Value As Variant) ``` Returns/sets the associated buddy control. ### BuddyProperty ```vb Public Property Get BuddyProperty() As String Public Property Let BuddyProperty(ByVal Value As String) ``` Returns/sets the property name of the buddy control used for data synchronization. ### SyncBuddy ```vb Public Property Get SyncBuddy() As Boolean Public Property Let SyncBuddy(ByVal Value As Boolean) ``` Returns/sets whether to automatically synchronize the value with the buddy control. ### Min ```vb Public Property Get Min() As Long Public Property Let Min(ByVal Value As Long) ``` Returns/sets the minimum value. ### Max ```vb Public Property Get Max() As Long Public Property Let Max(ByVal Value As Long) ``` Returns/sets the maximum value. ### Value ```vb Public Property Get Value() As Long Public Property Let Value(ByVal Value As Long) ``` Returns/sets the current value. ### Increment ```vb Public Property Get Increment() As Long Public Property Let Increment(ByVal Value As Long) ``` Returns/sets the increment/decrement amount per click. ### Wrap ```vb Public Property Get Wrap() As Boolean Public Property Let Wrap(ByVal Value As Boolean) ``` Returns/sets whether the value wraps. When True, exceeding the maximum value wraps to the minimum and vice versa. ### HotTracking ```vb Public Property Get HotTracking() As Boolean Public Property Let HotTracking(ByVal Value As Boolean) ``` Returns/sets whether hot tracking is enabled. ### Orientation ```vb Public Property Get Orientation() As UdnOrientationConstants Public Property Let Orientation(ByVal Value As UdnOrientationConstants) ``` Returns/sets the control orientation. ### ThousandsSeparator ```vb Public Property Get ThousandsSeparator() As Boolean Public Property Let ThousandsSeparator(ByVal Value As Boolean) ``` Returns/sets whether to display the thousands separator. ### NumberStyle ```vb Public Property Get NumberStyle() As UdnNumberStyleConstants Public Property Let NumberStyle(ByVal Value As UdnNumberStyleConstants) ``` Returns/sets the number display style. ## Methods ### OLEDrag ```vb Public Sub OLEDrag() ``` Initiates an OLE drag-and-drop operation. ### Drag ```vb Public Sub Drag(Optional ByRef Action As Variant) ``` Starts, ends, or cancels a drag operation. ### ZOrder ```vb Public Sub ZOrder(Optional ByRef Position As Variant) ``` Sets the Z-order. ### Refresh ```vb Public Sub Refresh() ``` Forces a complete repaint of the object. ### SyncFromBuddy ```vb Public Sub SyncFromBuddy() ``` Synchronizes the value from the buddy control to the UpDown control. ## Events ### DownClick ```vb Public Event DownClick() ``` Fired when the down/left button is clicked. ### UpClick ```vb Public Event UpClick() ``` Fired when the up/right button is clicked. ### BeforeChange ```vb Public Event BeforeChange(ByVal Value As Long, ByRef Delta As Long) ``` Fired before the value is about to change. Value is the current value, Delta is the expected change amount; modifying Delta controls the actual change. ### Change ```vb Public Event Change() ``` Fired after the value changes. ### MouseDown ```vb Public Event MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` Fired when a mouse button is pressed. ### MouseMove ```vb Public Event MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` Fired when the mouse is moved. ### MouseUp ```vb Public Event MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) ``` Fired when a mouse button is released. ### MouseEnter ```vb Public Event MouseEnter() ``` Fired when the mouse enters the control area. ### MouseLeave ```vb Public Event MouseLeave() ``` Fired when the mouse leaves the control area. ### OLECompleteDrag ```vb Public Event OLECompleteDrag(Effect As Long) ``` Fired when an OLE drag-and-drop operation completes. ### OLEDragDrop ```vb Public Event OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single) ``` Fired when data is dropped via an OLE drag-and-drop operation. ### OLEDragOver ```vb Public Event OLEDragOver(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single, State As Integer) ``` Fired when the mouse hovers during an OLE drag-and-drop operation. ### OLEGiveFeedback ```vb Public Event OLEGiveFeedback(Effect As Long, DefaultCursors As Boolean) ``` Fired when an OLE drag-and-drop operation gives feedback. ### OLESetData ```vb Public Event OLESetData(Data As DataObject, DataFormat As Integer) ``` Fired when an OLE drag-and-drop operation sets data. ### OLEStartDrag ```vb Public Event OLEStartDrag(Data As DataObject, AllowedEffects As Long) ``` Fired when an OLE drag-and-drop operation starts. ## Code Examples ### Basic Usage ```vb ' Set up the UpDown control With UpDown1 .Min = 0 .Max = 100 .Value = 50 .Increment = 5 .Wrap = True Set .BuddyControl = Text1 .BuddyProperty = "Text" .SyncBuddy = True End With ' Limit value change range Private Sub UpDown1_BeforeChange(ByVal Value As Long, ByRef Delta As Long) If Value + Delta > 100 Then Delta = 0 End Sub ' Respond to value change Private Sub UpDown1_Change() Debug.Print "Current value: " & UpDown1.Value End Sub ``` --- --- url: /en/cases.md description: >- VBMAN user case showcase - real-world projects in IoT, industrial control, web applications and more --- # User Cases Welcome to the **VBMAN User Cases** showcase! Here you'll find outstanding projects and real-world applications built with VBMAN products. Each case is a genuine validation of VBMAN's capabilities. ## Browse by Domain ### 🌡️ IoT / Internet of Things Device data cloud upload, sensor collection, remote control * [Lightweight IoT Cloud Platform](/en/cases/case-iot-cloud) — Read/write data with just a URL, supports ESP32/Arduino/Python ### 🏭 Industrial Control Device monitoring, data acquisition, Modbus communication * No real cases yet \[Placeholder, not actual] ### 🌐 Web Applications Backend management, online services, data visualization * No real cases yet \[Placeholder, not actual] ### 📚 Education / Office Online exams, library management, information systems * No real cases yet \[Placeholder, not actual] ## Browse by Core Module | VBMAN Module | Related Cases | | --- | --- | | **cHttpServer** | [Lightweight IoT Cloud Platform](/en/cases/case-iot-cloud) — REST API + CORS + Data Persistence | | **WebSocket** | More cases wanted... | | **Redis** | More cases wanted... | | **Database** | More cases wanted... | | **WebView2** | More cases wanted... | | **Modbus** | More cases wanted... | ## Browse by Difficulty | Difficulty | Case | Description | | --- | --- | --- | | 🟢 Beginner | None yet | Suitable for developers new to VBMAN | | 🟡 Intermediate | [Lightweight IoT Cloud Platform](/en/cases/case-iot-cloud) | Requires understanding of routing, JSON, data storage | | 🔴 Advanced | None yet | Involves multi-module collaboration, complex business logic | ## Submit Your Case We believe **every VB6 developer is an artist**, and your work deserves to be seen by more people! ### Submission Methods 1. **GitHub PR (Recommended)**: Fork the project → create `case-xxx.md` under `docs/en/cases/` → submit a PR 2. **Email**: Send to **cases@vb6.pro**, subject format: `[User Case] Project Name - Author Name` 3. **QQ Group**: Contact the group admin to submit ### Suggested Submission Content ```markdown --- title: Project Name description: One-line project description category: Application domain (IoT/Industrial Control/Web App/Education & Office) tags: [Core module tags] difficulty: Beginner/Intermediate/Advanced author: Author Name date: Date --- # Project Name > One-line highlight ## Project Overview (Basic information table) ## VBMAN Technical Implementation (Which VBMAN modules are used, key code snippets) ## Results (Screenshots, data, deployment scale, etc.) ## Project Highlights Summary (Highlights table) ``` :::: tip Note Submitting a case means you agree to display it on the official website. All submissions are subject to content review. Anonymous display is supported. :::: --- --- url: /en/vbman/database/utilities.md --- # Utility Methods This document details the various utility methods provided by the cDataBase class to simplify common database operations. *** ## Table of Contents * [Count Method](#count-method) * [LastInsertId Method](#lastinsertid-method) * [TableExists Method](#tableexists-method) * [GetTableFields Method](#gettablefields-method) * [GetTables Method](#gettables-method) * [GetDatabases Method](#getdatabases-method) * [GetVersion Method](#getversion-method) * [Escape Method](#escape-method) * [CheckConnection Method](#checkconnection-method) *** ## Count Method ### Syntax Counts the number of records in a table. ```vb Function Count(Optional ByVal TableName As String = "") As Long ``` ### Parameters | Parameter | Type | Description | | --------- | ---- | ----------- | | `TableName` | `String` | Table name (optional, uses current SQL if empty) | ### Return Value Returns record count (`Long` type). ### Example ```vb ' Count records in specified table Dim lCount As Long lCount = db.Count("users") Debug.Print "Total users: " & lCount ' Count records in current SQL query result db.Sql("SELECT * FROM users WHERE age > 18") lCount = db.Count() ' Use current SQL Debug.Print "Adult users: " & lCount ``` ### Implementation ```vb ' If table name specified SELECT COUNT(*) AS cnt FROM users ' If using current SQL SELECT COUNT(*) AS cnt FROM (SELECT * FROM users WHERE age > 18) AS T ``` *** ## LastInsertId Method ### Syntax Gets the auto-increment primary key ID of the last insert. ```vb Function LastInsertId() As Variant ``` ### Return Value Returns last inserted ID (`Variant` type). ### Supported Databases | Database | Implementation | | -------- | -------------- | | SQL Server | `SCOPE_IDENTITY()` | | MySQL | `LAST_INSERT_ID()` | | Access | `@@IDENTITY` | ### Example ```vb ' Insert data If db.Sql("INSERT INTO users (name, age) VALUES ('John', 25)").Exec Then ' Get last inserted ID Dim lId As Variant lId = db.LastInsertId Debug.Print "New user ID: " & lId End If ``` ### Notes 1. **Must call immediately after INSERT** ```vb ' Correct db.Sql("INSERT INTO users (name) VALUES ('John')").Exec Dim lId As Variant lId = db.LastInsertId ' Wrong: Other operations in between db.Sql("INSERT INTO users (name) VALUES ('John')").Exec db.Sql("SELECT * FROM users").Query ' This resets the ID Dim lId As Variant lId = db.LastInsertId ' May not get the correct ID ``` 2. **Only supports auto-increment primary key** ```vb ' Table must have auto-increment primary key CREATE TABLE users ( id INT IDENTITY(1,1) PRIMARY KEY, -- SQL Server name NVARCHAR(50) ) ``` *** ## TableExists Method ### Syntax Checks if a table exists. ```vb Function TableExists(ByVal TableName As String) As Boolean ``` ### Parameters | Parameter | Type | Description | | --------- | ---- | ----------- | | `TableName` | `String` | Table name (required) | ### Return Value * `True` - Table exists * `False` - Table does not exist ### Supported Databases | Database | Implementation | | -------- | -------------- | | SQL Server | `INFORMATION_SCHEMA.TABLES` | | MySQL | `INFORMATION_SCHEMA.TABLES` | | Access | `MSysObjects` | ### Example ```vb ' Check if table exists If db.TableExists("users") Then Debug.Print "users table exists" Else Debug.Print "users table does not exist" ' Create table db.Sql("CREATE TABLE users (id INT PRIMARY KEY, name NVARCHAR(50))").Exec End If ``` ### Usage Scenarios ```vb ' Scenario 1: Check before creating table If Not db.TableExists("users") Then db.Sql("CREATE TABLE users (...)").Exec End If ' Scenario 2: Check before deleting table If db.TableExists("temp_table") Then db.Sql("DROP TABLE temp_table").Exec End If ``` *** ## GetTableFields Method ### Syntax Gets the field list of a table. ```vb Function GetTableFields(ByVal TableName As String) As Collection ``` ### Parameters | Parameter | Type | Description | | --------- | ---- | ----------- | | `TableName` | `String` | Table name (required) | ### Return Value Returns field name collection (`Collection` type). ### Supported Databases | Database | Implementation | | -------- | -------------- | | SQL Server | `INFORMATION_SCHEMA.COLUMNS` | | MySQL | `INFORMATION_SCHEMA.COLUMNS` | | Access | `MSysObjects` | ### Example ```vb ' Get field list Dim colFields As Collection Set colFields = db.GetTableFields("users") ' Iterate fields Dim i As Long For i = 1 To colFields.Count Debug.Print "Field " & i & ": " & colFields(i) Next ``` ### Usage Scenarios ```vb ' Scenario 1: Dynamically generate SQL Function BuildSelectSQL(sTableName As String) As String Dim colFields As Collection Set colFields = db.GetTableFields(sTableName) Dim sFields As String Dim i As Long For i = 1 To colFields.Count If sFields <> "" Then sFields = sFields & ", " sFields = sFields & colFields(i) Next BuildSelectSQL = "SELECT " & sFields & " FROM " & sTableName End Function ' Scenario 2: Validate if field exists Function FieldExists(sTableName As String, sFieldName As String) As Boolean Dim colFields As Collection Set colFields = db.GetTableFields(sTableName) Dim i As Long For i = 1 To colFields.Count If colFields(i) = sFieldName Then FieldExists = True Exit Function End If Next FieldExists = False End Function ``` *** ## GetTables Method ### Syntax Gets the table name list in the database. ```vb Function GetTables(Optional ByVal DatabaseName As String = "") As Collection ``` ### Parameters | Parameter | Type | Description | | --------- | ---- | ----------- | | `DatabaseName` | `String` | Database name (optional, uses current database if empty) | ### Return Value Returns table name collection (`Collection` type). ### Supported Databases | Database | Implementation | | -------- | -------------- | | SQL Server | `INFORMATION_SCHEMA.TABLES` | | MySQL | `INFORMATION_SCHEMA.TABLES` | | Access | `MSysObjects` | ### Example ```vb ' Get table list of current database Dim colTables As Collection Set colTables = db.GetTables() ' Iterate table names Dim i As Long For i = 1 To colTables.Count Debug.Print "Table " & i & ": " & colTables(i) Next ' Get table list of specified database (SQL Server/MySQL) Set colTables = db.GetTables("mydb") ``` ### Usage Scenarios ```vb ' Scenario 1: List all tables Sub ListAllTables() Dim colTables As Collection Set colTables = db.GetTables() Dim i As Long For i = 1 To colTables.Count Debug.Print colTables(i) Next End Sub ' Scenario 2: Backup all tables Sub BackupAllTables() Dim colTables As Collection Set colTables = db.GetTables() Dim i As Long For i = 1 To colTables.Count Dim sTableName As String sTableName = colTables(i) db.Sql("SELECT * INTO " & sTableName & "_backup FROM " & sTableName).Exec Next End Sub ``` *** ## GetDatabases Method ### Syntax Gets the database list on the database server. ```vb Function GetDatabases() As Collection ``` ### Return Value Returns database name collection (`Collection` type). ### Supported Databases | Database | Implementation | | -------- | -------------- | | SQL Server | `sys.databases` | | MySQL | `SHOW DATABASES` | ### Example ```vb ' Get database list Dim colDatabases As Collection Set colDatabases = db.GetDatabases() ' Iterate database names Dim i As Long For i = 1 To colDatabases.Count Debug.Print "Database " & i & ": " & colDatabases(i) Next ``` ### Usage Scenarios ```vb ' Scenario 1: List all databases Sub ListAllDatabases() Dim colDatabases As Collection Set colDatabases = db.GetDatabases() Dim i As Long For i = 1 To colDatabases.Count Debug.Print colDatabases(i) Next End Sub ' Scenario 2: Switch database Sub SwitchDatabase(sDatabaseName As String) ' Check if database exists Dim colDatabases As Collection Set colDatabases = db.GetDatabases() Dim i As Long Dim bExists As Boolean bExists = False For i = 1 To colDatabases.Count If colDatabases(i) = sDatabaseName Then bExists = True Exit For End If Next If bExists Then db.Sql("USE " & sDatabaseName).Exec Else Debug.Print "Database does not exist: " & sDatabaseName End If End Sub ``` *** ## GetVersion Method ### Syntax Gets database version information. ```vb Function GetVersion() As String ``` ### Return Value Returns version string (`String` type). ### Example ```vb ' Get database version Dim sVersion As String sVersion = db.GetVersion Debug.Print "Database version: " & sVersion ``` ### Usage Scenarios ```vb ' Scenario 1: Check database version Sub CheckDatabaseVersion() Dim sVersion As String sVersion = db.GetVersion Debug.Print "Current database version: " & sVersion End Sub ' Scenario 2: Version compatibility check Function IsVersionCompatible(sMinVersion As String) As Boolean Dim sVersion As String sVersion = db.GetVersion ' Version comparison logic... IsVersionCompatible = True End Function ``` *** ## Escape Method ### Syntax Escapes special characters in SQL strings (prevents SQL injection). ```vb Function Escape(ByVal Str As String) As String ``` ### Parameters | Parameter | Type | Description | | --------- | ---- | ----------- | | `Str` | `String` | String to escape (required) | ### Return Value Returns escaped string (`String` type). ### Implementation Converts single quote `'` to two single quotes `''`. ### Example ```vb ' Escape string Dim sName As String sName = "O'Brien" Dim sEscaped As String sEscaped = db.Escape(sName) ' Result: "O''Brien" ' Use escaped string db.Sql("SELECT * FROM users WHERE name = '" & sEscaped & "'").Query ``` ### Notes **Recommended to use parameterized queries instead of Escape method**: ```vb ' Recommended: Use parameterized query db.Sql("SELECT * FROM users WHERE name = ?") _ .Param("name", "O'Brien", VBMAN.adVarWChar) _ .QueryParam ' OK alternative: Use Escape (but not as safe as parameterized query) db.Sql("SELECT * FROM users WHERE name = '" & db.Escape("O'Brien") & "'").Query ``` *** ## CheckConnection Method ### Syntax Checks connection state and attempts to reconnect. ```vb Function CheckConnection() As Boolean ``` ### Return Value * `True` - Connection normal or reconnection successful * `False` - Connection lost and reconnection failed ### Functionality 1. Check connection state 2. If disconnected, attempt to reconnect 3. Update connection flag ### Example ```vb ' Check connection If Not db.CheckConnection Then Debug.Print "Connection lost, attempting to reconnect..." ' Reconnect db.Connect VBMAN.enumDbType_MsSql, "127.0.0.1,1433", "sa", "pwd", "mydb" End If ``` ### Usage Scenarios ```vb ' Scenario 1: Regular connection check Private Sub Timer1_Timer() If Not db.CheckConnection Then Debug.Print "Connection lost, need to reconnect" End If End Sub ' Scenario 2: Check connection before operation Sub ExecuteQuery() ' Check connection If Not db.CheckConnection Then Debug.Print "Connection unavailable" Exit Sub End If ' Execute query db.Sql("SELECT * FROM users").Query End Sub ``` *** ## Comprehensive Examples ### Example 1: Database Info Viewer ```vb Sub ShowDatabaseInfo() ' Show database version Debug.Print "Database version: " & db.GetVersion ' Show database list Dim colDatabases As Collection Set colDatabases = db.GetDatabases() Debug.Print "Database list:" Dim i As Long For i = 1 To colDatabases.Count Debug.Print " - " & colDatabases(i) Next ' Show table list Dim colTables As Collection Set colTables = db.GetTables() Debug.Print "Table list:" For i = 1 To colTables.Count Debug.Print " - " & colTables(i) ' Show fields of each table Dim colFields As Collection Set colFields = db.GetTableFields(colTables(i)) Dim j As Long For j = 1 To colFields.Count Debug.Print " * " & colFields(j) Next Next End Sub ``` ### Example 2: Table Structure Comparison ```vb Function CompareTableStructure(sTable1 As String, sTable2 As String) As Boolean Dim colFields1 As Collection Dim colFields2 As Collection Set colFields1 = db.GetTableFields(sTable1) Set colFields2 = db.GetTableFields(sTable2) ' Compare field count If colFields1.Count <> colFields2.Count Then CompareTableStructure = False Exit Function End If ' Compare field names Dim i As Long For i = 1 To colFields1.Count If colFields1(i) <> colFields2(i) Then CompareTableStructure = False Exit Function End If Next CompareTableStructure = True End Function ``` *** **Last Updated**: 2026-01-21 --- --- url: /zh/packages/vbccr.md description: VBCCR 开发手册 - VBCCR 开发手册，基于源码的完整 API 参考 --- # VBCCR 开发手册 VBCCR（VB Common Controls Replacement）是 Visual Basic 6 中 Microsoft 通用控件 (MSComCtl) 的全面替代库，由 [Kr00l](https://github.com/Kr00l/VBCCR) 开发维护。在保持与原始控件兼容的同时，提供增强的功能、改进的视觉外观，以及**完整的 Unicode 支持**。 **核心优势：解决了原生 VB6 窗体控件上显示 Unicode 字符的乱码问题。** 本文档基于 VBCCR 1.8 源码编写，所有接口信息均来自实际代码，确保准确性。 ## 快速入门 1. 从 [GitHub 仓库](https://github.com/Kr00l/VBCCR) 下载 VBCCR 库 2. 在系统中注册 OCX 文件：`regsvr32 VBCCR18.OCX` 3. 在 VB6 项目中添加对 VBCCR 控件的引用 4. 在窗体中使用增强控件 ## 包含的控件 ### 按钮类 (buttons) | 控件 | 类名 | 说明 | |------|------|------| | [CheckBoxW](./buttons/checkboxw) | CheckBoxW | Unicode 复选框控件 | | [CommandButtonW](./buttons/commandbuttonw) | CommandButtonW | Unicode 命令按钮控件 | | [CommandLink](./buttons/commandlink) | CommandLink | 命令链接控件 | | [OptionButtonW](./buttons/optionbuttonw) | OptionButtonW | Unicode 选项按钮控件 | ### 文本标签类 (text) | 控件 | 类名 | 说明 | |------|------|------| | [TextBoxW](./text/textboxw) | TextBoxW | Unicode 文本框控件 | | [RichTextBox](./text/richtextbox) | RichTextBox | 富文本框控件 | | [SpinBox](./text/spinbox) | SpinBox | 数字调节框控件 | | [LabelW](./text/labelw) | LabelW | Unicode 标签控件 | | [WindowedLabel](./text/windowedlabel) | WindowedLabel | 窗口化标签控件 | | [LinkLabel](./text/linklabel) | LinkLabel | 链接标签控件 | | [HotKey](./text/hotkey) | HotKey | 热键控件 | ### 列表选择类 (lists) | 控件 | 类名 | 说明 | |------|------|------| | [ComboBoxW](./lists/comboboxw) | ComboBoxW | Unicode 组合框控件 | | [ListBoxW](./lists/listboxw) | ListBoxW | Unicode 列表框控件 | | [FontCombo](./lists/fontcombo) | FontCombo | 字体选择组合框控件 | | [ImageCombo](./lists/imagecombo) | ImageCombo | 图像组合框控件 | | [IPAddress](./lists/ipaddress) | IPAddress | IP 地址控件 | | [VirtualCombo](./lists/virtualcombo) | VirtualCombo | 虚拟组合框控件 | | [VListBox](./lists/vlistbox) | VListBox | 虚拟列表框控件 | ### 视图类 (views) | 控件 | 类名 | 说明 | |------|------|------| | [ListView](./views/listview) | ListView | 列表视图控件 | | [TreeView](./views/treeview) | TreeView | 树形视图控件 | | [TabStrip](./views/tabstrip) | TabStrip | 选项卡控件 | ### 工具条/状态栏类 (bars) | 控件 | 类名 | 说明 | |------|------|------| | [ToolBar](./bars/toolbar) | ToolBar | 工具栏控件 | | [StatusBar](./bars/statusbar) | StatusBar | 状态栏控件 | | [CoolBar](./bars/coolbar) | CoolBar | 可停靠工具条控件 | | [Pager](./bars/pager) | Pager | 分页控件 | ### 滑块/进度/调节类 (ranges) | 控件 | 类名 | 说明 | |------|------|------| | [Slider](./ranges/slider) | Slider | 滑块控件 | | [ProgressBar](./ranges/progressbar) | ProgressBar | 进度条控件 | | [UpDown](./ranges/updown) | UpDown | 上下调节控件 | | [Animation](./ranges/animation) | Animation | 动画播放控件 | ### 日期时间类 (datetime) | 控件 | 类名 | 说明 | |------|------|------| | [DTPicker](./datetime/dtpicker) | DTPicker | 日期时间选择器控件 | | [MonthView](./datetime/monthview) | MonthView | 月历视图控件 | ### 对话框/系统/容器/多媒体类 (system) | 控件 | 类名 | 说明 | |------|------|------| | [CommonDialog](./system/commondialog) | CommonDialog | 通用对话框类 | | [SysInfo](./system/sysinfo) | SysInfo | 系统信息控件 | | [ImageList](./system/imagelist) | ImageList | 图像列表控件 | | [FrameW](./system/framew) | FrameW | Unicode 框架控件 | | [MCIWnd](./system/mciwnd) | MCIWnd | 多媒体控件 | ## 公共辅助模块 VBCCR 还提供以下公共辅助模块，供所有控件共享使用： | 模块 | 文件 | 说明 | |------|------|------| | Common | Common.bas | 通用工具函数（MsgBox、SendKeys Unicode 版本，剪贴板操作，DPI 辅助，图片处理等） | | VisualStyles | VisualStyles.bas | 视觉样式管理（ActivateVisualStyles、RemoveVisualStyles、GetComCtlVersion） | | ISubclass | ISubclass.cls | 子类化接口 | | ComCtlsBase | ComCtlsBase.bas | 控件基础模块 | | VTableHandle | VTableHandle.bas | VTable 处理模块 | ## 通用枚举 以下枚举在多个控件中共享使用： ### CCAppearanceConstants | 常量 | 值 | 说明 | |------|-----|------| | cc2D | 0 | 平面外观 | | cc3D | 1 | 三维外观 | ### CCLeftRightAlignmentConstants | 常量 | 值 | 说明 | |------|-----|------| | ccLeft | 0 | 左对齐 | | ccRight | 1 | 右对齐 | ### CCVerticalAlignmentConstants | 常量 | 值 | 说明 | |------|-----|------| | ccTop | 0 | 顶部对齐 | | ccBottom | 1 | 底部对齐 | | ccVCenter | 2 | 垂直居中 | ### CCMousePointerConstants | 常量 | 值 | |------|-----| | ccDefault | 0 | | ccArrow | 1 | | ccCrosshair | 2 | | ccIBeam | 3 | | ccIcon | 4 | | ccSize | 5 | | ccSizeNESW | 6 | | ccSizeNS | 7 | | ccSizeNWSE | 8 | | ccSizeWE | 9 | | ccUpArrow | 10 | | ccHourglass | 11 | | ccNoDrop | 12 | | ccArrowHourglass | 13 | | ccArrowQuestion | 14 | | ccSizeAll | 15 | | ccCustom | 99 | ### CCRightToLeftModeConstants | 常量 | 值 | 说明 | |------|-----|------| | ccRtlModeNo | 0 | 无 RTL | | ccRtlModeStandard | 1 | 标准 RTL | | ccRtlModeV2 | 2 | V2 模式 RTL | ### CCIMEModeConstants | 常量 | 值 | |------|-----| | ccIMENoControl | 0 | | ccIMEOn | 1 | | ccIMEOff | 2 | | ccIMEDisable | 3 | | ccIMEHiragana | 4 | | ccIMEKatakanaDbl | 5 | | ccIMEKatakanaSng | 6 | | ccIMEAlphaDbl | 7 | | ccIMEAlphaSng | 8 | | ccIMEHangulDbl | 9 | | ccIMEHangulSng | 10 | ### OLEDropModeConstants | 常量 | 值 | |------|-----| | ccOLEDropNone | 0 | | ccOLEDropManual | 1 | ## 作者原文档 VBCCR 作者 Kr00l 编写的官方文档（中文翻译），涵盖 StdEXE/OCX 版本使用指南、OCX2StdEXE 工具说明、编译选项及版本历史等： [阅读作者原文档](./author) ## 附加资源 * [VBCCR GitHub 仓库](https://github.com/Kr00l/VBCCR) * [VBForums 讨论帖](https://www.vbforums.com/showthread.php?841929-VB6-ActiveX-CommonControls) --- --- url: /en/packages/vbccr.md description: VBCCR Development Manual - Complete API reference based on source code --- # VBCCR Development Manual VBCCR (VB Common Controls Replacement) is a comprehensive replacement library for the Microsoft Common Controls (MSComCtl) in Visual Basic 6, developed and maintained by [Kr00l](https://github.com/Kr00l/VBCCR). While maintaining compatibility with the original controls, it provides enhanced functionality, improved visual appearance, and **full Unicode support**. **Key advantage: Resolves the garbled text issue when displaying Unicode characters on native VB6 form controls.** This documentation is based on the VBCCR 1.8 source code. All interface information is derived from the actual code to ensure accuracy. ## Quick Start 1. Download the VBCCR library from the [GitHub repository](https://github.com/Kr00l/VBCCR) 2. Register the OCX file on your system: `regsvr32 VBCCR18.OCX` 3. Add a reference to the VBCCR controls in your VB6 project 4. Use the enhanced controls on your forms ## Included Controls ### Buttons | Control | Class Name | Description | |---------|-----------|-------------| | [CheckBoxW](./buttons/checkboxw) | CheckBoxW | Unicode CheckBox control | | [CommandButtonW](./buttons/commandbuttonw) | CommandButtonW | Unicode CommandButton control | | [CommandLink](./buttons/commandlink) | CommandLink | CommandLink control | | [OptionButtonW](./buttons/optionbuttonw) | OptionButtonW | Unicode OptionButton control | ### Text | Control | Class Name | Description | |---------|-----------|-------------| | [TextBoxW](./text/textboxw) | TextBoxW | Unicode TextBox control | | [RichTextBox](./text/richtextbox) | RichTextBox | RichTextBox control | | [SpinBox](./text/spinbox) | SpinBox | SpinBox control | | [LabelW](./text/labelw) | LabelW | Unicode Label control | | [WindowedLabel](./text/windowedlabel) | WindowedLabel | Windowed Label control | | [LinkLabel](./text/linklabel) | LinkLabel | LinkLabel control | | [HotKey](./text/hotkey) | HotKey | HotKey control | ### Lists | Control | Class Name | Description | |---------|-----------|-------------| | [ComboBoxW](./lists/comboboxw) | ComboBoxW | Unicode ComboBox control | | [ListBoxW](./lists/listboxw) | ListBoxW | Unicode ListBox control | | [FontCombo](./lists/fontcombo) | FontCombo | Font selection ComboBox control | | [ImageCombo](./lists/imagecombo) | ImageCombo | Image ComboBox control | | [IPAddress](./lists/ipaddress) | IPAddress | IP Address control | | [VirtualCombo](./lists/virtualcombo) | VirtualCombo | Virtual ComboBox control | | [VListBox](./lists/vlistbox) | VListBox | Virtual ListBox control | ### Views | Control | Class Name | Description | |---------|-----------|-------------| | [ListView](./views/listview) | ListView | ListView control | | [TreeView](./views/treeview) | TreeView | TreeView control | | [TabStrip](./views/tabstrip) | TabStrip | TabStrip control | ### Bars | Control | Class Name | Description | |---------|-----------|-------------| | [ToolBar](./bars/toolbar) | ToolBar | ToolBar control | | [StatusBar](./bars/statusbar) | StatusBar | StatusBar control | | [CoolBar](./bars/coolbar) | CoolBar | Dockable toolbar control | | [Pager](./bars/pager) | Pager | Pager control | ### Ranges | Control | Class Name | Description | |---------|-----------|-------------| | [Slider](./ranges/slider) | Slider | Slider control | | [ProgressBar](./ranges/progressbar) | ProgressBar | ProgressBar control | | [UpDown](./ranges/updown) | UpDown | UpDown control | | [Animation](./ranges/animation) | Animation | Animation control | ### Date/Time | Control | Class Name | Description | |---------|-----------|-------------| | [DTPicker](./datetime/dtpicker) | DTPicker | DateTimePicker control | | [MonthView](./datetime/monthview) | MonthView | MonthView control | ### System | Control | Class Name | Description | |---------|-----------|-------------| | [CommonDialog](./system/commondialog) | CommonDialog | Common Dialog class | | [SysInfo](./system/sysinfo) | SysInfo | System Information control | | [ImageList](./system/imagelist) | ImageList | ImageList control | | [FrameW](./system/framew) | FrameW | Unicode Frame control | | [MCIWnd](./system/mciwnd) | MCIWnd | Multimedia control | ## Common Helper Modules VBCCR also provides the following public helper modules shared by all controls: | Module | File | Description | |--------|------|-------------| | Common | Common.bas | General utility functions (MsgBox, SendKeys Unicode versions, clipboard operations, DPI helpers, image processing, etc.) | | VisualStyles | VisualStyles.bas | Visual style management (ActivateVisualStyles, RemoveVisualStyles, GetComCtlVersion) | | ISubclass | ISubclass.cls | Subclassing interface | | ComCtlsBase | ComCtlsBase.bas | Control base module | | VTableHandle | VTableHandle.bas | VTable handling module | ## Common Enumerations The following enumerations are shared across multiple controls: ### CCAppearanceConstants | Constant | Value | Description | |----------|-------|-------------| | cc2D | 0 | Flat appearance | | cc3D | 1 | 3D appearance | ### CCLeftRightAlignmentConstants | Constant | Value | Description | |----------|-------|-------------| | ccLeft | 0 | Left alignment | | ccRight | 1 | Right alignment | ### CCVerticalAlignmentConstants | Constant | Value | Description | |----------|-------|-------------| | ccTop | 0 | Top alignment | | ccBottom | 1 | Bottom alignment | | ccVCenter | 2 | Vertical center | ### CCMousePointerConstants | Constant | Value | |----------|-------| | ccDefault | 0 | | ccArrow | 1 | | ccCrosshair | 2 | | ccIBeam | 3 | | ccIcon | 4 | | ccSize | 5 | | ccSizeNESW | 6 | | ccSizeNS | 7 | | ccSizeNWSE | 8 | | ccSizeWE | 9 | | ccUpArrow | 10 | | ccHourglass | 11 | | ccNoDrop | 12 | | ccArrowHourglass | 13 | | ccArrowQuestion | 14 | | ccSizeAll | 15 | | ccCustom | 99 | ### CCRightToLeftModeConstants | Constant | Value | Description | |----------|-------|-------------| | ccRtlModeNo | 0 | No RTL | | ccRtlModeStandard | 1 | Standard RTL | | ccRtlModeV2 | 2 | V2 mode RTL | ### CCIMEModeConstants | Constant | Value | |----------|-------| | ccIMENoControl | 0 | | ccIMEOn | 1 | | ccIMEOff | 2 | | ccIMEDisable | 3 | | ccIMEHiragana | 4 | | ccIMEKatakanaDbl | 5 | | ccIMEKatakanaSng | 6 | | ccIMEAlphaDbl | 7 | | ccIMEAlphaSng | 8 | | ccIMEHangulDbl | 9 | | ccIMEHangulSng | 10 | ### OLEDropModeConstants | Constant | Value | |----------|-------| | ccOLEDropNone | 0 | | ccOLEDropManual | 1 | ## Author Documentation The official documentation written by VBCCR author Kr00l (Chinese translation), covering StdEXE/OCX version usage guides, OCX2StdEXE tool instructions, compilation options, and version history: [Read Author Documentation](./author) ## Additional Resources * [VBCCR GitHub Repository](https://github.com/Kr00l/VBCCR) * [VBForums Discussion Thread](https://www.vbforums.com/showthread.php?841929-VB6-ActiveX-CommonControls) --- --- url: /zh/vbman/demo/10.Multiprocessor.md --- # VBMAN 多进程示例 ## 概述 这个示例展示了如何使用 VBMAN 框架实现多进程处理,通过将业务逻辑分配到不同的进程中执行,提高应用程序的性能和稳定性。 ## 项目结构 ::: tip 下载源码 \[ 注意：重新到`bin`目录注册 DLL 文件 ] 代码请到首页下载VBMAN 项目，解压后，打开包含所有DEMO项目。 ::: ``` Multiprocessor/ ├── Form1.frm # 主窗体,主进程代码 ├── VBMAN_DEMO.vbp # 主进程项目文件 └── sub/ # 子进程代码 ├── bUsers.cls # 用户业务逻辑类 └── VBMANControllers.vbp # 子进程项目文件 ``` ## 核心代码解析 ### 1. 主进程代码(Form1.frm) ```vb Dim HttpServer As New cHttpServer Private Sub Form_Load() With HttpServer '注册子进程的用户控制器 .Router.Reg "Users", New VBMANControllers.bUsers '配置API路由 .Router.Add "/api/users/list", "Users@List" '启动服务器 .Start 80 End With '打开浏览器访问示例 Shell "explorer.exe http://127.0.0.1:80/api/users/list" End Sub ``` ### 2. 用户业务类(bUsers.cls) ```vb '用户业务逻辑类,在子进程中执行 Option Explicit Public Sub List(ctx As cHttpServerContext) '创建模拟用户数据 With ctx.Response.NewJson .Items.Add GetUser(1, "张三", 25) .Items.Add GetUser(2, "李四", 30) .Items.Add GetUser(3, "王五", 28) End With End Sub Private Function GetUser(id As Long, name As String, age As Long) As Object With VBMAN.Json.NewJson .Item("id") = id .Item("name") = name .Item("age") = age Set GetUser = .Item End With End Function ``` ## 功能说明 1. **多进程架构** * 主进程负责请求分发 * 子进程处理具体业务 * 进程间通信 * 负载均衡 2. **业务处理** * 业务模块独立 * 故障隔离 * 性能优化 * 资源管理 3. **进程管理** * 进程创建 * 进程监控 * 进程重启 * 资源回收 ## 技术要点 1. 进程间通信(IPC) 2. 请求分发机制 3. 子进程管理 4. 错误处理机制 ## 应用场景 1. 高并发Web服务 2. 大规模数据处理 3. 分布式计算 4. CPU密集型任务 ## 扩展建议 1. 添加进程池管理 2. 实现动态扩缩容 3. 添加进程监控 4. 优化进程通信 5. 添加故障转移 --- --- url: /zh/vbman/demo/12.AdminEnd.md --- # VBMAN 管理端示例 ## 概述 这个示例展示了如何使用 VBMAN 框架构建一个完整的管理系统，包含了服务端和前端实现。前端支持 layui 和 vue2 两种框架，展示了不同的开发方式。 ## 项目结构 ::: tip 下载源码 \[ 注意：重新到`bin`目录注册 DLL 文件 ] 代码请到首页下载VBMAN 项目，解压后，打开包含所有DEMO项目。 ::: ``` AdminEnd/ ├── Form1.frm # 主窗体 ├── VBMAN_DEMO.vbp # 项目文件 └── www/ # Web前端目录 ├── layui/ # layui版前端 │ └── easyweb/ # 基于layui的管理系统模板 └── vue/ # Vue2版前端 └── eleadmin2/ # 基于Vue2的管理系统模板 ``` ## 核心代码解析 ### 1. 服务端入口(Form1.frm) ```vb Option Explicit Private Sub Command1_Click() '启动layui版 Shell "explorer.exe http://127.0.0.1:800/layui/easyweb/" End Sub Private Sub Command2_Click() '启动vue2版 Shell "explorer.exe http://127.0.0.1:800/vue/eleadmin2/" End Sub Private Sub Form_Load() '启动Web服务器 With HttpServer '注册业务模块 .Router.Reg "Users", New bUsers .Router.Reg "Menus", New bMenus '配置静态文件目录 .WebRoot(App.Path & "\www").Start 800 End With End Sub ``` ### 2. 用户管理实现(bUsers.cls) ```vb '用户管理业务类 Option Explicit '用户列表 Public Sub List(ctx As cHttpServerContext) With ctx.Response.NewJson .Items.Add GetUser(1, "admin", "管理员") .Items.Add GetUser(2, "test", "测试用户") End With End Sub '用户登录 Public Sub Login(ctx As cHttpServerContext) Dim username As String, password As String username = ctx.Request.PostData("username") password = ctx.Request.PostData("password") If CheckLogin(username, password) Then '生成token With ctx.Response.NewJson .Item("code") = 0 .Item("token") = GenerateToken(username) .Item("userInfo") = GetUserInfo(username) End With Else ctx.Response.Error 401, "用户名或密码错误" End If End Sub ``` ### 3. 菜单管理实现(bMenus.cls) ```vb '菜单管理业务类 Option Explicit '获取菜单树 Public Sub GetTree(ctx As cHttpServerContext) With ctx.Response.NewJson '系统管理 With .NewJson("system") .Item("title") = "系统管理" .Item("icon") = "layui-icon-set" '添加子菜单 With .NewJson("children") .Items.Add GetMenuItem("用户管理", "/system/user") .Items.Add GetMenuItem("角色管理", "/system/role") .Items.Add GetMenuItem("菜单管理", "/system/menu") End With End With '业务管理 With .NewJson("business") .Item("title") = "业务管理" .Item("icon") = "layui-icon-app" With .NewJson("children") .Items.Add GetMenuItem("订单管理", "/business/order") .Items.Add GetMenuItem("商品管理", "/business/product") .Items.Add GetMenuItem("客户管理", "/business/customer") End With End With End With End Sub ``` ## 功能说明 1. **系统功能** * 用户管理 * 角色权限 * 菜单配置 * 系统设置 2. **前端框架** * Layui版 * EasyWeb模板 * 组件丰富 * 简单易用 * Vue2版 * ElementUI * 前后端分离 * 组件化开发 3. **开发模式** * 传统版(Layui) * 服务端渲染 * 模板引擎 * 同步加载 * 现代版(Vue2) * 前后端分离 * 单页应用 * 异步加载 ## 技术要点 1. 前后端分离 2. 权限控制 3. 异步通信 4. 组件封装 ## 应用场景 1. 后台管理系统 2. 业务管理平台 3. 运维监控系统 4. 数据管理平台 ## 扩展建议 1. 添加更多组件 2. 优化页面性能 3. 增加主题切换 4. 添加数据缓存 5. 支持国际化 --- --- url: /zh/vbman/global.md --- # VBMAN 全局静态对象文档 ## 概述 `VBMAN` 是 VB6 项目中的一个全局静态对象实例，引用 `vbman.dll` 后，可以在 VB6 工程任何地方直接使用，无需手动 `New` 实例化。 ## 核心优势 1. **全局静态实例化**: DLL 加载即自动实例化，无需手动 `New`，跟随应用程序整个生命周期 2. **用空间换速度**: 高频使用对象常驻内存，避免频繁创建和销毁的性能开销 3. **全局共享**: 配置、HTTP 客户端等对象一次获取，无限使用，数据全局共享 4. **零内存开销**: 全部对象常驻内存但是惰性加载，首次调用才会实例化 5. **使用便捷**: 借鉴成熟对象体系设计，API 简洁直观，开箱即用 6. **链式调用**: 大部分对象支持链式调用，代码更简洁 7. **类型安全**: 完整的强类型支持，IDE 自动提示 8. **生产验证**: 已在多个实际项目中广泛使用 ## 快速入门 ```vb ' 引用 vbman.dll 后直接使用 Dim Result As String Result = VBMAN.Json.Encode(SomeObject) ' 数据库操作示例 VBMAN.Db.Sql("SELECT * FROM users WHERE id=?").Param("id", 1).Fetch ' 文件操作示例 VBMAN.ToolsFso.AutoMakeDir "C:\\MyApp\\Data" ``` ## 子对象列表 ### 数据操作 | 对象 | 类 | 说明 | | ----------------------------- | ----------- | ---------------- | | [Json](./json.md) | cJson | JSON 解析与构建 | | [Csv](./csv.md) | cCsv | CSV 文件读写 | | [Ini](./ini.md) | cIni | INI 配置文件操作 | | [Db](./database.md) | cDataBase | 数据库操作（含[链式CURD系列](../database/chain-curd.md)）| | [Collection](./collection.md) | cCollection | 增强型集合类 | ### 网络通信 | 对象 | 类 | 说明 | | ----------------------------- | ----------- | --------------- | | [HttpClient](./httpclient.md) | cHttpClient | HTTP 客户端请求 | ### 文件与系统 | 对象 | 类 | 说明 | | ------------------------------- | ------------ | ------------ | | [FileEx](./fileex.md) | cFileEx | 高级文件操作 | | [ToolsFso](./toolsfso.md) | cToolsFso | 文件系统操作 | | [ToolsStream](./toolsstream.md) | cToolsStream | 文件流操作 | | [Regedit](./regedit.md) | cRegedit | 注册表操作 | | [StartUp](./startup.md) | cStartUp | 开机启动管理 | ### 工具类 | 对象 | 类 | 说明 | | ------------------------------- | ------------ | -------------- | | [ToolsStr](./toolsstr.md) | cToolsStr | 字符串处理工具 | | [ToolsMath](./toolsmath.md) | cToolsMath | 数学运算工具 | | [ToolsHttp](./toolshttp.md) | cToolsHttp | HTTP 工具函数 | | [ToolsBase64](./toolsbase64.md) | cToolsBase64 | Base64 编解码 | | [ToolsUtf8](./toolsutf8.md) | cToolsUtf8 | UTF-8 编解码 | | [ToolsArray](./toolsarray.md) | cToolsArray | 数组操作工具 | | [ToolsDic](./toolsdic.md) | cToolsDic | 字典操作工具 | | [ToolsList](./toolslist.md) | cToolsList | 列表操作工具 | | [ToolsSystem](./toolssystem.md) | cToolsSystem | 系统信息工具 | | [ToolsCrc](./toolscrc.md) | cToolsCrc | CRC 校验计算 | | [ToolsWindow](./toolswindow.md) | cToolsWindow | 窗口操作工具 | ### UI 与交互 | 对象 | 类 | 说明 | | --------------------- | ------- | ------------ | | [Dialog](./dialog.md) | cDialog | 对话框操作 | | [Toast](./toast.md) | cToast | 通知消息显示 | ### 图片处理 | 对象 | 类 | 说明 | | --------------------- | ------- | ---------------------- | | [Image](./cimage.md) | cImage | 图片数据互转（链式调用）| ### 其他功能 | 对象 | 类 | 说明 | | ------------------------- | --------- | ------------ | | [Logs](./logs.md) | cLogs | 日志记录 | | [Cmd](./cmd.md) | cCmd | 命令行执行 | | [TimeUse](./timeuse.md) | cTimeUse | 计时工具 | | [PLI](./pli.md) | cPLI | 插件接口 | | [QRcode](./qrcode.md) | cQRcode | 二维码生成 | | [Password](./password.md) | cPassword | 密码处理 | | [Delay](./delay.md) | cDelay | 延迟执行 | | [Formater](./formater.md) | cFormater | 格式化工具 | | [Baidu](./baidu.md) | cBaidu | 百度服务接口 | ## 使用模式 ### 直接使用模式 ```vb ' 最简单的使用方式 - 全局对象直接调用 Dim jsonText As String jsonText = VBMAN.Json.Encode(myData) ``` ### 链式调用模式 ```vb ' 支持链式调用的对象可以连续调用 VBMAN.Db.Sql("SELECT * FROM users").Fetch Debug.Print VBMAN.Db.Row("name") ``` ### 独立实例模式 ```vb ' 需要多个独立实例时，可以 New 创建 Dim json1 As New cJson Dim json2 As New cJson json1.Item("key1") = "value1" json2.Item("key2") = "value2" ``` ### 全局共享模式 ```vb ' 在程序启动时加载配置文件 VBMAN.Ini.LoadFrom "C:\\MyApp\\config.ini" ' 在任何地方直接读取配置值 Dim ServerUrl As String ServerUrl = VBMAN.Ini("Database")("ServerUrl") ' 修改配置值（内存中） VBMAN.Ini("Database")("ServerUrl") = "http://newserver.com" ' 随时保存到文件 VBMAN.Ini.Save ' HttpClient 等对象同样全局共享，一次配置，无限使用 VBMAN.HttpClient.SetBaseUrl ServerUrl ``` ## 引用说明 在 VB6 项目中使用 VBMAN 需要： 1. 引用 `vbman.dll`（工程 → 引用） 2. 确保 DLL 与 EXE 在同一目录，或正确配置路径 3. 无需额外声明，直接通过 `VBMAN` 对象访问 --- --- url: /zh/vbman/demo/3.Database.md --- # VBMAN 数据库操作示例 ## 概述 这个示例展示了如何使用 VBMAN 框架连接数据库并进行数据操作,支持多种数据库类型(Access/MySQL/SQLServer)，并结合Web API实现数据服务。 ## 项目结构 ::: tip 下载源码 \[ 注意：重新到`bin`目录注册 DLL 文件 ] 代码请到首页下载VBMAN 项目，解压后，打开包含所有DEMO项目。 ::: ``` Database/ ├── Form1.frm # 主窗体 ├── Config.bas # 配置模块 ├── bHello.cls # Hello业务类 ├── bMenus.cls # 菜单业务类 ├── bStation.cls # 工作站业务类 ├── bUsers.cls # 用户业务类 ├── _data/ # 数据文件目录 │ └── rtxdb.mdb # Access数据库文件 └── VBMAN_DEMO.vbp # VB6项目文件 ``` ## 核心代码解析 ### 1. 数据库连接(Form1.frm) ```vb Dim HttpServer As New VBMANLIB.cHttpServer Private Sub Form_Load() With HttpServer '配置数据库连接,支持Access/MySQL/SQLServer .Database.Connect Access, App.Path & "\..\_data\rtxdb.mdb" '注册业务类 .Router.Reg "Users", New bUsers .Router.Reg "Station", New bStation '配置路由映射 .Router.Add "/users/list", "Users@List" .Router.Add "/users/add", "Users@Add" .Router.Add "/station/list", "Station@List" .Start 800 End With Shell "explorer.exe http://127.0.0.1:800/users/list" End Sub ``` ### 2. 业务类示例(bUsers.cls) ```vb Public Sub List(ctx As cHttpServerContext) '执行SQL查询 Dim rs As Recordset Set rs = ctx.Db.Query("SELECT * FROM Users") '将结果转为JSON返回 With ctx.Response.Json .BeginArray While Not rs.EOF .BeginObject .Item("id") = rs("ID") .Item("name") = rs("UserName") .EndObject rs.MoveNext Wend .EndArray End With End Sub Public Sub Add(ctx As cHttpServerContext) '获取POST参数 Dim userName As String: userName = ctx.Request.Form("username") '执行插入 ctx.Db.Execute "INSERT INTO Users (UserName) VALUES ('" & userName & "')" '返回结果 ctx.Response.Json.Item("success") = True End Sub ``` ## 功能说明 1. **数据库支持** * 支持多种数据库(Access/MySQL/SQLServer) * 统一的数据库操作接口 * 自动事务处理 2. **业务逻辑组织** * 按功能模块划分业务类 * 业务类自动获取数据库连接 * 支持数据库操作和Web API集成 3. **Web API设计** * RESTful风格的API设计 * JSON数据格式 * 支持GET/POST等HTTP方法 ## 技术要点 1. 数据库连接配置简单,支持多种数据库类型 2. 通过ctx.Db直接访问数据库,无需手动管理连接 3. 内置JSON支持,方便返回结构化数据 4. 支持事务处理和错误管理 ## 实现的接口 1. GET /users/list - 获取用户列表 2. POST /users/add - 添加新用户 3. GET /station/list - 获取工作站列表 ## 扩展建议 1. 添加数据验证和错误处理 2. 实现更复杂的数据库操作(JOIN,子查询等) 3. 添加数据库连接池 4. 添加缓存机制 5. 实现数据库迁移工具 --- --- url: /zh/vbman/demo/13.Weather.md --- # VBMAN 天气预报实例 ## 概述 这是一个天气预报查询实例，通过调用天气预报查询接口，获取天气预报信息，并播放央视解说视频。 ## 项目结构 ::: tip 下载源码 \[ 注意：重新到`bin`目录注册 DLL 文件 ] 代码请到首页下载VBMAN 项目，解压后，打开包含所有DEMO项目。 ::: ``` Weather/ ├── Form1.frm # 主窗体,包含服务器启动代码 └── Weather.vbp # VB6项目文件 ``` ## 核心代码解析 ### 1. 主窗体(Form1.frm) ```vb Private Sub Command1_Click() '城市id， Dim id$: id = Text4.Text '通过城市名称查询城市id的接口 Const areaid$ = "https://i.tq121.com.cn/j/wap2016/news/city_search_data.js?20220422" '全国天气预报视频和区域 Const videos$ = "https://e.weather.com.cn/pubm/videos_vms1.htm?callback=getLbDatas&_=1747888658520" Dim area$: area = "https://e.weather.com.cn/p/site/aqifc1h?areaid=" & id & "&callback=aqifc1h&_=1747888658537" '城市当前天气预报 Dim tq$: tq = "https://d1.weather.com.cn/sk_2d/" & id & ".html?_=1747889185006" '城市一周天气 Dim week$: week = "https://d1.weather.com.cn/weixinfc/" & id & ".html?_=1747889185007" '城市天气概览 Dim sum$: sum = "https://d1.weather.com.cn/weather_index/" & id & ".html?_=1747889185008" '一句话调用 'Text1.Text = VBMAN.HttpClient.Fetch(ReqGet, videos).ReturnJson().Encode(, 2, True) '分段调用 With VBMAN.HttpClient.Fetch(ReqGet, videos).ReturnJson() Text1.Text = .Encode(, 2, True) '显示文本内容 Dim url$: url = .Root("documents")(1)("videourl")(1)("url") WindowsMediaPlayer1.url = url '播放天气预报视频 End With '城市天气预报均需要添加“引用”头 ^"referer: https://e.weather.com.cn/^" ^ With VBMAN.HttpClient .RequestHeaders("referer") = "https://e.weather.com.cn/" '获取当前城市的天气数据 With .Fetch(ReqGet, tq).ReturnJson() Label1.Caption = .Root("cityname") & " 当前气温：" & .Root("temp") & " 度" Text2.Text = .Encode(, 2, True) End With '获取城市对于的id数据 Text3.Text = .Fetch(ReqGet, areaid).ReturnText() End With End Sub ``` ## 功能说明 1. **接口列表** * 通过城市名称查询城市id的接口 * 获取城市id数据 * 获取天气预报视频和区域 * 获取城市当前天气预报 * 获取城市一周天气 * 获取城市天气概览 2. **效果截图** ## 技术要点 1. VBMAN 库提供了 HttpClient 类，用于处理 HTTP 请求。 2. 通过 HttpClient 类的 Fetch 方法可以发送 HTTP 请求，并返回响应结果。 3. 可以使用 Fetch 方法的 ReturnJson 方法将响应结果转换为 JSON 对象，并进行后续处理。 4. 可以使用 Fetch 方法的 ReturnText 方法将响应结果转换为文本，并进行后续处理。 5. 可以使用 HttpClient 类的 RequestHeaders 属性添加请求头，如添加 Referer 头。 6. 可以使用 Json 类的 Root 方法获取 JSON 对象的根节点，并使用 Root 方法获取指定节点的值。 7. 可以使用 Json 类的 Encode 方法将 JSON 对象转换为文本，并设置缩进和换行符。 8. 可以使用 WindowsMediaPlayer 控件播放视频。 ## 扩展建议 1. 可以添加更多的城市查询功能，如添加城市列表，用户输入城市名称后查询城市id，并显示天气预报。 2. 可以添加更多的天气预报功能，如添加天气预报列表，用户选择城市后查询天气预报。 3. 可以添加更多的天气预报查询功能，如添加天气预报查询列表，用户选择城市后查询天气预报。 --- --- url: /zh/vbman/demo/11.NetDataShow.md --- # VBMAN 网络数据展示示例 ## 概述 这个示例展示了如何使用 VBMAN 框架实现网络数据的实时展示,包括数据采集、传输、解析和可视化展示等功能。 ## 项目结构 ::: tip 下载源码 \[ 注意：重新到`bin`目录注册 DLL 文件 ] 代码请到首页下载VBMAN 项目，解压后，打开包含所有DEMO项目。 ::: ``` NetDataShow/ ├── Form1.frm # 主窗体,包含数据展示界面 ├── Form1.frx # 窗体资源文件 ├── NetDataShow.vbp # 项目文件 └── _pic/ # 图片资源目录 ``` ## 核心代码解析 ### 1. 数据展示窗体(Form1.frm) ```vb '数据展示窗体 Private WithEvents NetClient As New cTcpClient Private WithEvents Timer1 As New Timer Private Sub Form_Load() '连接数据服务器 With NetClient .Connect "127.0.0.1", 9000 End With '启动定时刷新 With Timer1 .Interval = 1000 .Enabled = True End With End Sub '数据接收处理 Private Sub NetClient_OnDataArrival() Dim data As String data = NetClient.RecvText '解析数据 ParseData data '更新显示 UpdateDisplay End Sub '定时刷新处理 Private Sub Timer1_Timer() '获取最新数据 NetClient.Send "GET_DATA" End Sub '数据解析 Private Sub ParseData(data As String) With VBMAN.Json If .Decode(data) Then '解析温度数据 txtTemp.Text = .Item("temperature") '解析湿度数据 txtHumidity.Text = .Item("humidity") '更新趋势图 UpdateChart .Item("history") End If End With End Sub ``` ### 2. 图表显示实现 ```vb '更新趋势图显示 Private Sub UpdateChart(history As Object) '清除旧数据 Chart1.Clear '添加新数据点 For Each point In history Chart1.AddPoint point("time"), point("value") Next '刷新显示 Chart1.Refresh End Sub '自定义显示格式 Private Sub FormatDisplay() '设置数值格式 txtTemp.Format = "0.00 ℃" txtHumidity.Format = "0.0 %" '设置报警阈值 txtTemp.AlarmValue = 30 txtHumidity.AlarmValue = 85 '配置图表样式 With Chart1 .Title = "温度趋势" .XLabel = "时间" .YLabel = "温度(℃)" .GridVisible = True .Refresh End With End Sub ``` ## 功能说明 1. **数据采集功能** * 网络通信 * 数据解析 * 实时更新 * 定时刷新 2. **数据显示** * 数值显示 * 趋势图表 * 报警提示 * 自动刷新 3. **用户界面** * 布局设计 * 交互控制 * 显示格式 * 主题样式 ## 技术要点 1. TCP通信实现 2. JSON数据处理 3. 图表控件应用 4. 界面刷新机制 ## 应用场景 1. 工业监控 2. 环境监测 3. 设备状态监控 4. 数据可视化 ## 扩展建议 1. 添加数据记录 2. 实现多通道显示 3. 添加数据分析 4. 支持报表导出 5. 优化刷新机制 --- --- url: /zh/vbman/LICENSE_GUIDE.md --- # VBMAN 许可证使用指南 本文档帮助你快速理解 VBMAN 项目的许可证要求，以及什么情况下需要付费。 *** ## 现有协议的核心要点 ### 基础协议：GPL-3.0 VBMAN 采用 GNU General Public License v3.0 (GPL-3.0) 开源协议。 ## 一句话总结 > **使用编译好的 DLL → 完全免费**\ > **修改源代码后开源使用 → 完全免费**\ > **用 DLL 免费，改源码且闭源才付费。** *** ## 详细说明 ### 一、二进制文件（永久免费） VBMAN 编译后的二进制文件（`.dll`、`.exe` 等）**永久免费**，无任何使用限制： * ✅ 个人项目使用 — 免费 * ✅ 商业软件中直接引用 VBMAN 的 DLL — 免费 * ✅ 公司内部工具开发 — 免费 * ✅ 开源项目使用 — 免费 ### 二、源代码使用 #### 情况 1：免费使用（遵守 GPL 协议） 如果你满足以下任一条件，可以免费使用源代码： 1. **个人学习/研究** — 自己改着玩，不对外发布 2. **修改后开源** — 如果你基于 VBMAN 修改并对外发布（包括销售），必须将整个项目的源代码开源，并采用 GPL 兼容协议 **GPL 协议核心要求：** * 分发时必须附带 LICENSE 文件 * 修改后的作品也必须采用 GPL 协议开源 * 保留版权声明和免责声明 #### 情况 2：需要购买商业授权 只有一种情况需要付费： > **你希望将 VBMAN 的源代码用于闭源商业项目，且不愿开源自己的代码。** 常见场景： | 场景 | 说明 | | ------------------------------------------ | ------------ | | 修改了 VBMAN 源码，但不希望开源修改内容 | 需要商业授权 | | 将 VBMAN 源码集成到闭源产品中销售 | 需要商业授权 | | SaaS 服务使用修改后的 VBMAN 源码但闭源部署 | 需要商业授权 | *** ## 决策流程图 ``` ┌─────────────────────────────────────┐ │ 你想使用 VBMAN 商用？ │ └──────────────────┬──────────────────┘ │ ┌─────────┴─────────┐ ▼ ▼ ┌──────────┐ ┌──────────┐ │ 只用 DLL │ │ 使用源码 │ └────┬─────┘ └────┬─────┘ │ │ ▼ ▼ ┌──────────┐ ┌──────────────┐ │ 完全免费 │ │ 对外发布吗？ │ │ 无需授权 │ └──────┬───────┘ └──────────┘ │ ┌───────┴───────┐ ▼ ▼ ┌──────────┐ ┌──────────┐ │ 不开源 │ │ 开源 │ └────┬─────┘ └────┬─────┘ │ │ ▼ ▼ ┌──────────┐ ┌──────────┐ │购买商业 │ │完全免费 │ │授权 │ │GPL协议 │ └──────────┘ └──────────┘ ``` ## 总结 ### 付费情况界定 **1. 二进制文件（DLL、EXE 等）** * 永久免费 * 无任何使用限制 * 无论是个人使用还是商业使用 **2. 源代码使用 - 个人用户** * 免费使用 * 但必须遵守 GPL 协议的规定： * 分发时必须附带 LICENSE 文件 * 修改后的作品也必须采用 GPL 兼容协议开源 **3. 源代码使用 - 商业场景** 这里分两种情况： **情况 A：开源商业使用（免费）** * 如果您的商业项目基于本项目进行修改或二次开发 * 并且**对外发布/销售**时**将整个项目的源代码开源**，并采用 GPL 兼容协议 * 这种情况下**不需要付费** **情况 B：闭源商业使用（需要付费）** * 如果您希望在**闭源商业项目**中使用本项目的源代码 * 即不想开源自己的代码 * 必须联系作者购买商业授权 ### 需要付费的具体场景 1. 商业软件公司开发闭源产品，使用了 VBMAN 的源代码 2. 企业内部闭源系统，使用了 VBMAN 的源代码，且不希望遵循 GPL 开源要求 3. SaaS 服务提供商在闭源代码基础上构建服务 ### 不需要付费的场景 1. 直接使用编译后的 DLL/EXE 文件，无论个人还是商业用途 2. 个人学习和研究使用源代码 3. 基于源代码开发，并愿意将修改后的代码开源的项目 4. 任何遵循 GPL 协议开源的项目 商业授权的核心在于源代码的使用方式，而非二进制文件的部署。开发者提供了灵活的使用路径，既保证了开源精神，又为商业应用提供了合法途径。关键在于用户是否愿意承担开源义务，或选择购买闭源使用的授权。 根据 `LICENSE` 和 `readme.md` 的内容，我为你梳理一下现有的协议界定： *** ## 现有协议核心要点 ### 基础协议：GPL-3.0 VBMAN 采用 **GNU General Public License v3.0 (GPL-3.0)** 协议开源。 *** ## 付费情况界定 ### 1. 二进制文件（永久免费） ``` 本项目编译后的二进制文件（DLL、EXE 等）永久免费，无任何使用限制。 ``` 无论个人还是商业用途，**直接使用编译后的 DLL 都是完全免费的**，不需要付费。 *** ### 2. 源代码使用（区分场景） | 使用场景 | 是否需要付费 | 条件 | | ------------------- | ------------ | --------------------------------------------------------------------------------- | | **个人使用** | 免费 | 遵守 GPL 协议（附带 LICENSE、修改后开源） | | **商业使用 + 开源** | 免费 | 基于本项目修改后**对外发布/销售**时，**必须将整个项目源代码开源**（GPL 兼容协议） | | **商业使用 + 闭源** | **需要付费** | 希望在**闭源商业项目**中使用源代码，不对外开源自己的代码 | *** ## 什么情况下需要付费？ **只有一个条件**：你想在**闭源的商业软件**中使用 VBMAN 的源代码，并且不想开源你自己的代码。 具体场景举例： | 场景 | 是否需要商业授权 | | ---------------------------------------------------- | ---------------- | | 公司内部使用 VBMAN 的 DLL 开发工具 | 免费 | | 开发商业软件，直接引用 VBMAN 的 DLL | 免费 | | 修改了 VBMAN 源代码，把修改后的 DLL 给客户用（开源） | 免费 | | 修改了 VBMAN 源代码，把修改后的 DLL 给客户用（闭源） | **需要付费** | | SaaS 服务使用 VBMAN 源码但闭源部署 | **需要付费** | *** ## 商业授权说明 如需闭源商业授权，请联系： * **作者**：邓伟 * **网站**：https://a-vi.com * **项目仓库**：https://gitcode.com/woeoio/vbman 商业授权费用根据具体使用场景和范围协商确定。 *** ## 常见问题（FAQ） **Q1：我在公司里用 VBMAN 开发内部工具，需要付费吗？**\ A：不需要。直接使用 DLL 完全免费。 **Q2：我修改了 VBMAN 的源码，做成产品卖给别人，但我不想开源，怎么办？**\ A：需要购买商业授权。否则违反 GPL 协议。 **Q3：我用 VBMAN 开发了一个开源软件，可以收费吗？**\ A：可以。GPL 协议允许你收费销售，但你必须提供源代码给客户。 **Q4：VBMAN2 也是同样的许可政策吗？**\ A：VBMAN2 不开源，只提供二进制文件，永久免费使用。 *** ## 完整法律文本 详细条款请参见 [LICENSE](LICENSE) 文件。 --- --- url: /zh/vbman/demo/5.MiddleWare.md --- # VBMAN 中间件与客户端通信示例 ## 概述 这个示例展示了如何使用 VBMAN 框架构建带有中间件的 Web 服务器,以及如何实现客户端与服务器的通信。示例包含权限验证中间件等高级特性。 ## 项目结构 ::: tip 下载源码 \[ 注意：重新到`bin`目录注册 DLL 文件 ] 代码请到首页下载VBMAN 项目，解压后，打开包含所有DEMO项目。 ::: ``` MiddleWare/ ├── server/ # 服务器端项目 │ ├── Form1.frm # 服务器主窗体 │ ├── DataServer.vbp # 服务器项目文件 │ └── include/ # 服务器端类库 │ ├── bWcs.cls # 业务处理类 │ ├── mAuth.cls # 权限验证中间件 │ ├── Config.bas # 配置模块 │ └── ToolsHttp.bas # HTTP工具模块 └── client/ # 客户端项目 ├── Client.frm # 客户端主窗体 ├── DataClient.vbp # 客户端项目文件 └── include/ # 客户端类库 ├── cHttpClient.cls # HTTP客户端类 ├── bTaskSend.cls # 任务发送类 ├── bTaskLog.cls # 任务日志类 └── cJson.cls # JSON处理类 ``` ## 核心代码解析 ### 1. 服务器端中间件配置(Form1.frm) ```vb '服务器初始化 Dim HttpServer As New VBMANLIB.cHttpServer Private Sub Form_Load() With HttpServer '注册业务类 .Router.Reg "Wcs", New bWcs '配置前置中间件用于权限检查 .Router.Before.Add "/*", New mAuth '启动服务器 .Start 800 End With End Sub ``` ### 2. 权限验证中间件(mAuth.cls) ```vb Public Sub Execute(ctx As cHttpServerContext) '获取认证信息 Dim token As String: token = ctx.Request.Headers("Authorization") '验证失败时终止请求 If Not IsValidToken(token) Then ctx.Response.State401 "Unauthorized" ctx.Abort End If End Sub ``` ### 3. 客户端请求发送(Client.frm) ```vb Private Sub SendTask() With New cHttpClient '设置请求头 .RequestHeaders.Add "Authorization", "Bearer " & token .RequestHeaders.Add "Content-Type", "application/json" '发送请求 Dim response As String response = .Fetch(ReqPost, "http://localhost:800/wcs/task", jsonData) '处理响应 Debug.Print .ReturnJson().Encode(, 2) End With End Sub ``` ## 功能说明 1. **中间件系统** * 支持前置中间件(Before) * 支持后置中间件(After) * 支持中间件链式调用 * 支持请求拦截和终止 2. **权限验证** * Token 认证机制 * 请求头验证 * 可配置的验证规则 * 统一的错误处理 3. **客户端功能** * HTTP 请求封装 * 头部管理 * JSON 数据处理 * 响应处理 ## 技术要点 1. 中间件机制的实现 2. HTTP 通信的封装 3. 权限验证的统一处理 4. 客户端-服务器交互 ## 应用场景 1. 需要权限验证的 Web API 2. 分布式系统通信 3. 微服务架构 4. 业务系统集成 ## 扩展建议 1. 添加更多类型的中间件 2. 实现请求限流 3. 添加数据验证中间件 4. 实现缓存中间件 5. 添加日志中间件 --- --- url: /zh/crowd.md --- # VBMAN 众筹项目 ## 项目概述 **项目名称**：VBMAN - 让VB6开发更方便\ **项目类型**：开发工具软件\ **筹资目标**：¥50,000\ **项目周期**：90天\ **项目状态**：筹备中 ## 项目介绍 ### 什么是 VBMAN？ VBMAN 是一个专为 VB6 开发者设计的革命性工具集，包含两个核心组件： 1. **VBMAN**：基于COM的dll文件，提供WEB服务器和客户端功能 2. **VBMAN2**：基于COM的ocx文件，提供webview2控件和web交互能力 ### 项目愿景 让每一个 VB6 开发者都能轻松地为自己的应用程序添加现代化的网络功能，无需复杂的配置，几行代码即可启动专业级的WEB服务。 ## 核心功能 ### VBMAN 功能特性 #### 🌐 嵌入式 WEB 服务器 * **一键启动**：几行代码即可在VB6项目中启动HTTP服务器 * **RESTful API**：支持GET、POST、PUT、DELETE等HTTP方法 * **静态文件服务**：支持HTML、CSS、JS、图片等静态资源 * **中间件支持**：可扩展的请求处理中间件 * **WebSocket支持**：实时双向通信能力 #### 📡 HTTP 客户端 * **简单易用**：封装复杂的HTTP请求操作 * **多协议支持**：HTTP/HTTPS/WebSocket客户端 * **文件上传下载**：支持大文件的分块传输 * **Cookie管理**：自动处理Cookie和Session #### 🛠️ 开发工具集 * **JSON处理**：高性能的JSON解析和生成 * **数据库连接池**：高效的数据库连接管理 * **日志系统**：灵活的日志记录和管理 * **配置管理**：统一的配置文件处理 ### VBMAN2 功能特性 #### 🖥️ WebView2 控件 * **现代浏览器内核**：基于Microsoft Edge WebView2 * **完整DOM操作**：JavaScript与VB6的双向调用 * **事件绑定**：网页元素直接绑定VB6函数 * **自动化操作**：实现网页的自动化控制 #### 📊 专业组件 * **WebOffice**：在线文档编辑和预览 * **可视化打印**：所见即所得的打印解决方案 * **Markdown编辑器**：实时预览的Markdown编辑器 * **图表组件**：丰富的数据可视化图表 ## 技术优势 ### 🚀 性能优异 * **原生C++实现**：核心功能使用C++开发，性能卓越 * **异步IO**：基于IOCP的高性能网络模型 * **内存优化**：精心设计的内存管理策略 ### 🔒 安全可靠 * **HTTPS支持**：内置SSL/TLS加密传输 * **访问控制**：灵活的权限管理机制 * **防攻击**：内置常见网络攻击防护 ### 🔧 易于集成 * **COM接口**：标准的COM组件，易于集成 * **零依赖**：无需额外安装运行时库 * **向后兼容**：支持Windows XP及以上系统 ## 应用场景 ### 🏢 企业应用 * **内部管理系统**：将传统VB6应用Web化 * **数据展示平台**：实时数据监控和展示 * **接口服务**：为移动端提供数据接口 ### 🏭 工业控制 * **设备监控**：工业设备的远程监控界面 * **数据采集**：传感器数据的实时采集和展示 * **报表系统**：设备运行状态报表 ### 🏫 教育软件 * **在线考试系统**：基于Web的考试平台 * **学习管理**：学生学习进度管理 * **互动教学**：多媒体教学工具 ## 开发计划 ### 阶段一：核心功能完善（1-30天） * \[ ] 完善HTTP服务器核心功能 * \[ ] 优化WebView2控件性能 * \[ ] 增强JSON处理能力 * \[ ] 完善文档和示例 ### 阶段二：高级功能开发（31-60天） * \[ ] 新增WebSocket服务器端 * \[ ] 实现数据库连接池 * \[ ] 开发可视化图表组件 * \[ ] 增加AI功能模块 ### 阶段三：生态建设（61-90天） * \[ ] 开发EXE版本 * \[ ] 支持VBS/ASP脚本 * \[ ] 建立插件生态 * \[ ] 完善社区文档 ## 回报设置 ### 早鸟支持者 - ¥99（限前100名） **回报内容**： * VBMAN + VBMAN2 完整版授权 * 详细开发文档和示例代码 * 官方QQ群技术支持 * 早鸟专属徽章 **原价**：¥199\ **节省**：¥100 ### 标准支持者 - ¥199 **回报内容**： * VBMAN + VBMAN2 完整版授权 * 详细开发文档和示例代码 * 官方QQ群技术支持 * 社区论坛访问权限 ### 高级支持者 - ¥399 **回报内容**： * 标准支持者所有内容 * 一对一技术咨询服务（2小时） * 定制化需求优先处理 * 内测版本抢先体验 ### 企业支持者 - ¥999 **回报内容**： * 高级支持者所有内容 * 企业版授权（支持多开发者） * 专属技术支持群 * 源码级技术支持（部分模块） ### 白金赞助商 - ¥2999 **回报内容**： * 企业支持者所有内容 * 产品首页赞助商展示 * 定制化功能开发（1个需求） * 年度技术顾问服务 ## 团队介绍 ### 核心开发团队 **项目负责人**：资深VB6开发专家，10年+软件开发经验\ **架构师**：前微软工程师，精通Windows系统开发\ **前端工程师**：Web技术专家，专注用户体验设计\ **测试工程师**：质量保证专家，确保产品稳定性 ### 技术顾问 * **Windows系统专家**：系统底层技术指导 * **网络安全专家**：安全架构设计和审核 * **用户体验设计师**：产品界面和交互设计 ## 风险说明 ### 技术风险 * **新技术挑战**：WebView2等新技术可能存在兼容性问题 * **应对措施**：充分测试，提供多种解决方案 ### 时间风险 * **开发延期**：复杂功能可能导致开发周期延长 * **应对措施**：合理规划，优先保证核心功能 ### 市场风险 * **需求变化**：市场需求可能发生变化 * **应对措施**：持续调研，灵活调整产品方向 ## 众筹资金用途 ### 开发成本（60%） * 开发人员薪酬：¥30,000 * 技术顾问费用：¥10,000 * 测试设备采购：¥5,000 ### 运营成本（25%） * 服务器和域名：¥5,000 * 营销推广：¥7,500 ### 平台费用（15%） * 众筹平台手续费：¥7,500 ## 联系我们 ### 官方网站 ### 技术交流群 * **QQ群**：123456789 * **微信群**：扫描二维码加入 ### 邮箱联系 * **商务合作**：business@vb6.pro * **技术支持**：support@vb6.pro ### 社交媒体 * **微博**：@VBMAN官方 * **B站**：VBMAN开发日志 ## 常见问题 ### Q: VBMAN支持哪些Windows版本？ A: 支持Windows XP SP3及以上所有版本，包括Windows 7/8/10/11。 ### Q: 是否支持64位系统？ A: 完全支持32位和64位Windows系统。 ### Q: 购买后是否有使用期限？ A: 一次购买，终身使用，免费升级。 ### Q: 是否提供源代码？ A: 部分模块提供源代码，核心算法保留商业机密。 ### Q: 如何获得技术支持？ A: 通过官方QQ群、邮箱、论坛等多种方式提供技术支持。 *** ## 立即支持 **让我们一起让VB6开发更简单、更现代！** 选择您的支持档位，成为VBMAN项目的早期支持者，与我们一起见证VB6开发工具的革新！ [立即支持 →](#) *** *本众筹项目承诺按时交付，如有任何问题，请随时联系我们的客服团队。* --- --- url: /en/vbman/demo/12.AdminEnd.md --- # VBMAN Admin Panel Example ## Overview This example demonstrates how to build a complete management system using the VBMAN framework, including both server-side and frontend implementations. The frontend supports two frameworks: Layui and Vue2, showcasing different development approaches. ## Project Structure ::: tip Download source \[ Note：To `bin` regedits DLL file ] Please go to the home page to download the VBMAN project, decompress it, and open it with all DEMO projects. ::: ``` AdminEnd/ ├── Form1.frm # Main form ├── VBMAN_DEMO.vbp # Project file └── www/ # Web frontend directory ├── layui/ # Layui version frontend │ └── easyweb/ # Management system template based on Layui └── vue/ # Vue2 version frontend └── eleadmin2/ # Management system template based on Vue2 ``` ## Core Code Analysis ### 1. Server Entry (Form1.frm) ```vb Option Explicit Private Sub Command1_Click() 'Launch Layui version Shell "explorer.exe http://127.0.0.1:800/layui/easyweb/" End Sub Private Sub Command2_Click() 'Launch Vue2 version Shell "explorer.exe http://127.0.0.1:800/vue/eleadmin2/" End Sub Private Sub Form_Load() 'Start Web server With HttpServer 'Register business modules .Router.Reg "Users", New bUsers .Router.Reg "Menus", New bMenus 'Configure static file directory .WebRoot(App.Path & "\www").Start 800 End With End Sub ``` ### 2. User Management Implementation (bUsers.cls) ```vb 'User management business class Option Explicit 'User list Public Sub List(ctx As cHttpServerContext) With ctx.Response.NewJson .Items.Add GetUser(1, "admin", "Administrator") .Items.Add GetUser(2, "test", "Test User") End With End Sub 'User login Public Sub Login(ctx As cHttpServerContext) Dim username As String, password As String username = ctx.Request.PostData("username") password = ctx.Request.PostData("password") If CheckLogin(username, password) Then 'Generate token With ctx.Response.NewJson .Item("code") = 0 .Item("token") = GenerateToken(username) .Item("userInfo") = GetUserInfo(username) End With Else ctx.Response.Error 401, "Invalid username or password" End If End Sub ``` ### 3. Menu Management Implementation (bMenus.cls) ```vb 'Menu management business class Option Explicit 'Get menu tree Public Sub GetTree(ctx As cHttpServerContext) With ctx.Response.NewJson 'System management With .NewJson("system") .Item("title") = "System Management" .Item("icon") = "layui-icon-set" 'Add submenus With .NewJson("children") .Items.Add GetMenuItem("User Management", "/system/user") .Items.Add GetMenuItem("Role Management", "/system/role") .Items.Add GetMenuItem("Menu Management", "/system/menu") End With End With 'Business management With .NewJson("business") .Item("title") = "Business Management" .Item("icon") = "layui-icon-app" With .NewJson("children") .Items.Add GetMenuItem("Order Management", "/business/order") .Items.Add GetMenuItem("Product Management", "/business/product") .Items.Add GetMenuItem("Customer Management", "/business/customer") End With End With End With End Sub ``` ## Feature Description 1. **System Features** * User management * Role permissions * Menu configuration * System settings 2. **Frontend Frameworks** * Layui Version * EasyWeb template * Rich components * Easy to use * Vue2 Version * ElementUI * Frontend-backend separation * Component-based development 3. **Development Modes** * Traditional Version (Layui) * Server-side rendering * Template engine * Synchronous loading * Modern Version (Vue2) * Frontend-backend separation * Single-page application * Asynchronous loading ## Technical Points 1. Frontend-backend separation 2. Permission control 3. Asynchronous communication 4. Component encapsulation ## Use Cases 1. Backend management systems 2. Business management platforms 3. Operations monitoring systems 4. Data management platforms ## Extension Suggestions 1. Add more components 2. Optimize page performance 3. Add theme switching 4. Add data caching 5. Support internationalization --- --- url: /zh/vbman/demo/9.ApiCall.md --- # VBMAN API 调用示例 ## 概述 这个示例展示了如何使用 VBMAN 框架调用外部 API 接口，包括了 HTTP GET/POST 请求、参数设置、响应解析等功能。 ## 项目结构 ::: tip 下载源码 \[ 注意：重新到`bin`目录注册 DLL 文件 ] 代码请到首页下载 VBMAN 项目，解压后，打开包含所有 DEMO 项目。 ::: ``` ApiCall/ ├── src/ # 源代码目录 │ ├── Form1.frm # 主窗体 │ └── ApiCall.vbp # 项目文件 └── dist/ # 编译输出目录 └── ApiCall.exe # 可执行文件 ``` ## 核心代码解析 ### 1. API 调用示例 ```vb '创建HTTP客户端 Dim http As New cHttpClient 'GET请求示例（一句示例，使用全局 VBMAN 对象） MsgBox VBMAN.HttpClient.SendGet("http://api.example.com/users").ReturnText() 'POST请求示例 With new cHttpClient Const Url as String = "http://api.example.com/users/list" '设置请求头，比如要求提供 token 的接口，在这里设置 .RequestHeader.Add "Authorization", "Bearer " & token '如果需要在URL后面加一些参数，可以这样构造，内部会自动拼接的 .RequestDataQuery.Add "time", Now() .RequestDataQuery.Add "version", 1.0.0 '以下数据格式 二选一 '1, 如果接口要求 表单 数据格式 '设置POST数据 表单数据 .RequestDataBody.Add "search","邓伟" .RequestDataBody.Add "sort","ASC" '发送请求，此时参数2 不用写，内部会自动构建表单并 urlencode .SendPost Url '2, 如果接口要求 Json 数据格式 '设置POST数据 先构造 Json 对象 With new cJson .Item("search") = "邓伟" .Item("sort") = "ASC" '接下来把对象转为 Json 字符串给变量，下面要使用 Const PostData as String = .Encode() End With '发送请求，设置内容格式为Json（因为默认是表单）Json字符串传给参数2 .SetRequestContentType JsonString .SendPost Url, PostData '处理响应，如果出错就不会走到这一行，所以应该使用 On Error 包裹错误处理 With .ReturnJson() '.ReturnBody 返回二进制， .ReturnText 返回文本 if .Root("code") = 0 then dim i as long, x as variant '这里可以处理后端返回的数据，比如遍历记录集，数组从1开始， for i = 1 to .Root("data")("count") List1.AddItem .Root("data")("rs")(i)("username") next '也可以使用 for each 更加简洁 for each x in .Root("data")("rs") list2.AddItem x("username") next Else MsgBox .Root("msg") '显示后端返回的错误信息 End if End With End With ``` ### 2. 文件上传示例 ```vb '文件上传 With http .FormData.Add "file", "c:\test.jpg" .FormData.Add "name", "测试图片" .Post "http://api.example.com/upload" End With ``` ### 3. 批量请求示例 ```vb '并发请求 With http .AsyncMode = True '开启异步模式 '发起多个请求 .Get "http://api1.example.com" .Get "http://api2.example.com" .Get "http://api3.example.com" '等待所有请求完成 .WaitAll '获取响应 For Each res In .AsyncResponses Debug.Print res.url, res.status Next End With ``` ## 功能说明 1. **HTTP 请求功能** * GET/POST/PUT/DELETE 等方法支持 * 表单提交(application/x-www-form-urlencoded) * 文件上传(multipart/form-data) * JSON 数据(application/json) * 异步请求 2. **请求配置** * 请求头设置 * Cookie 管理 * 超时设置 * 代理设置 * SSL/TLS 支持 3. **响应处理** * 状态码检查 * 响应头解析 * JSON 解析 * 文件下载 * 字符集处理 ## 技术要点 1. HTTP 协议实现 2. HTTPS 安全通信 3. 异步编程模型 4. 错误处理机制 ## 应用场景 1. 第三方 API 集成 2. 微服务通信 3. 文件上传下载 4. 数据同步 ## 扩展建议 1. 添加请求重试机制 2. 实现请求队列 3. 添加响应缓存 4. 实现请求限流 5. 支持 WebSocket --- --- url: /en/vbman/demo/9.ApiCall.md --- # VBMAN API Call Example ## Overview This example demonstrates how to use the VBMAN framework to call external API interfaces, including HTTP GET/POST requests, parameter settings, response parsing, and other functionalities. ## Project Structure ::: tip Download source \[ Note：To `bin` regedits DLL file ] Please go to the home page to download the VBMAN project, decompress it, and open it with all DEMO projects. ::: ``` ApiCall/ ├── src/ # Source code directory │ ├── Form1.frm # Main form │ └── ApiCall.vbp # Project file └── dist/ # Build output directory └── ApiCall.exe # Executable file ``` ## Core Code Analysis ### 1. API Call Example ```vb 'Create HTTP client Dim http As New cHttpClient 'Example of GET request (one-line example, using the global VBMAN object) MsgBox VBMAN.HttpClient.SendGet("http://api.example.com/users").ReturnText() 'Example of POST request With new cHttpClient Const Url as String = "http://api.example.com/users/list" 'Set request headers, e.g., for interfaces that require a token, set it here .RequestHeader.Add "Authorization", "Bearer " & token 'If parameters need to be appended to the URL, construct them this way; they will be automatically concatenated internally .RequestDataQuery.Add "time", Now() .RequestDataQuery.Add "version", 1.0.0 'Choose one of the following data formats '1. If the interface requires form data format 'Set POST data as form data .RequestDataBody.Add "search","woeoio" .RequestDataBody.Add "sort","ASC" 'Send the request. In this case, parameter 2 is not needed; the form will be automatically built and urlencoded internally .SendPost Url '2. If the interface requires JSON data format 'Set POST data by constructing a JSON object first With new cJson .Item("search") = "woeoio" .Item("sort") = "ASC" 'Next, convert the object to a JSON string for the variable to be used below Const PostData as String = .Encode() End With 'Send the request, set the content type to JSON (default is form), and pass the JSON string as parameter 2 .SetRequestContentType JsonString .SendPost Url, PostData 'Process the response. If an error occurs, this line will not be reached, so use On Error for error handling With .ReturnJson() '.ReturnBody returns binary, .ReturnText returns text if .Root("code") = 0 then dim i as long, x as variant 'Here you can process the data returned by the backend, e.g., iterate through the recordset. Arrays start from 1. for i = 1 to .Root("data")("count") List1.AddItem .Root("data")("rs")(i)("username") next 'You can also use for each for a more concise approach for each x in .Root("data")("rs") list2.AddItem x("username") next Else MsgBox .Root("msg") 'Display the error message returned by the backend End if End With End With ``` ### 2. File Upload Example ```vb 'File upload With http .FormData.Add "file", "c:\test.jpg" .FormData.Add "name", "Test Image" .Post "http://api.example.com/upload" End With ``` ### 3. Batch Request Example ```vb 'Concurrent requests With http .AsyncMode = True 'Enable async mode 'Initiate multiple requests .Get "http://api1.example.com" .Get "http://api2.example.com" .Get "http://api3.example.com" 'Wait for all requests to complete .WaitAll 'Get responses For Each res In .AsyncResponses Debug.Print res.url, res.status Next End With ``` ## Feature Description 1. **HTTP Request Features** * Support for GET/POST/PUT/DELETE methods * Form submission (application/x-www-form-urlencoded) * File upload (multipart/form-data) * JSON data (application/json) * Asynchronous requests 2. **Request Configuration** * Request header settings * Cookie management * Timeout settings * Proxy settings * SSL/TLS support 3. **Response Handling** * Status code checking * Response header parsing * JSON parsing * File downloading * Character set handling ## Technical Points 1. HTTP protocol implementation 2. HTTPS secure communication 3. Asynchronous programming model 4. Error handling mechanism ## Use Cases 1. Third-party API integration 2. Microservice communication 3. File upload and download 4. Data synchronization ## Extension Suggestions 1. Add request retry mechanism 2. Implement request queue 3. Add response caching 4. Implement request rate limiting 5. Support WebSocket --- --- url: /zh/vbman/winsock/benchmarks.md --- # VBMAN cWinsock TCP 服务端压力测试报告 📊 ## 📋 测试概述 本报告详细记录了 **VBMAN cWinsock** 类对象作为 TCP 服务端在高并发场景下的性能表现。测试采用 BeetleX TCP Benchmark V1.2 作为压力测试工具，对服务端进行了长时间、高强度的压力测试。 **测试结论：✅ 通过生产环境验证，性能稳定，资源占用极低，可放心用于生产环境。** *** ## 🖥️ 测试环境 ### 系统信息 * **操作系统**: Microsoft Windows NT 10.0.19045.0 * **CPU**: 12 逻辑核心 * **测试工具**: BeetleX TCP Benchmark V1.2 * **服务端程序**: Project1.exe (32位) ### 测试配置 * **并发连接数**: 1,000 个连接 * **测试间隔**: 50ms * **测试主机**: 127.0.0.1 (本地回环) * **服务端口**: 8080 * **测试协议**: TCP *** ![server](/images/vbman/socket/benchmarks/7.png) ## 📈 测试结果 ### 核心性能指标 | 指标项 | 数值 | 说明 | |--------|------|------| | **请求处理能力** | **16,023 次/秒** | 当前实时处理速率 | | **平均处理速率** | **16,018 次/秒** | 长时间运行平均值 | | **峰值处理速率** | **16,453 次/秒** | 最大瞬时处理能力 | | **总请求数** | **1,564,000** | 累计处理请求数 | | **CPU 占用率** | **18.6%** | 服务端进程 CPU 使用率 | | **内存占用** | **12.2 MB** | 服务端进程内存占用 | | **系统 CPU** | **1.47%** | 系统整体 CPU 使用率 | ### 网络 IO 统计 | 指标项 | 数值 | |--------|------| | **写入 IO 总量** | 1,564,000 次 | | **写入 IO/秒** | 16,023 次/秒 | | **写入数据总量** | 35.797 MB | | **写入数据速率** | 0.367 MB/秒 | | **读取 IO 总量** | 1,561,700 次 | | **读取 IO/秒** | 16,066 次/秒 | | **读取数据总量** | 2.979 MB | | **读取数据速率** | 0.031 MB/秒 | ### 稳定性表现 * ✅ **请求处理速率稳定**: 长时间运行保持在 **15,000+ 次/秒**，表现稳定如老狗 🐕 * ✅ **内存占用极低**: 运行期间内存始终不超过 **13 MB** * ✅ **内存回收优秀**: 停止测试后内存可自动恢复到 **5 MB**，无内存泄漏 * ✅ **CPU 占用合理**: 在 1,000 并发连接下，CPU 占用率仅 **18.6%** *** ## 🔍 性能分析 ### 1. 吞吐量分析 💪 * **峰值吞吐量**: 16,453 次/秒 * **平均吞吐量**: 16,018 次/秒 * **稳定性**: 波动范围极小（< 3%），表现非常稳定 在 1,000 个并发连接的情况下，cWinsock 能够稳定处理超过 **15,000 次/秒** 的请求，充分证明了其在高并发场景下的优秀性能。 ### 2. 资源占用分析 💾 #### 内存占用 * **运行中**: ≤ 13 MB * **空闲时**: ~5 MB * **内存增长**: 仅 8 MB（从空闲到满载） * **内存回收**: 测试停止后能完全回收，无内存泄漏 #### CPU 占用 * **服务端进程**: 18.6% (12 核系统) * **系统整体**: 1.47% * **单核等效**: 约 2.2 核（18.6% × 12 核） 在如此高的并发压力下，CPU 占用率保持在合理范围内，说明 cWinsock 的实现非常高效。 ![server](/images/vbman/socket/benchmarks/5.png) 下图中是测试了600+秒之后，各方面指标依然稳定（点击图片可放大） ![server](/images/vbman/socket/benchmarks/6.png) ### 3. 网络 IO 分析 🌐 * **双向 IO**: 读写 IO 数量基本平衡，说明连接管理正常 * **数据吞吐**: 写入 35.797 MB，读取 2.979 MB，符合测试场景 * **IO 效率**: 平均每次 IO 约 24 字节，小包处理能力优秀 ### 4. 稳定性分析 ⚡ * **长时间运行**: 测试持续运行，无崩溃、无异常 * **连接管理**: 1,000 个并发连接稳定维持 * **错误率**: 读写 IO 差异极小（0.15%），说明连接稳定可靠 *** ## ✅ 测试结论 ### 核心优势 1. **🚀 高性能**: 稳定处理 15,000+ 次/秒请求，峰值可达 16,453 次/秒 2. **💚 低资源占用**: 内存占用始终不超过 13 MB，CPU 占用合理 3. **🔄 优秀的内存管理**: 测试停止后内存可完全回收，无内存泄漏 4. **🛡️ 高稳定性**: 长时间高并发运行无崩溃、无异常 5. **📊 性能稳定**: 处理速率波动极小，表现稳定如老狗 ### 生产环境适用性评估 | 评估项 | 状态 | 说明 | |--------|------|------| | **性能** | ✅ 优秀 | 15,000+ 次/秒处理能力，满足大多数生产场景 | | **稳定性** | ✅ 优秀 | 长时间运行无异常，连接管理可靠 | | **资源占用** | ✅ 优秀 | 内存占用极低，CPU 占用合理 | | **内存管理** | ✅ 优秀 | 无内存泄漏，自动回收机制完善 | | **生产就绪** | ✅ **可生产使用** | 各项指标均达到生产环境要求 | *** ## 🎯 推荐使用场景 基于本次压力测试结果，**VBMAN cWinsock** 和 **cWebSocket** 类对象适用于以下生产场景： * ✅ 高并发 TCP 服务端应用 * ✅ WebSocket 实时通信服务 * ✅ 游戏服务器后端 * ✅ 物联网设备接入服务 * ✅ 实时数据采集与处理 * ✅ 微服务通信中间件 * ✅ 其他需要高性能网络通信的场景 *** ## 📝 测试数据快照 ### 测试工具统计信息 ``` 系统平台: Microsoft Windows NT 10.0.19045.0 逻辑核数: 12 CPU占用率: 1.47% 占用内存: 328,680 KB (测试工具本身) 总请求数: 1,564,000 请求数/秒: 16,023 平均请求数/秒: 16,018 最大请求数/秒: 16,453 ``` ### 服务端进程信息（任务管理器） ``` 进程名称: Project1.exe (32位) CPU 使用率: 18.6% 内存占用: 12.2 MB 磁盘 IO: 0 MB/秒 网络带宽: 0 Mbps 电源使用: 非常高（表示 CPU 密集型任务） ``` *** ## 🏆 总结 **VBMAN cWinsock** 类对象在本次压力测试中表现卓越： * 🎯 **性能**: 15,000+ 次/秒稳定处理，峰值 16,453 次/秒 * 💾 **资源**: 内存 ≤ 13 MB，CPU 占用合理 * 🔄 **稳定性**: 长时间运行无异常，内存自动回收 * ✅ **结论**: **可放心用于生产环境** 测试停止之后，服务端进程平稳退出，内存恢复到5MB左右，无资源泄漏。 ![server](/images/vbman/socket/benchmarks/9.png) **VBMAN 的 cWinsock 和 cWebSocket 已通过生产环境验证，可生产使用！** 🚀 *** *测试报告生成时间: 2026年01月12日*\ *测试工具: BeetleX TCP Benchmark V1.2*\ *服务端: VBMAN cWinsock TCP Server* 测试程序源码可以在顶部菜单下载。 --- --- url: /en/vbman/winsock/benchmarks.md --- # VBMAN cWinsock TCP Server Stress Test Report 📊 ## 📋 Test Overview This report details the performance of **VBMAN cWinsock** class as a TCP server under high-concurrency scenarios. The test used BeetleX TCP Benchmark V1.2 as a stress testing tool, conducting long-term, intensive stress tests on the server. **Test Conclusion: ✅ Verified in production environment with stable performance and extremely low resource usage, ready for production use.** *** ## 🖥️ Test Environment ### System Information * **Operating System**: Microsoft Windows NT 10.0.19045.0 * **CPU**: 12 logical cores * **Test Tool**: BeetleX TCP Benchmark V1.2 * **Server Program**: Project1.exe (32-bit) ### Test Configuration * **Concurrent Connections**: 1,000 connections * **Test Interval**: 50ms * **Test Host**: 127.0.0.1 (local loopback) * **Server Port**: 8080 * **Test Protocol**: TCP *** ![server](/images/vbman/socket/benchmarks/7.png) ## 📈 Test Results ### Core Performance Metrics | Metric | Value | Description | |--------|-------|-------------| | **Request Processing** | **16,023 req/s** | Current real-time processing rate | | **Average Processing Rate** | **16,018 req/s** | Long-term running average | | **Peak Processing Rate** | **16,453 req/s** | Maximum instantaneous processing capability | | **Total Requests** | **1,564,000** | Cumulative processed requests | | **CPU Usage** | **18.6%** | Server process CPU usage | | **Memory Usage** | **12.2 MB** | Server process memory usage | | **System CPU** | **1.47%** | Overall system CPU usage | ### Network IO Statistics | Metric | Value | |--------|-------| | **Write IO Total** | 1,564,000 operations | | **Write IO/sec** | 16,023 ops/s | | **Write Data Total** | 35.797 MB | | **Write Data Rate** | 0.367 MB/s | | **Read IO Total** | 1,561,700 operations | | **Read IO/sec** | 16,066 ops/s | | **Read Data Total** | 2.979 MB | | **Read Data Rate** | 0.031 MB/s | ### Stability Performance * ✅ **Stable Request Processing**: Maintained **15,000+ req/s** during long-term operation, as stable as a rock 🐕 * ✅ **Extremely Low Memory Usage**: Memory never exceeded **13 MB** during operation * ✅ **Excellent Memory Recovery**: After stopping the test, memory automatically recovered to **5 MB**, no memory leaks * ✅ **Reasonable CPU Usage**: Only **18.6%** CPU usage with 1,000 concurrent connections *** ## 🔍 Performance Analysis ### 1. Throughput Analysis 💪 * **Peak Throughput**: 16,453 req/s * **Average Throughput**: 16,018 req/s * **Stability**: Very small fluctuation range (< 3%), extremely stable performance With 1,000 concurrent connections, cWinsock can stably process over **15,000 req/s**, fully demonstrating its excellent performance in high-concurrency scenarios. ### 2. Resource Usage Analysis 💾 #### Memory Usage * **During Operation**: ≤ 13 MB * **Idle**: ~5 MB * **Memory Growth**: Only 8 MB (from idle to full load) * **Memory Recovery**: Fully recoverable after test stops, no memory leaks #### CPU Usage * **Server Process**: 18.6% (12-core system) * **Overall System**: 1.47% * **Single Core Equivalent**: Approximately 2.2 cores (18.6% × 12 cores) Under such high concurrency pressure, CPU usage remains within a reasonable range, demonstrating cWinsock's highly efficient implementation. ![server](/images/vbman/socket/benchmarks/5.png) The image below shows that after testing for 600+ seconds, all metrics remain stable (click image to enlarge) ![server](/images/vbman/socket/benchmarks/6.png) ### 3. Network IO Analysis 🌐 * **Bidirectional IO**: Balanced read/write IO counts, indicating proper connection management * **Data Throughput**: 35.797 MB written, 2.979 MB read, consistent with test scenario * **IO Efficiency**: Average ~24 bytes per IO, excellent small packet processing capability ### 4. Stability Analysis ⚡ * **Long-term Operation**: Continuous testing without crashes or exceptions * **Connection Management**: 1,000 concurrent connections maintained stably * **Error Rate**: Minimal difference between read/write IO (0.15%), indicating reliable connection stability *** ## ✅ Test Conclusion ### Core Advantages 1. **🚀 High Performance**: Stable 15,000+ req/s processing, peak up to 16,453 req/s 2. **💚 Low Resource Usage**: Memory usage never exceeds 13 MB, CPU usage is reasonable 3. **🔄 Excellent Memory Management**: Fully recoverable after test stops, no memory leaks 4. **🛡️ High Stability**: Long-term high-concurrency operation without crashes or exceptions 5. **📊 Stable Performance**: Minimal processing rate fluctuation, as stable as a rock ### Production Environment Suitability Assessment | Assessment Item | Status | Description | |-----------------|--------|-------------| | **Performance** | ✅ Excellent | 15,000+ req/s processing capability, meets most production scenarios | | **Stability** | ✅ Excellent | No anomalies during long-term operation, reliable connection management | | **Resource Usage** | ✅ Excellent | Extremely low memory usage, reasonable CPU usage | | **Memory Management** | ✅ Excellent | No memory leaks,完善的自动回收机制 | | **Production Ready** | ✅ **Ready for Production** | All indicators meet production environment requirements | *** ## 🎯 Recommended Use Cases Based on these stress test results, **VBMAN cWinsock** and **cWebSocket** classes are suitable for the following production scenarios: * ✅ High-concurrency TCP server applications * ✅ WebSocket real-time communication services * ✅ Game server backends * ✅ IoT device access services * ✅ Real-time data collection and processing * ✅ Microservice communication middleware * ✅ Other scenarios requiring high-performance network communication *** ## 📝 Test Data Snapshot ### Test Tool Statistics ``` System Platform: Microsoft Windows NT 10.0.19045.0 Logical Cores: 12 CPU Usage: 1.47% Memory Usage: 328,680 KB (test tool itself) Total Requests: 1,564,000 Requests/sec: 16,023 Average Requests/sec: 16,018 Max Requests/sec: 16,453 ``` ### Server Process Information (Task Manager) ``` Process Name: Project1.exe (32-bit) CPU Usage: 18.6% Memory Usage: 12.2 MB Disk IO: 0 MB/s Network Bandwidth: 0 Mbps Power Usage: Very High (indicates CPU-intensive task) ``` *** ## 🏆 Summary **VBMAN cWinsock** class performed exceptionally well in this stress test: * 🎯 **Performance**: Stable 15,000+ req/s processing, peak 16,453 req/s * 💾 **Resources**: Memory ≤ 13 MB, reasonable CPU usage * 🔄 **Stability**: No anomalies during long-term operation, automatic memory recovery * ✅ **Conclusion**: **Ready for production use with confidence** After stopping the test, the server process exited smoothly and memory recovered to around 5MB with no resource leaks. ![server](/images/vbman/socket/benchmarks/9.png) **VBMAN's cWinsock and cWebSocket have been verified in production environment and are production-ready!** 🚀 *** *Test Report Generated: January 12, 2026*\ *Test Tool: BeetleX TCP Benchmark V1.2*\ *Server: VBMAN cWinsock TCP Server* Test program source code can be downloaded from the top menu. --- --- url: /en/vbman/demo/3.Database.md --- # VBMAN Database Operations Example ## Overview This example demonstrates how to connect to databases and perform data operations using the VBMAN framework, supporting multiple database types (Access/MySQL/SQLServer), and implementing data services with Web API. ## Project Structure ::: tip Download source \[ Note：To `bin` regedits DLL file ] Please go to the home page to download the VBMAN project, decompress it, and open it with all DEMO projects. ::: ``` Database/ ├── Form1.frm # Main form ├── Config.bas # Configuration module ├── bHello.cls # Hello business class ├── bMenus.cls # Menu business class ├── bStation.cls # Workstation business class ├── bUsers.cls # User business class ├── _data/ # Data files directory │ └── rtxdb.mdb # Access database file └── VBMAN_DEMO.vbp # VB6 project file ``` ## Core Code Analysis ### 1. Database Connection (Form1.frm) ```vb Dim HttpServer As New VBMANLIB.cHttpServer Private Sub Form_Load() With HttpServer 'Configure database connection, supporting Access/MySQL/SQLServer .Database.Connect Access, App.Path & "\..\_data\rtxdb.mdb" 'Register business classes .Router.Reg "Users", New bUsers .Router.Reg "Station", New bStation 'Configure route mappings .Router.Add "/users/list", "Users@List" .Router.Add "/users/add", "Users@Add" .Router.Add "/station/list", "Station@List" .Start 800 End With Shell "explorer.exe http://127.0.0.1:800/users/list" End Sub ``` ### 2. Business Class Example (bUsers.cls) ```vb Public Sub List(ctx As cHttpServerContext) 'Execute SQL query Dim rs As Recordset Set rs = ctx.Db.Query("SELECT * FROM Users") 'Convert result to JSON and return With ctx.Response.Json .BeginArray While Not rs.EOF .BeginObject .Item("id") = rs("ID") .Item("name") = rs("UserName") .EndObject rs.MoveNext Wend .EndArray End With End Sub Public Sub Add(ctx As cHttpServerContext) 'Get POST parameters Dim userName As String: userName = ctx.Request.Form("username") 'Execute insert ctx.Db.Execute "INSERT INTO Users (UserName) VALUES ('" & userName & "')" 'Return result ctx.Response.Json.Item("success") = True End Sub ``` ## Feature Description 1. **Database Support** * Support multiple databases (Access/MySQL/SQLServer) * Unified database operation interface * Automatic transaction handling 2. **Business Logic Organization** * Business classes divided by functional modules * Business classes automatically get database connections * Support database operations and Web API integration 3. **Web API Design** * RESTful style API design * JSON data format * Support for GET/POST and other HTTP methods ## Technical Points 1. Simple database connection configuration, supporting multiple database types 2. Direct database access through ctx.Db, no need to manually manage connections 3. Built-in JSON support for convenient structured data return 4. Support for transaction processing and error management ## Implemented Interfaces 1. GET /users/list - Get user list 2. POST /users/add - Add new user 3. GET /station/list - Get workstation list ## Extension Suggestions 1. Add data validation and error handling 2. Implement more complex database operations (JOIN, subqueries, etc.) 3. Add database connection pool 4. Add caching mechanism 5. Implement database migration tools --- --- url: /en/vbman/global.md --- # VBMAN Global Static Object Documentation ## Overview `VBMAN` is a global static object instance in VB6 projects. After referencing `vbman.dll`, it can be used anywhere in the VB6 project without manual `New` instantiation. ## Core Advantages 1. **Global Static Instantiation**: Automatically instantiated when DLL loads, no manual `New` required, follows the entire application lifecycle 2. **Space for Speed**: High-frequency use objects stay resident in memory, avoiding performance overhead from frequent creation and destruction 3. **Global Sharing**: Configuration, HTTP clients, and other objects are obtained once and used unlimited times, with data shared globally 4. **Zero Memory Overhead**: All objects stay resident in memory but are lazily loaded, only instantiated on first call 5. **Easy to Use**: Learned from mature object system designs, with simple and intuitive APIs, ready to use out of the box 6. **Chain Calls**: Most objects support chain calls for cleaner code 7. **Type Safety**: Complete strong type support with IDE auto-completion 8. **Production Verified**: Widely used in multiple real-world projects ## Quick Start ```vb ' Use directly after referencing vbman.dll Dim Result As String Result = VBMAN.Json.Encode(SomeObject) ' Database operation example VBMAN.Db.Sql("SELECT * FROM users WHERE id=?").Param("id", 1).Fetch ' File operation example VBMAN.ToolsFso.AutoMakeDir "C:\MyApp\Data" ``` ## Sub-object List ### Data Operations | Object | Class | Description | | ----------------------------- | ----------- | --------------------------------- | | [Json](./json.md) | cJson | JSON parsing and building | | [Csv](./csv.md) | cCsv | CSV file read/write | | [Ini](./ini.md) | cIni | INI configuration file operations | | [Db](./database.md) | cDataBase | Database operations (includes [Chained CRUD series](../database/chain-curd.md))| | [Collection](./collection.md) | cCollection | Enhanced collection class | ### Network Communication | Object | Class | Description | | ----------------------------- | ----------- | -------------------- | | [HttpClient](./httpclient.md) | cHttpClient | HTTP client requests | ### File and System | Object | Class | Description | | ------------------------------- | ------------ | ------------------------ | | [FileEx](./fileex.md) | cFileEx | Advanced file operations | | [ToolsFso](./toolsfso.md) | cToolsFso | File system operations | | [ToolsStream](./toolsstream.md) | cToolsStream | File stream operations | | [Regedit](./regedit.md) | cRegedit | Registry operations | | [StartUp](./startup.md) | cStartUp | Startup management | ### Utilities | Object | Class | Description | | ------------------------------- | ------------ | -------------------------- | | [ToolsStr](./toolsstr.md) | cToolsStr | String processing tools | | [ToolsMath](./toolsmath.md) | cToolsMath | Math operation tools | | [ToolsHttp](./toolshttp.md) | cToolsHttp | HTTP utility functions | | [ToolsBase64](./toolsbase64.md) | cToolsBase64 | Base64 encoding/decoding | | [ToolsUtf8](./toolsutf8.md) | cToolsUtf8 | UTF-8 encoding/decoding | | [ToolsArray](./toolsarray.md) | cToolsArray | Array operation tools | | [ToolsDic](./toolsdic.md) | cToolsDic | Dictionary operation tools | | [ToolsList](./toolslist.md) | cToolsList | List operation tools | | [ToolsSystem](./toolssystem.md) | cToolsSystem | System information tools | | [ToolsCrc](./toolscrc.md) | cToolsCrc | CRC checksum calculation | | [ToolsWindow](./toolswindow.md) | cToolsWindow | Window operation tools | ### UI and Interaction | Object | Class | Description | | --------------------- | ------- | --------------------- | | [Dialog](./dialog.md) | cDialog | Dialog operations | | [Toast](./toast.md) | cToast | Notification messages | ### Image Processing | Object | Class | Description | | --------------------- | ------- | ---------------------- | | [Image](./cimage.md) | cImage | Image data conversion (chained calls) | ### Other Features | Object | Class | Description | | ------------------------- | --------- | ----------------------- | | [Logs](./logs.md) | cLogs | Logging | | [Cmd](./cmd.md) | cCmd | Command line execution | | [TimeUse](./timeuse.md) | cTimeUse | Timing utilities | | [PLI](./pli.md) | cPLI | Plugin interface | | [QRcode](./qrcode.md) | cQRcode | QR code generation | | [Password](./password.md) | cPassword | Password processing | | [Delay](./delay.md) | cDelay | Delayed execution | | [Formater](./formater.md) | cFormater | Formatting utilities | | [Baidu](./baidu.md) | cBaidu | Baidu service interface | ## Usage Patterns ### Direct Usage Pattern ```vb ' Simplest usage - direct call on global object Dim jsonText As String jsonText = VBMAN.Json.Encode(myData) ``` ### Chain Call Pattern ```vb ' Objects supporting chain calls can be called continuously VBMAN.Db.Sql("SELECT * FROM users").Fetch Debug.Print VBMAN.Db.Row("name") ``` ### Independent Instance Pattern ```vb ' When multiple independent instances are needed, create with New Dim json1 As New cJson Dim json2 As New cJson json1.Item("key1") = "value1" json2.Item("key2") = "value2" ``` ### Global Sharing Pattern ```vb ' Load configuration file at program startup VBMAN.Ini.LoadFrom "C:\MyApp\config.ini" ' Read configuration values anywhere Dim ServerUrl As String ServerUrl = VBMAN.Ini("Database")("ServerUrl") ' Modify configuration values (in memory) VBMAN.Ini("Database")("ServerUrl") = "http://newserver.com" ' Save to file at any time VBMAN.Ini.Save ' HttpClient and other objects are also globally shared, configure once, use unlimited times VBMAN.HttpClient.SetBaseUrl ServerUrl ``` ## Reference Instructions To use VBMAN in VB6 projects: 1. Reference `vbman.dll` (Project → References) 2. Ensure DLL is in the same directory as EXE, or properly configure the path 3. No additional declarations needed, access directly through `VBMAN` object --- --- url: /zh/vbman/demo/1.HelloWorld.md --- # VBMAN HelloWorld 示例 ## 概述 这是一个使用 VBMAN 库创建基础 Web 服务器的示例,展示了最简单的 HTTP 服务器搭建和路由配置。 ## 项目结构 ::: tip 下载源码 \[ 注意：重新到`bin`目录注册 DLL 文件 ] 代码请到首页下载VBMAN 项目，解压后，打开包含所有DEMO项目。 ::: ``` Helloworld/ ├── Form1.frm # 主窗体,包含服务器启动代码 ├── bDemo.cls # Demo业务类,处理具体的请求 └── VBMAN_DEMO.vbp # VB6项目文件 ``` ## 核心代码解析 ### 1. 主窗体(Form1.frm) ```vb Dim HttpServer As New cHttpServer Private Sub Form_Load() With HttpServer .Router.Reg "Demo", New bDemo '注册业务类 .Router.AutoRoute = True '开启自动路由 .Start 800 '启动服务器,监听800端口 End With Shell "explorer.exe http://127.0.0.1:800/demo/hello" '自动打开浏览器访问示例 End Sub ``` ### 2. Demo 业务类(bDemo.cls) ```vb Public Sub Hello(ctx As cHttpServerContext) Dim id As Long: id = ctx.Request.QueryString("id") '获取URL参数id ctx.Response.Text "hello vbman @ " & id '返回响应文本 End Sub ``` ## 功能说明 1. **HTTP服务器配置** * 使用 VBMAN 库的 cHttpServer 类创建 HTTP 服务器 * 服务器监听 800 端口 * 程序启动时自动打开浏览器访问示例页面 2. **路由系统** * 注册 bDemo 类作为 Demo 业务处理器 * 启用自动路由功能(AutoRoute = True) * 路由规则: /demo/hello 映射到 bDemo.Hello 方法 * URL参数示例: /demo/hello?id=123 3. **请求处理** * 通过 ctx.Request.QueryString 获取URL参数 * 使用 ctx.Response.Text 返回文本响应 ## 技术要点 1. VBMAN 采用面向对象的方式处理 Web 请求 2. 自动路由功能可基于类名和方法名自动生成 URL 路径 3. 上下文对象(ctx)提供了完整的请求/响应处理能力 ## 运行效果 启动后会自动打开浏览器访问 http://127.0.0.1:800/demo/hello ,页面将显示"hello vbman @ "加上传入的id值。 ## 扩展建议 1. 可以添加更多的业务方法来处理不同的URL请求 2. 可以返回不同类型的响应,如JSON、HTML等 3. 可以添加更多的URL参数处理逻辑 --- --- url: /en/vbman/demo/1.HelloWorld.md --- # VBMAN HelloWorld Example ## Overview This is an example of creating a basic web server using the VBMAN library, demonstrating the simplest HTTP server setup and route configuration. ## Project Structure ::: tip Download source \[ Note：To `bin` regedits DLL file ] Please go to the home page to download the VBMAN project, decompress it, and open it with all DEMO projects. ::: ``` Helloworld/ ├── Form1.frm # Main form, contains server startup code ├── bHello.cls # Hello business class, handles specific requests └── VBMAN_DEMO.vbp # VB6 project file ``` ## Core Code Analysis ### 1. Main Form (Form1.frm) ```vb Dim HttpServer As New cHttpServer Private Sub Form_Load() With HttpServer .Router.Reg "Demo", New bHello 'Register business class .Router.AutoRoute = True 'Enable auto routing .Start 800 'Start server, listen on port 800 End With Shell "explorer.exe http://127.0.0.1:800/demo/hello" 'Automatically open browser to visit example End Sub ``` ### 2. Hello Business Class (bHello.cls) ```vb Public Sub Hello(ctx As cHttpServerContext) Dim id As Long: id = ctx.Request.QueryString("id") 'Get URL parameter id ctx.Response.Text "hello vbman @ " & id 'Return response text End Sub ``` ## Feature Description 1. **HTTP Server Configuration** * Create HTTP server using VBMAN library's cHttpServer class * Server listens on port 800 * Automatically opens browser to visit example page when program starts 2. **Routing System** * Register bHello class as Demo business handler * Enable auto routing feature (AutoRoute = True) * Route rule: /demo/hello maps to bHello.Hello method * URL parameter example: /demo/hello?id=123 3. **Request Handling** * Get URL parameters through ctx.Request.QueryString * Return text response using ctx.Response.Text ## Technical Points 1. VBMAN handles web requests in an object-oriented way 2. Auto routing feature can automatically generate URL paths based on class and method names 3. Context object (ctx) provides complete request/response handling capabilities ## Running Effect After startup, it will automatically open the browser to visit http://127.0.0.1:800/demo/hello, and the page will display "hello vbman @ " followed by the provided id value. ## Extension Suggestions 1. Add more business methods to handle different URL requests 2. Return different types of responses, such as JSON, HTML, etc. 3. Add more URL parameter handling logic --- --- url: /zh/vbman/demo/4.cJson.md --- # VBMAN JSON 数据处理示例 ## 概述 这个示例展示了如何使用 VBMAN 框架处理 JSON 数据,包括 JSON 的创建、解析、修改和序列化等操作。VBMAN 提供了简单易用的 JSON API。 ## 项目结构 ::: tip 下载源码 \[ 注意：重新到`bin`目录注册 DLL 文件 ] 代码请到首页下载VBMAN 项目，解压后，打开包含所有DEMO项目。 ::: ``` Json/ ├── Form1.frm # 主窗体,包含 JSON 操作示例代码 ├── Form1.frx # 窗体资源文件 └── VBMAN_DEMOS.vbp # VB6项目文件 ``` ## 核心代码解析 ### 1. JSON 对象创建和属性设置 ```vb With VBMAN.Json .Item("a") = 1 '设置数字类型 .Item("b") = "dengwei" '设置字符串类型 '创建嵌套数组 With .NewItems("c") For i = 0 To 3 With .NewItem() '添加数组元素 .Item("d") = Now() .Item("e") = 34 + i .Item("f") = "测试内容: " & i End With Next End With End With ``` ### 2. JSON 文件操作 ```vb '保存 JSON 到文件 .SaveTo "c:\tmp\demo.json", , 2 '第三个参数为格式化缩进空格数 '从文件加载 JSON With VBMAN.Json.LoadFrom("c:\tmp\demo.json") MsgBox .Root("b") '访问顶层属性 MsgBox .Root("c")(1)("f") '访问嵌套属性 End With ``` ### 3. JSON 数据访问 ```vb '使用数组下标访问(从1开始) MsgBox json("c")(2)("f") '使用 For Each 遍历 Dim x As Variant For Each x In json("c") Debug.Print x("f") Next '使用索引遍历 For i = 1 To json("c").Count Debug.Print json("c")(i)("f") Next ``` ### 4. JSON 序列化 ```vb '将 JSON 转换为格式化字符串 Text1.Text = json.Encode(, 2, True) '参数说明: '第2个参数: 缩进空格数 '第3个参数: 是否使用 Unicode ``` ## 功能说明 1. **JSON 数据创建** * 支持各种数据类型(数字、字符串、布尔等) * 支持嵌套对象和数组 * 链式操作API * 自动类型转换 2. **JSON 数据访问** * 使用键值或索引访问 * 支持多级嵌套访问 * 支持数组遍历 * 支持集合操作 3. **JSON 序列化** * 格式化输出 * Unicode 支持 * 自定义缩进 * 文件读写支持 ## 技术要点 1. 面向对象的 JSON API 设计 2. 支持复杂的嵌套数据结构 3. 完整的文件操作支持 4. 灵活的遍历方式 5. 格式化输出控制 ## 使用场景 1. Web API 数据交换 2. 配置文件处理 3. 数据序列化 4. 前后端数据通信 ## 扩展建议 1. 添加 JSON Schema 验证 2. 添加 JSON Path 查询 3. 实现 JSON 数据压缩 4. 添加更多辅助函数 5. 实现 JSON 数据比较功能 --- --- url: /en/vbman/demo/4.cJson.md --- # VBMAN JSON Data Processing Example ## Overview This example demonstrates how to process JSON data using the VBMAN framework, including JSON creation, parsing, modification, and serialization operations. VBMAN provides a simple and easy-to-use JSON API. ## Project Structure ::: tip Download source \[ Note：To `bin` regedits DLL file ] Please go to the home page to download the VBMAN project, decompress it, and open it with all DEMO projects. ::: ``` Json/ ├── Form1.frm # Main form containing JSON operation example code ├── Form1.frx # Form resource file └── VBMAN_DEMOS.vbp # VB6 project file ``` ## Core Code Analysis ### 1. JSON Object Creation and Property Setting ```vb With VBMAN.Json .Item("a") = 1 'Set numeric type .Item("b") = "dengwei" 'Set string type 'Create nested array With .NewItems("c") For i = 0 To 3 With .NewItem() 'Add array element .Item("d") = Now() .Item("e") = 34 + i .Item("f") = "Test content: " & i End With Next End With End With ``` ### 2. JSON File Operations ```vb 'Save JSON to file .SaveTo "c:\tmp\demo.json", , 2 'Third parameter is formatting indent spaces 'Load JSON from file With VBMAN.Json.LoadFrom("c:\tmp\demo.json") MsgBox .Root("b") 'Access top-level property MsgBox .Root("c")(1)("f") 'Access nested property End With ``` ### 3. JSON Data Access ```vb 'Using array index (starting from 1) MsgBox json("c")(2)("f") 'Using For Each iteration Dim x As Variant For Each x In json("c") Debug.Print x("f") Next 'Using index iteration For i = 1 To json("c").Count Debug.Print json("c")(i)("f") Next ``` ### 4. JSON Serialization ```vb 'Convert JSON to formatted string Text1.Text = json.Encode(, 2, True) 'Parameters: '2nd parameter: indent spaces '3rd parameter: use Unicode ``` ## Feature Description 1. **JSON Data Creation** * Support for various data types (numbers, strings, booleans, etc.) * Support for nested objects and arrays * Chainable API operations * Automatic type conversion 2. **JSON Data Access** * Access using keys or indices * Support for multi-level nested access * Support for array iteration * Support for collection operations 3. **JSON Serialization** * Formatted output * Unicode support * Custom indentation * File I/O support ## Technical Points 1. Object-oriented JSON API design 2. Support for complex nested data structures 3. Complete file operation support 4. Flexible iteration methods 5. Formatted output control ## Use Cases 1. Web API data exchange 2. Configuration file processing 3. Data serialization 4. Frontend-backend data communication ## Extension Suggestions 1. Add JSON Schema validation 2. Add JSON Path querying 3. Implement JSON data compression 4. Add more helper functions 5. Implement JSON data comparison functionality --- --- url: /en/vbman/LICENSE_GUIDE.md --- # VBMAN License Usage Guide This document helps you quickly understand the licensing requirements of the VBMAN project and when you need to pay for a commercial license. *** ## Core Points of the Existing License ### Base License: GPL-3.0 VBMAN is licensed under the **GNU General Public License v3.0 (GPL-3.0)** open source license. ## One-Sentence Summary > **Using compiled DLL → Completely Free**\ > **Modifying source code and open-sourcing → Completely Free**\ > **Using DLL is free; modifying source code and using it closed-source requires payment.** *** ## Detailed Explanation ### 1. Binary Files (Permanently Free) VBMAN compiled binary files (`.dll`, `.exe`, etc.) are **permanently free** with no usage restrictions: * ✅ Personal projects — Free * ✅ Commercial software directly referencing VBMAN DLL — Free * ✅ Internal company tool development — Free * ✅ Open source projects — Free ### 2. Source Code Usage #### Case 1: Free Usage (Complying with GPL) If you meet any of the following conditions, you can use the source code for free: 1. **Personal learning/research** — Modifying for your own use, not distributed externally 2. **Modified and open-sourced** — If you modify VBMAN and distribute it (including selling), you must open-source the entire project under a GPL-compatible license **Core GPL Requirements:** * Must include LICENSE file when distributing * Modified works must also be open-sourced under GPL * Retain copyright notices and disclaimers #### Case 2: Requires Commercial License Only one situation requires payment: > **You want to use VBMAN source code in a closed-source commercial project and do not want to open-source your own code.** Common scenarios: | Scenario | Description | | ------------------------------------------ | ------------ | | Modified VBMAN source code but don't want to open-source modifications | Requires commercial license | | Integrated VBMAN source code into closed-source product for sale | Requires commercial license | | SaaS service using modified VBMAN source code but closed-source deployment | Requires commercial license | *** ## Decision Flowchart ``` ┌─────────────────────────────────────┐ │ Do you want to use VBMAN for │ │ commercial purposes? │ └──────────────────┬──────────────────┘ │ ┌─────────┴─────────┐ ▼ ▼ ┌──────────┐ ┌──────────┐ │ Use DLL │ │ Use Source │ │ Only │ │ Code │ └────┬─────┘ └────┬─────┘ │ │ ▼ ▼ ┌──────────┐ ┌──────────────┐ │ Free │ │ Distribute? │ │ No │ └──────┬───────┘ │ License │ │ │ Required │ ┌──────┴──────┐ └──────────┘ ▼ ▼ ┌──────────┐ ┌──────────┐ │Closed │ │ Open │ │Source │ │ Source │ └────┬─────┘ └────┬─────┘ │ │ ▼ ▼ ┌──────────┐ ┌──────────┐ │Purchase │ │Completely│ │Commercial│ │ Free │ │License │ │ GPL │ └──────────┘ └──────────┘ ``` ## Summary ### Definition of Payment Situations **1. Binary Files (DLL, EXE, etc.)** * Permanently free * No usage restrictions * Whether for personal or commercial use **2. Source Code Usage - Individual Users** * Free to use * But must comply with GPL license requirements: * Must include LICENSE file when distributing * Modified works must also be open-sourced under GPL-compatible license **3. Source Code Usage - Commercial Scenarios** There are two situations here: **Scenario A: Open Source Commercial Use (Free)** * If your commercial project is based on modifications or secondary development of this project * And when **distributing/selling**, you **open-source the entire project's source code** under a GPL-compatible license * In this case, **no payment is required** **Scenario B: Closed Source Commercial Use (Requires Payment)** * If you want to use this project's source code in a **closed-source commercial project** * That is, you don't want to open-source your own code * You must contact the author to purchase a commercial license ### Specific Scenarios Requiring Payment 1. Commercial software company developing closed-source products using VBMAN source code 2. Internal closed-source enterprise systems using VBMAN source code and not wanting to follow GPL open-source requirements 3. SaaS service providers building services on closed-source code ### Scenarios Not Requiring Payment 1. Directly using compiled DLL/EXE files, whether for personal or commercial use 2. Personal learning and research using source code 3. Projects based on source code development that are willing to open-source modified code 4. Any project following GPL open-source license The core of commercial licensing lies in how the source code is used, rather than the deployment of binary files. The developer provides flexible usage paths, ensuring both open-source spirit and legal avenues for commercial applications. The key is whether the user is willing to bear the open-source obligation, or choose to purchase a license for closed-source use. According to the content of `LICENSE` and `readme.md`, here is a summary of the existing license definitions: *** ## Core Points of the Existing License ### Base License: GPL-3.0 VBMAN is licensed under the **GNU General Public License v3.0 (GPL-3.0)** open source license. *** ## Definition of Payment Situations ### 1. Binary Files (Permanently Free) ``` Compiled binary files (DLL, EXE, etc.) of this project are permanently free with no usage restrictions. ``` Whether for personal or commercial purposes, **using the compiled DLL directly is completely free**, no payment is required. *** ### 2. Source Code Usage (Scenario-Based) | Usage Scenario | Requires Payment | Conditions | | ------------------- | ------------ | --------------------------------------------------------------------------------- | | **Personal Use** | Free | Comply with GPL license (include LICENSE, open-source after modifications) | | **Commercial Use + Open Source** | Free | When **distributing/selling** after modifying this project, **must open-source the entire project's source code** (GPL-compatible license) | | **Commercial Use + Closed Source** | **Requires Payment** | Want to use source code in **closed-source commercial project**, not open-source your own code | *** ## When Do You Need to Pay? **Only one condition**: You want to use VBMAN source code in a **closed-source commercial software** and do not want to open-source your own code. Specific scenario examples: | Scenario | Requires Commercial License | | ---------------------------------------------------- | ---------------- | | Using VBMAN DLL to develop tools internally within the company | Free | | Developing commercial software, directly referencing VBMAN DLL | Free | | Modified VBMAN source code, distributing modified DLL to customers (open-source) | Free | | Modified VBMAN source code, distributing modified DLL to customers (closed-source) | **Requires Payment** | | SaaS service using VBMAN source code but closed-source deployment | **Requires Payment** | *** ## Commercial License Information For closed-source commercial licensing, please contact: * **Author**: Deng Wei (邓伟) * **Website**: https://a-vi.com * **Repository**: https://gitcode.com/woeoio/vbman Commercial license fees are negotiated based on specific usage scenarios and scope. *** ## Frequently Asked Questions (FAQ) **Q1: I use VBMAN to develop internal tools at my company. Do I need to pay?**\ A: No. Using the DLL directly is completely free. **Q2: I modified VBMAN's source code, made it into a product and sold it to others, but I don't want to open-source it. What should I do?**\ A: You need to purchase a commercial license. Otherwise, it violates the GPL license. **Q3: I developed an open-source software using VBMAN. Can I charge for it?**\ A: Yes. The GPL license allows you to sell for a fee, but you must provide the source code to customers. **Q4: Is VBMAN2 under the same licensing policy?**\ A: VBMAN2 is not open-sourced, only binary files are provided, and they are permanently free to use. *** ## Full Legal Text For detailed terms, please refer to the [LICENSE](LICENSE) file. --- --- url: /en/vbman/demo/5.MiddleWare.md --- # VBMAN Middleware and Client Communication Example ## Overview This example demonstrates how to build a web server with middleware using the VBMAN framework, and how to implement client-server communication. The example includes advanced features such as authentication middleware. ## Project Structure ::: tip Download source \[ Note：To `bin` regedits DLL file ] Please go to the home page to download the VBMAN project, decompress it, and open it with all DEMO projects. ::: ``` MiddleWare/ ├── server/ # Server-side project │ ├── Form1.frm # Server main form │ ├── DataServer.vbp # Server project file │ └── include/ # Server-side class libraries │ ├── bWcs.cls # Business processing class │ ├── mAuth.cls # Authentication middleware │ ├── Config.bas # Configuration module │ └── ToolsHttp.bas # HTTP utility module └── client/ # Client project ├── Client.frm # Client main form ├── DataClient.vbp # Client project file └── include/ # Client-side class libraries ├── cHttpClient.cls # HTTP client class ├── bTaskSend.cls # Task sending class ├── bTaskLog.cls # Task logging class └── cJson.cls # JSON processing class ``` ## Core Code Analysis ### 1. Server-side Middleware Configuration (Form1.frm) ```vb 'Server initialization Dim HttpServer As New VBMANLIB.cHttpServer Private Sub Form_Load() With HttpServer 'Register business class .Router.Reg "Wcs", New bWcs 'Configure pre-middleware for authentication check .Router.Before.Add "/*", New mAuth 'Start server .Start 800 End With End Sub ``` ### 2. Authentication Middleware (mAuth.cls) ```vb Public Sub Execute(ctx As cHttpServerContext) 'Get authentication information Dim token As String: token = ctx.Request.Headers("Authorization") 'Terminate request on authentication failure If Not IsValidToken(token) Then ctx.Response.State401 "Unauthorized" ctx.Abort End If End Sub ``` ### 3. Client Request Sending (Client.frm) ```vb Private Sub SendTask() With New cHttpClient 'Set request headers .RequestHeaders.Add "Authorization", "Bearer " & token .RequestHeaders.Add "Content-Type", "application/json" 'Send request Dim response As String response = .Fetch(ReqPost, "http://localhost:800/wcs/task", jsonData) 'Handle response Debug.Print .ReturnJson().Encode(, 2) End With End Sub ``` ## Feature Description 1. **Middleware System** * Support for pre-middleware (Before) * Support for post-middleware (After) * Support for middleware chain calls * Support for request interception and termination 2. **Authentication** * Token authentication mechanism * Request header validation * Configurable validation rules * Unified error handling 3. **Client Functionality** * HTTP request encapsulation * Header management * JSON data processing * Response handling ## Technical Points 1. Implementation of middleware mechanism 2. Encapsulation of HTTP communication 3. Unified handling of authentication 4. Client-server interaction ## Use Cases 1. Web APIs requiring authentication 2. Distributed system communication 3. Microservice architecture 4. Business system integration ## Extension Suggestions 1. Add more types of middleware 2. Implement request rate limiting 3. Add data validation middleware 4. Implement caching middleware 5. Add logging middleware --- --- url: /en/vbman/demo/10.Multiprocessor.md --- # VBMAN Multiprocessor Example ## Overview This example demonstrates how to implement multiprocessing using the VBMAN framework, improving application performance and stability by distributing business logic across different processes. ## Project Structure ::: tip Download source \[ Note：To `bin` regedits DLL file ] Please go to the home page to download the VBMAN project, decompress it, and open it with all DEMO projects. ::: ``` Multiprocessor/ ├── Form1.frm # Main form, main process code ├── VBMAN_DEMO.vbp # Main process project file └── sub/ # Subprocess code ├── bUsers.cls # User business logic class └── VBMANControllers.vbp # Subprocess project file ``` ## Core Code Analysis ### 1. Main Process Code (Form1.frm) ```vb Dim HttpServer As New cHttpServer Private Sub Form_Load() With HttpServer 'Register subprocess user controller .Router.Reg "Users", New VBMANControllers.bUsers 'Configure API routes .Router.Add "/api/users/list", "Users@List" 'Start server .Start 80 End With 'Open browser to visit example Shell "explorer.exe http://127.0.0.1:80/api/users/list" End Sub ``` ### 2. User Business Class (bUsers.cls) ```vb 'User business logic class, executed in subprocess Option Explicit Public Sub List(ctx As cHttpServerContext) 'Create mock user data With ctx.Response.NewJson .Items.Add GetUser(1, "John", 25) .Items.Add GetUser(2, "Mike", 30) .Items.Add GetUser(3, "David", 28) End With End Sub Private Function GetUser(id As Long, name As String, age As Long) As Object With VBMAN.Json.NewJson .Item("id") = id .Item("name") = name .Item("age") = age Set GetUser = .Item End With End Function ``` ## Feature Description 1. **Multiprocess Architecture** * Main process handles request distribution * Subprocesses handle specific business logic * Inter-process communication * Load balancing 2. **Business Processing** * Independent business modules * Fault isolation * Performance optimization * Resource management 3. **Process Management** * Process creation * Process monitoring * Process restart * Resource recovery ## Technical Points 1. Inter-Process Communication (IPC) 2. Request distribution mechanism 3. Subprocess management 4. Error handling mechanism ## Use Cases 1. High-concurrency web services 2. Large-scale data processing 3. Distributed computing 4. CPU-intensive tasks ## Extension Suggestions 1. Add process pool management 2. Implement dynamic scaling 3. Add process monitoring 4. Optimize process communication 5. Add failover support --- --- url: /en/vbman/demo/11.NetDataShow.md --- # VBMAN Network Data Display Example ## Overview This example demonstrates how to use the VBMAN framework to implement real-time network data display, including data collection, transmission, parsing, and visualization features. ## Project Structure ::: tip Download source \[ Note：To `bin` regedits DLL file ] Please go to the home page to download the VBMAN project, decompress it, and open it with all DEMO projects. ::: ``` NetDataShow/ ├── Form1.frm # Main form, contains data display interface ├── Form1.frx # Form resource file ├── NetDataShow.vbp # Project file └── _pic/ # Image resource directory ``` ## Core Code Analysis ### 1. Data Display Form (Form1.frm) ```vb 'Data display form Private WithEvents NetClient As New cTcpClient Private WithEvents Timer1 As New Timer Private Sub Form_Load() 'Connect to data server With NetClient .Connect "127.0.0.1", 9000 End With 'Start periodic refresh With Timer1 .Interval = 1000 .Enabled = True End With End Sub 'Data reception handling Private Sub NetClient_OnDataArrival() Dim data As String data = NetClient.RecvText 'Parse data ParseData data 'Update display UpdateDisplay End Sub 'Periodic refresh handling Private Sub Timer1_Timer() 'Get latest data NetClient.Send "GET_DATA" End Sub 'Data parsing Private Sub ParseData(data As String) With VBMAN.Json If .Decode(data) Then 'Parse temperature data txtTemp.Text = .Item("temperature") 'Parse humidity data txtHumidity.Text = .Item("humidity") 'Update trend chart UpdateChart .Item("history") End If End With End Sub ``` ### 2. Chart Display Implementation ```vb 'Update trend chart display Private Sub UpdateChart(history As Object) 'Clear old data Chart1.Clear 'Add new data points For Each point In history Chart1.AddPoint point("time"), point("value") Next 'Refresh display Chart1.Refresh End Sub 'Custom display format Private Sub FormatDisplay() 'Set value format txtTemp.Format = "0.00 ℃" txtHumidity.Format = "0.0 %" 'Set alarm thresholds txtTemp.AlarmValue = 30 txtHumidity.AlarmValue = 85 'Configure chart style With Chart1 .Title = "Temperature Trend" .XLabel = "Time" .YLabel = "Temperature(℃)" .GridVisible = True .Refresh End With End Sub ``` ## Feature Description 1. **Data Collection Features** * Network communication * Data parsing * Real-time updates * Periodic refresh 2. **Data Display** * Numerical display * Trend charts * Alarm notifications * Automatic refresh 3. **User Interface** * Layout design * Interactive control * Display formatting * Theme styling ## Technical Points 1. TCP communication implementation 2. JSON data processing 3. Chart control application 4. Interface refresh mechanism ## Use Cases 1. Industrial monitoring 2. Environmental monitoring 3. Equipment status monitoring 4. Data visualization ## Extension Suggestions 1. Add data recording 2. Implement multi-channel display 3. Add data analysis 4. Support report export 5. Optimize refresh mechanism --- --- url: /en/vbman/demo/6.SSE.md --- # VBMAN SSE (Server-Sent Events) Server Push Example ## Overview This example demonstrates how to implement SSE (Server-Sent Events) server push functionality using the VBMAN framework, enabling real-time data push from server to client. The example includes both timed push and manual push modes. ## Project Structure ::: tip Download source \[ Note：To `bin` regedits DLL file ] Please go to the home page to download the VBMAN project, decompress it, and open it with all DEMO projects. ::: ``` SSE/ ├── src/ # Server-side project │ ├── Form1.frm # Main form │ ├── bMes.cls # Message handling class │ └── VBMAN_DEMO_SSE.vbp # Project file └── www/ # Frontend pages └── Client.html # SSE client page ``` ## Core Code Analysis ### 1. Server Configuration (Form1.frm) ```vb Dim HttpServer As New VBMANLIB.cHttpServer Private Sub Form_Load() With HttpServer .Router.Reg "Mes", New bMes 'Register message handling class .Router.AutoRoute = True 'Enable auto routing .CrossDomain.Enable = True 'Allow cross-domain access 'Enable SSE functionality .SSE.Start 'Start Web server .WebRoot(App.Path & "\..\www").Start 82 End With Shell "explorer http://127.0.0.1:82/Client.html" End Sub 'Timer push Private Sub Timer1_Timer() HttpServer.SSE.SendPack "timer", Now() End Sub 'Manual push Private Sub Command1_Click() HttpServer.SSE.SendPack "test", Text2.Text End Sub ``` ### 2. Message Handling Class (bMes.cls) ```vb Public Sub Printer(ctx As VBMANLIB.cHttpServerContext) 'Get data sent from client Dim zs As String: zs = ctx.Request.Json.Root("data")(1)("name") Dim ls As String: ls = ctx.Request.Json.Root("data")(2)("name") 'Display data on interface Form1.Text1.Text = ctx.Request.Json.Encode(, 2) 'Respond to client ctx.Response.Text "Processing successful: " & Now() End Sub ``` ### 3. Client Implementation (Client.html) ```html ``` ## Feature Description 1. **SSE Server Features** * Support for multiple client connections * Support for timed push * Support for manual push * Support for custom event types 2. **Message Push Features** * Automatic reconnection mechanism * Disconnect reconnection * Event categorized push * Cross-domain support 3. **Client Features** * Native SSE support * Event listening mechanism * Connection status monitoring * Error handling ## Technical Points 1. SSE protocol implementation 2. Real-time data push 3. Long connection management 4. Event-driven model ## Use Cases 1. Real-time data monitoring 2. Message notification system 3. Real-time report updates 4. Live log display ## Extension Suggestions 1. Add message filtering mechanism 2. Implement message compression 3. Add message priority 4. Implement message confirmation mechanism 5. Add load balancing support --- --- url: /zh/vbman/demo/6.SSE.md --- # VBMAN SSE(Server-Sent Events)服务器推送示例 ## 概述 这个示例展示了如何使用 VBMAN 框架实现 SSE(Server-Sent Events)服务器推送功能,实现服务器向客户端的实时数据推送。示例包含定时推送和手动推送两种模式。 ## 项目结构 ::: tip 下载源码 \[ 注意：重新到`bin`目录注册 DLL 文件 ] 代码请到首页下载VBMAN 项目，解压后，打开包含所有DEMO项目。 ::: ``` SSE/ ├── src/ # 服务器端项目 │ ├── Form1.frm # 主窗体 │ ├── bMes.cls # 消息处理类 │ └── VBMAN_DEMO_SSE.vbp # 项目文件 └── www/ # 前端页面 └── Client.html # SSE客户端页面 ``` ## 核心代码解析 ### 1. 服务器端配置(Form1.frm) ```vb Dim HttpServer As New VBMANLIB.cHttpServer Private Sub Form_Load() With HttpServer .Router.Reg "Mes", New bMes '注册消息处理类 .Router.AutoRoute = True '开启自动路由 .CrossDomain.Enable = True '允许跨域访问 '启用 SSE 功能 .SSE.Start '启动 Web 服务器 .WebRoot(App.Path & "\..\www").Start 82 End With Shell "explorer http://127.0.0.1:82/Client.html" End Sub '定时器推送 Private Sub Timer1_Timer() HttpServer.SSE.SendPack "timer", Now() End Sub '手动推送 Private Sub Command1_Click() HttpServer.SSE.SendPack "test", Text2.Text End Sub ``` ### 2. 消息处理类(bMes.cls) ```vb Public Sub Printer(ctx As VBMANLIB.cHttpServerContext) '获取客户端发送的数据 Dim zs As String: zs = ctx.Request.Json.Root("data")(1)("name") Dim ls As String: ls = ctx.Request.Json.Root("data")(2)("name") '将数据显示在界面上 Form1.Text1.Text = ctx.Request.Json.Encode(, 2) '响应客户端 ctx.Response.Text "处理成功: " & Now() End Sub ``` ### 3. 客户端实现(Client.html) ```html ``` ## 功能说明 1. **SSE服务端功能** * 支持多客户端连接 * 支持定时推送 * 支持手动推送 * 支持自定义事件类型 2. **消息推送特性** * 自动重连机制 * 断线重连 * 事件分类推送 * 跨域支持 3. **客户端功能** * 原生 SSE 支持 * 事件监听机制 * 连接状态监控 * 错误处理 ## 技术要点 1. SSE 协议实现 2. 实时数据推送 3. 长连接管理 4. 事件驱动模型 ## 应用场景 1. 实时数据监控 2. 消息通知系统 3. 实时报表更新 4. 日志实时显示 ## 扩展建议 1. 添加消息过滤机制 2. 实现消息压缩 3. 添加消息优先级 4. 实现消息确认机制 5. 添加负载均衡支持 --- --- url: /zh/vbman/demo/7.SSE2.md --- # VBMAN SSE2 高级服务器推送示例 ## 概述 这个示例在基础 SSE 示例的基础上，展示了更复杂的实时数据推送场景，包括数据的展示和发送的分离处理，以及更灵活的数据推送模式。 ## 项目结构 ::: tip 下载源码 \[ 注意：重新到`bin`目录注册 DLL 文件 ] 代码请到首页下载VBMAN 项目，解压后，打开包含所有DEMO项目。 ::: ``` SSE2/ ├── src/ # 服务器端项目 │ ├── Form1.frm # 主窗体 │ ├── bShowData.cls # 数据展示类 │ ├── bSendData.cls # 数据发送类 │ ├── ToolsMath.bas # 数学工具模块 │ ├── ToolsWindow.bas # 窗口工具模块 │ └── VBMAN_DEMO_SSE2.vbp # 项目文件 └── www/ # 前端页面 ├── index.html # 主页面 └── js/ # 前端脚本 └── app.js # SSE客户端实现 ``` ## 核心代码解析 ### 1. 服务器端配置(Form1.frm) ```vb Public HttpServer As New VBMANLIB.cHttpServer Private Sub Form_Load() With HttpServer '注册数据展示和发送处理类 .Router.Reg "ShowData", New bShowData .Router.Reg "SendData", New bSendData '启用跨域和自动路由 .Router.AutoRoute = True .CrossDomain.Enable = True '启用 SSE .SSE.Start '启动服务器 .WebRoot(App.Path & "\..\www").Start 82 '显示服务器状态 Label1.Caption = "服务器运行中..." End With Shell "explorer http://127.0.0.1:82/" End Sub '手动推送测试数据 Private Sub Command1_Click() HttpServer.SSE.SendPack "testData", Text2.Text End Sub ``` ### 2. 数据展示类(bShowData.cls) ```vb Public Sub List(ctx As cHttpServerContext) '模拟从数据源获取数据 Dim data As New Collection With data .Add "数据项1" .Add "数据项2" .Add "数据项3" End With '返回JSON格式数据 ctx.Response.Json data End Sub Public Sub Detail(ctx As cHttpServerContext) Dim id As String: id = ctx.Request.QueryString("id") '返回详细数据 With ctx.Response.NewJson .Item("id") = id .Item("name") = "测试数据 " & id .Item("time") = Now() End With End Sub ``` ### 3. 数据发送类(bSendData.cls) ```vb Public Sub Push(ctx As cHttpServerContext) '获取推送数据 Dim data As String: data = ctx.Request.Form("data") '推送到所有连接的客户端 Form1.HttpServer.SSE.SendPack "newData", data '记录到日志列表 Form1.List1.AddItem Now() & " - " & data '返回成功 ctx.Response.Json True End Sub ``` ### 4. 客户端实现(app.js) ```javascript class DataMonitor { constructor() { // 创建 SSE 连接 this.source = new EventSource('/sse'); // 配置事件监听 this.source.addEventListener('newData', this.handleNewData.bind(this)); this.source.addEventListener('testData', this.handleTestData.bind(this)); // 错误处理 this.source.onerror = this.handleError.bind(this); } handleNewData(e) { // 处理新数据 const data = JSON.parse(e.data); this.updateUI(data); } handleTestData(e) { // 处理测试数据 console.log('收到测试数据:', e.data); } handleError(e) { console.error('SSE连接错误:', e); // 实现重连逻辑 } updateUI(data) { // 更新页面显示 } } // 初始化监控 new DataMonitor(); ``` ## 功能说明 1. **数据处理分离** * 展示逻辑与发送逻辑分离 * 模块化的数据处理 * 清晰的职责划分 * 可扩展的架构设计 2. **高级推送特性** * 数据广播推送 * 日志记录功能 * 多种数据格式支持 * 错误处理机制 3. **客户端增强** * 面向对象的实现 * 模块化的事件处理 * 完整的错误处理 * UI自动更新 ## 技术要点 1. 模块化设计 2. 数据处理分离 3. 双向通信实现 4. 界面实时更新 ## 应用场景 1. 复杂数据监控系统 2. 多源数据整合展示 3. 实时数据分析平台 4. 监控告警系统 ## 扩展建议 1. 添加数据过滤器 2. 实现数据持久化 3. 添加数据验证机制 4. 实现数据轮询备份 5. 添加性能监控 --- --- url: /en/vbman/demo/7.SSE2.md --- # VBMAN SSE2 Advanced Server Push Example ## Overview This example builds upon the basic SSE example to demonstrate more complex real-time data push scenarios, including separated handling of data display and sending, as well as more flexible data push patterns. ## Project Structure ::: tip Download source \[ Note：To `bin` regedits DLL file ] Please go to the home page to download the VBMAN project, decompress it, and open it with all DEMO projects. ::: ``` SSE2/ ├── src/ # Server-side project │ ├── Form1.frm # Main form │ ├── bShowData.cls # Data display class │ ├── bSendData.cls # Data sending class │ ├── ToolsMath.bas # Math utility module │ ├── ToolsWindow.bas # Window utility module │ └── VBMAN_DEMO_SSE2.vbp # Project file └── www/ # Frontend pages ├── index.html # Main page └── js/ # Frontend scripts └── app.js # SSE client implementation ``` ## Core Code Analysis ### 1. Server Configuration (Form1.frm) ```vb Public HttpServer As New VBMANLIB.cHttpServer Private Sub Form_Load() With HttpServer 'Register data display and sending handler classes .Router.Reg "ShowData", New bShowData .Router.Reg "SendData", New bSendData 'Enable cross-domain and auto routing .Router.AutoRoute = True .CrossDomain.Enable = True 'Enable SSE .SSE.Start 'Start server .WebRoot(App.Path & "\..\www").Start 82 'Display server status Label1.Caption = "Server running..." End With Shell "explorer http://127.0.0.1:82/" End Sub 'Manually push test data Private Sub Command1_Click() HttpServer.SSE.SendPack "testData", Text2.Text End Sub ``` ### 2. Data Display Class (bShowData.cls) ```vb Public Sub List(ctx As cHttpServerContext) 'Simulate getting data from data source Dim data As New Collection With data .Add "Data Item 1" .Add "Data Item 2" .Add "Data Item 3" End With 'Return data in JSON format ctx.Response.Json data End Sub Public Sub Detail(ctx As cHttpServerContext) Dim id As String: id = ctx.Request.QueryString("id") 'Return detailed data With ctx.Response.NewJson .Item("id") = id .Item("name") = "Test Data " & id .Item("time") = Now() End With End Sub ``` ### 3. Data Sending Class (bSendData.cls) ```vb Public Sub Push(ctx As cHttpServerContext) 'Get push data Dim data As String: data = ctx.Request.Form("data") 'Push to all connected clients Form1.HttpServer.SSE.SendPack "newData", data 'Record to log list Form1.List1.AddItem Now() & " - " & data 'Return success ctx.Response.Json True End Sub ``` ### 4. Client Implementation (app.js) ```javascript class DataMonitor { constructor() { // Create SSE connection this.source = new EventSource('/sse'); // Configure event listeners this.source.addEventListener('newData', this.handleNewData.bind(this)); this.source.addEventListener('testData', this.handleTestData.bind(this)); // Error handling this.source.onerror = this.handleError.bind(this); } handleNewData(e) { // Handle new data const data = JSON.parse(e.data); this.updateUI(data); } handleTestData(e) { // Handle test data console.log('Received test data:', e.data); } handleError(e) { console.error('SSE connection error:', e); // Implement reconnection logic } updateUI(data) { // Update page display } } // Initialize monitoring new DataMonitor(); ``` ## Feature Description 1. **Separated Data Processing** * Separation of display logic and sending logic * Modular data processing * Clear responsibility division * Extensible architecture design 2. **Advanced Push Features** * Data broadcast pushing * Logging functionality * Multiple data format support * Error handling mechanism 3. **Enhanced Client Features** * Object-oriented implementation * Modular event handling * Complete error handling * Automatic UI updates ## Technical Points 1. Modular design 2. Separated data processing 3. Two-way communication implementation 4. Real-time interface updates ## Use Cases 1. Complex data monitoring systems 2. Multi-source data integration display 3. Real-time data analysis platform 4. Monitoring and alerting systems ## Extension Suggestions 1. Add data filters 2. Implement data persistence 3. Add data validation mechanism 4. Implement data polling backup 5. Add performance monitoring --- --- url: /en/vbman/demo/13.Weather.md --- # VBMAN Weather demo ## Overview This is a weather forecast query instance. It uses the weather forecast query interface to get weather forecast information and play the cctv video. ## Project Structure ::: tip Download source \[ Note：To `bin` regedits DLL file ] Please go to the home page to download the VBMAN project, decompress it, and open it with all DEMO projects. ::: ``` Weather/ ├── Form1.frm # Main form └── Weather.vbp # VB6 project file ``` ## Core Code Analysis ### 1. Main Form (Form1.frm) ```vb Private Sub Command1_Click() 'City ID Dim id$: id = Text4.Text 'City name query interface Const areaid$ = "https://i.tq121.com.cn/j/wap2016/news/city_search_data.js?20220422" 'Weather forecast video and area Const videos$ = "https://e.weather.com.cn/pubm/videos_vms1.htm?callback=getLbDatas&_=1747888658520" Dim area$: area = "https://e.weather.com.cn/p/site/aqifc1h?areaid=" & id & "&callback=aqifc1h&_=1747888658537" 'Current weather forecast Dim tq$: tq = "https://d1.weather.com.cn/sk_2d/" & id & ".html?_=1747889185006" 'One week weather forecast Dim week$: week = "https://d1.weather.com.cn/weixinfc/" & id & ".html?_=1747889185007" 'Weather overview Dim sum$: sum = "https://d1.weather.com.cn/weather_index/" & id & ".html?_=1747889185008" 'Direct call 'Text1.Text = VBMAN.HttpClient.Fetch(ReqGet, videos).ReturnJson().Encode(, 2, True) With VBMAN.HttpClient.Fetch(ReqGet, videos).ReturnJson() Text1.Text = .Encode(, 2, True) 'show text content Dim url$: url = .Root("documents")(1)("videourl")(1)("url") WindowsMediaPlayer1.url = url 'play weather forecast video End With 'add "referer" header ^"referer: https://e.weather.com.cn/^" ^ With VBMAN.HttpClient .RequestHeaders("referer") = "https://e.weather.com.cn/" 'Get current weather data With .Fetch(ReqGet, tq).ReturnJson() Label1.Caption = .Root("cityname") & " Current temperature: " & .Root("temp") & " degree" Text2.Text = .Encode(, 2, True) end With 'Get city ID data Text3.Text = .Fetch(ReqGet, areaid).ReturnText() end With end sub ``` ## Function Description 1. **Interface List** * Query city ID interface * Get city ID data * Get weather forecast video and area * Get current weather forecast * Get one week weather forecast * Get weather overview 2. **Effect Screenshots** ## Technical Points 1. VBMAN library provides HttpClient class for HTTP requests. 2. The Fetch method of HttpClient class can send HTTP requests and return response results. 3. The ReturnJson method of Fetch method can convert response results to JSON objects and perform subsequent processing. 4. The ReturnText method of Fetch method can convert response results to text and perform subsequent processing. 5. The RequestHeaders property of HttpClient class can add request headers, such as adding Referer header. 6. The Root method of Json class can get the root node of JSON objects and use the Root method to get the value of a node. 7. The Encode method of Json class can convert JSON objects to text and set indentation and line breaks. 8. The WindowsMediaPlayer control can play videos. ## Use Cases 1. Add more city query functions, such as adding city lists, users enter city names to query city IDs, and display weather forecasts. 2. Add more weather forecast query functions, such as adding weather forecast query lists, users select cities to query weather forecasts. 3. Add more weather forecast query functions, such as adding weather forecast query lists, users select cities to query weather forecasts. --- --- url: /en/vbman/demo/2.Webroot.md --- # VBMAN Webroot Static File Server Example ## Overview This example demonstrates how to quickly set up a static file server using VBMAN to host static resource files for your website. ## Project Structure ::: tip Download source \[ Note：To `bin` regedits DLL file ] Please go to the home page to download the VBMAN project, decompress it, and open it with all DEMO projects. ::: ``` Webroot/ ├── Form1.frm # Main form ├── Webroot.vbp # VB6 project file └── www/ # Static files directory ``` ## Core Code Analysis ### Main Form (Form1.frm) ```vb Dim HttpServer As New cHttpServer Private Sub Form_Load() HttpServer.WebRoot(App.Path & "\www").Start 800 'Start server and specify www directory as website root Shell "explorer.exe http://127.0.0.1:800" 'Automatically open browser End Sub ``` ## Feature Description 1. **Static File Server Configuration** * Create HTTP server based on VBMAN * Server listens on port 800 * Specify www directory as website root directory 2. **Automatic File Service** * Automatically handle requests for static files * Support common file types (HTML, CSS, JavaScript, images, etc.) * Automatic handling of file MIME types 3. **Directory Service** * Automatically look for default files (e.g., index.html) when accessing directories * Support directory browsing (if enabled) ## Technical Points 1. VBMAN has built-in static file serving capability, no additional code needed 2. Static file server can be used alongside dynamic routing 3. Support setting custom website root directory ## Use Cases 1. Hosting Single Page Applications (SPA) 2. Providing file download service 3. Setting up simple documentation sites 4. Serving as a static resource server for development environment ## Extension Suggestions 1. Add access control and authentication 2. Configure cache control 3. Add custom error pages 4. Combine with dynamic routing for more complex functionality --- --- url: /zh/vbman/demo/2.Webroot.md --- # VBMAN Webroot静态文件服务示例 ## 概述 这个示例展示了如何使用 VBMAN 快速搭建一个静态文件服务器，可以用来托管网站的静态资源文件。 ## 项目结构 ::: tip 下载源码 \[ 注意：重新到`bin`目录注册 DLL 文件 ] 代码请到首页下载VBMAN 项目，解压后，打开包含所有DEMO项目。 ::: ``` Webroot/ ├── Form1.frm # 主窗体 ├── Webroot.vbp # VB6项目文件 └── www/ # 静态文件目录 ``` ## 核心代码解析 ### 主窗体(Form1.frm) ```vb Dim HttpServer As New cHttpServer Private Sub Form_Load() HttpServer.WebRoot(App.Path & "\www").Start 800 '启动服务器并指定www目录作为网站根目录 Shell "explorer.exe http://127.0.0.1:800" '自动打开浏览器访问 End Sub ``` ## 功能说明 1. **静态文件服务器配置** * 创建基于 VBMAN 的 HTTP 服务器 * 服务器监听 800 端口 * 指定 www 目录作为网站根目录 2. **自动文件服务** * 自动处理对静态文件的请求 * 支持常见的文件类型(HTML, CSS, JavaScript, 图片等) * 自动处理文件的 MIME 类型 3. **目录服务** * 访问目录时自动寻找默认文件(如 index.html) * 支持目录浏览(如果启用) ## 技术要点 1. VBMAN 内置了静态文件服务能力，无需额外编写代码 2. 静态文件服务器可以与动态路由同时使用 3. 支持设置自定义的网站根目录 ## 使用场景 1. 托管单页面应用(SPA) 2. 提供文件下载服务 3. 搭建简单的文档站点 4. 作为开发环境的静态资源服务器 ## 扩展建议 1. 可以添加访问控制和认证 2. 可以配置缓存控制 3. 可以添加自定义的错误页面 4. 可以与动态路由结合使用，实现更复杂的功能 --- --- url: /zh/vbman/demo/8.WebSocket.md --- # VBMAN WebSocket 双向通信示例 ::: danger 提示 本篇由ai根据vbman源码自动猜测，真实对象尚未发布。 ::: ## 概述 这个示例展示了如何使用 VBMAN 框架实现基于 WebSocket 协议的实时双向通信。相比 SSE，WebSocket 提供了真正的双向通信能力，客户端和服务器都可以主动发送数据。 ## 项目结构 ::: tip 下载源码 \[ 注意：重新到`bin`目录注册 DLL 文件 ] 代码请到首页下载VBMAN 项目，解压后，打开包含所有DEMO项目。 ::: ``` WebSocket/ ├── server/ # WebSocket服务器 │ ├── Form1.frm # 服务器主窗体 │ ├── WebSocket.vbp # 服务器项目文件 │ └── include/ # 服务器端类库 │ ├── wsHandler.cls # WebSocket处理类 │ └── wsAuth.cls # WebSocket认证类 └── client/ # WebSocket客户端 ├── index.html # 客户端页面 └── js/ # 客户端脚本 └── ws.js # WebSocket客户端实现 ``` ## 核心代码解析 ### 1. WebSocket服务器配置(Form1.frm) ```vb Dim WebSocketServer As New cWebsocketServer Private Sub Form_Load() With WebSocketServer '注册事件处理程序 .Router.Reg "WS", New wsHandler '配置认证中间件 .Router.Before.Add "/*", New wsAuth '启动WebSocket服务器 .Start 81 End With End Sub 'WebSocket客户端连接事件 Private Sub WebSocketServer_OnAccept(ClientInfo As cHttpServerClientInfo, Disconnect As Boolean) List1.AddItem Now() & " - 新连接: " & ClientInfo.IP & ":" & ClientInfo.Port End Sub 'WebSocket数据到达事件 Private Sub WebSocketServer_OnDataArrival(Client As cWebsockerServerClient) '获取消息内容 Dim msg As String: msg = Client.ReceivedText '广播给所有客户端 Client.Parent.Broadcast msg '添加到日志 List1.AddItem Now() & " - 收到消息: " & msg End Sub ``` ### 2. WebSocket处理类(wsHandler.cls) ```vb Public Sub OnConnect(Client As cWebsockerServerClient) '连接建立时的处理 With Client.NewJson .Item("type") = "welcome" .Item("time") = Now() .Item("msg") = "欢迎加入聊天室" End With Client.SendJson Client.Json End Sub Public Sub OnMessage(Client As cWebsockerServerClient) '处理接收到的消息 Dim msg As String: msg = Client.ReceivedText '响应客户端 With Client.NewJson .Item("type") = "reply" .Item("time") = Now() .Item("msg") = "服务器已收到: " & msg End With Client.SendJson Client.Json End Sub Public Sub OnClose(Client As cWebsockerServerClient) '连接关闭时的处理 Client.Parent.Broadcast "用户离开: " & Client.ClientInfo.IP End Sub ``` ### 3. WebSocket认证中间件(wsAuth.cls) ```vb Public Sub Execute(Client As cWebsockerServerClient) '获取认证信息 Dim token As String: token = Client.Request.Headers("Sec-WebSocket-Protocol") '验证失败时关闭连接 If Not IsValidToken(token) Then Client.Close Exit Sub End If End Sub ``` ### 4. WebSocket客户端实现(ws.js) ```javascript class ChatClient { constructor() { // 创建WebSocket连接 this.ws = new WebSocket('ws://localhost:81'); // 绑定事件处理 this.ws.onopen = this.handleOpen.bind(this); this.ws.onmessage = this.handleMessage.bind(this); this.ws.onclose = this.handleClose.bind(this); this.ws.onerror = this.handleError.bind(this); } handleOpen(e) { console.log('WebSocket连接已建立'); this.send({type: 'login', user: this.username}); } handleMessage(e) { const data = JSON.parse(e.data); switch(data.type) { case 'welcome': this.showWelcome(data); break; case 'message': this.showMessage(data); break; case 'users': this.updateUsers(data.users); break; } } handleClose() { console.log('WebSocket连接已关闭'); } handleError(e) { console.error('WebSocket错误:', e); } send(data) { this.ws.send(JSON.stringify(data)); } } ``` ## 功能说明 1. **WebSocket服务器功能** * 支持多客户端连接 * 支持消息广播 * 支持私聊消息 * 支持自定义协议 2. **消息处理功能** * JSON格式消息 * 消息类型识别 * 消息路由分发 * 错误处理机制 3. **认证与安全** * 连接认证 * 心跳检测 * 断线重连 * 安全传输 ## 技术要点 1. WebSocket协议实现 2. 双向通信机制 3. 消息广播系统 4. 认证中间件 ## 应用场景 1. 在线聊天室 2. 游戏服务器 3. 协同编辑 4. 实时通知 ## 扩展建议 1. 添加消息压缩 2. 实现分组广播 3. 添加离线消息 4. 实现消息持久化 5. 添加集群支持 --- --- url: /en/vbman/demo/8.WebSocket.md --- # VBMAN WebSocket Bidirectional Communication Example ::: danger Note This article is automatically generated by AI based on VBMAN source code. The actual implementation has not been released yet. ::: ## Overview ::: tip Download source \[ Note：To `bin` regedits DLL file ] Please go to the home page to download the VBMAN project, decompress it, and open it with all DEMO projects. ::: This example demonstrates how to implement real-time bidirectional communication using WebSocket protocol with the VBMAN framework. Compared to SSE, WebSocket provides true two-way communication capability, allowing both client and server to actively send data. ## Project Structure ``` WebSocket/ ├── server/ # WebSocket server │ ├── Form1.frm # Server main form │ ├── WebSocket.vbp # Server project file │ └── include/ # Server-side class libraries │ ├── wsHandler.cls # WebSocket handler class │ └── wsAuth.cls # WebSocket authentication class └── client/ # WebSocket client ├── index.html # Client page └── js/ # Client scripts └── ws.js # WebSocket client implementation ``` ## Core Code Analysis ### 1. WebSocket Server Configuration (Form1.frm) ```vb Dim WebSocketServer As New cWebsocketServer Private Sub Form_Load() With WebSocketServer 'Register event handler .Router.Reg "WS", New wsHandler 'Configure authentication middleware .Router.Before.Add "/*", New wsAuth 'Start WebSocket server .Start 81 End With End Sub 'WebSocket client connection event Private Sub WebSocketServer_OnAccept(ClientInfo As cHttpServerClientInfo, Disconnect As Boolean) List1.AddItem Now() & " - New connection: " & ClientInfo.IP & ":" & ClientInfo.Port End Sub 'WebSocket data arrival event Private Sub WebSocketServer_OnDataArrival(Client As cWebsockerServerClient) 'Get message content Dim msg As String: msg = Client.ReceivedText 'Broadcast to all clients Client.Parent.Broadcast msg 'Add to log List1.AddItem Now() & " - Message received: " & msg End Sub ``` ### 2. WebSocket Handler Class (wsHandler.cls) ```vb Public Sub OnConnect(Client As cWebsockerServerClient) 'Handle connection establishment With Client.NewJson .Item("type") = "welcome" .Item("time") = Now() .Item("msg") = "Welcome to the chat room" End With Client.SendJson Client.Json End Sub Public Sub OnMessage(Client As cWebsockerServerClient) 'Handle received message Dim msg As String: msg = Client.ReceivedText 'Respond to client With Client.NewJson .Item("type") = "reply" .Item("time") = Now() .Item("msg") = "Server received: " & msg End With Client.SendJson Client.Json End Sub Public Sub OnClose(Client As cWebsockerServerClient) 'Handle connection closure Client.Parent.Broadcast "User left: " & Client.ClientInfo.IP End Sub ``` ### 3. WebSocket Authentication Middleware (wsAuth.cls) ```vb Public Sub Execute(Client As cWebsockerServerClient) 'Get authentication information Dim token As String: token = Client.Request.Headers("Sec-WebSocket-Protocol") 'Close connection if validation fails If Not IsValidToken(token) Then Client.Close Exit Sub End If End Sub ``` ### 4. WebSocket Client Implementation (ws.js) ```javascript class ChatClient { constructor() { // Create WebSocket connection this.ws = new WebSocket('ws://localhost:81'); // Bind event handlers this.ws.onopen = this.handleOpen.bind(this); this.ws.onmessage = this.handleMessage.bind(this); this.ws.onclose = this.handleClose.bind(this); this.ws.onerror = this.handleError.bind(this); } handleOpen(e) { console.log('WebSocket connection established'); this.send({type: 'login', user: this.username}); } handleMessage(e) { const data = JSON.parse(e.data); switch(data.type) { case 'welcome': this.showWelcome(data); break; case 'message': this.showMessage(data); break; case 'users': this.updateUsers(data.users); break; } } handleClose() { console.log('WebSocket connection closed'); } handleError(e) { console.error('WebSocket error:', e); } send(data) { this.ws.send(JSON.stringify(data)); } } ``` ## Feature Description 1. **WebSocket Server Features** * Support for multiple client connections * Support for message broadcasting * Support for private messaging * Support for custom protocols 2. **Message Processing Features** * JSON format messages * Message type identification * Message routing dispatch * Error handling mechanism 3. **Authentication and Security** * Connection authentication * Heartbeat detection * Automatic reconnection * Secure transmission ## Technical Points 1. WebSocket protocol implementation 2. Bidirectional communication mechanism 3. Message broadcasting system 4. Authentication middleware ## Use Cases 1. Online chat rooms 2. Game servers 3. Collaborative editing 4. Real-time notifications ## Extension Suggestions 1. Add message compression 2. Implement group broadcasting 3. Add offline messages 4. Implement message persistence 5. Add cluster support --- --- url: /zh/vbman/global/ai.md --- # VBMAN.AI - AI 对话客户端 ## 概述 `VBMAN.AI` 提供了通用 AI 对话功能，兼容任何 OpenAI API 格式的服务（豆包、DeepSeek、OpenAI、通义千问等），支持链式调用和流式响应。 ## 核心特性 * **链式调用**: 流畅的 API 设计 * **多服务商**: 内置豆包/DeepSeek/OpenAI/通义千问预设 * **流式响应**: 支持 SSE 实时流式输出 * **多轮对话**: 自动维护对话上下文 ## 快速使用 ### 最简单的调用 ```vb Dim Response As String Response = VBMAN.AI.ApiKey("sk-xxx").Chat("你好") ``` ### 使用预设 ```vb ' DeepSeek Response = VBMAN.AI.DeepSeek("your-key").Chat("你好") ' 豆包 Response = VBMAN.AI.Doubao("your-key").Model("ep-xxx").Chat("你好") ' OpenAI Response = VBMAN.AI.OpenAI("your-key").Model("gpt-4").Chat("你好") ' 通义千问 Response = VBMAN.AI.Qwen("your-key").Model("qwen-turbo").Chat("你好") ``` ### 完整配置 ```vb Response = VBMAN.AI.ApiKey("sk-xxx") _ .Model("gpt-4") _ .Temperature(0.7) _ .MaxTokens(1000) _ .System("你是一个专业的编程助手") _ .Chat("如何实现单例模式？") ``` ### 流式响应（回调方式） ```vb VBMAN.AI.ApiKey("sk-xxx") _ .Stream(True) _ .Chat("写一首诗", Me, "OnStreamChunk") Private Sub OnStreamChunk(Chunk As String, IsComplete As Boolean) If IsComplete Then Debug.Print "完成" Else Debug.Print Chunk; End If End Sub ``` ### 多轮对话 ```vb VBMAN.AI.ApiKey("sk-xxx") VBMAN.AI.User("我喜欢编程").Chat() VBMAN.AI.User("推荐学习资源").Chat() VBMAN.AI.ClearMessages().User("新话题").Chat() ``` ## 方法 ### 基础配置 | 方法 | 说明 | |------|------| | `ApiKey(Key)` | 设置 API 密钥 | | `BaseUrl(Url)` | 设置 API 基础 URL | | `ApiPath(Path)` | 设置 API 路径 | | `Model(Name)` | 设置模型名称 | | `Timeout(Seconds)` | 设置超时时间（秒） | ### 参数配置 | 方法 | 说明 | 默认值 | |------|------|--------| | `Temperature(Value)` | 温度 (0-2) | 1.0 | | `MaxTokens(Value)` | 最大 token 数 | 自动 | | `TopP(Value)` | Top-P 采样 | 1.0 | | `FrequencyPenalty(Value)` | 频率惩罚 | 0 | | `PresencePenalty(Value)` | 存在惩罚 | 0 | | `Stream(Enable)` | 启用流式响应 | False | | `Stop(Value)` | 停止序列 | 无 | ### 消息管理 | 方法 | 说明 | |------|------| | `System(Prompt)` | 设置系统提示词 | | `User(Content)` | 添加用户消息 | | `Assistant(Content)` | 添加助手消息 | | `ClearMessages()` | 清空消息历史 | | `Messages(MsgList)` | 设置消息列表 | ### 预设配置 | 方法 | 服务商 | |------|--------| | `Doubao(Key)` | 豆包 | | `DeepSeek(Key)` | DeepSeek | | `OpenAI(Key)` | OpenAI | | `Qwen(Key)` | 通义千问 | ### 高级配置 | 方法 | 说明 | |------|------| | `Header(Name, Value)` | 自定义请求头 | | `Proxy(Url)` | 代理地址 | | `Organization(Id)` | OpenAI 组织 ID | ### 执行 | 方法 | 说明 | |------|------| | `Chat([Msg], [Callback], [Method])` | 发送请求，返回完整响应 | | `ChatJson([Msg])` | 发送请求，返回 cJson 对象 | | `Reset()` | 重置所有配置 | ## 属性 | 属性 | 类型 | 说明 | |------|------|------| | `LastError` | String (只读) | 最后错误信息 | | `IsStreaming` | Boolean (只读) | 是否在流式请求中 | ## 事件 | 事件 | 说明 | |------|------| | `OnStreamChunk(Chunk, IsComplete)` | 流式数据块（需 WithEvents 声明） | | `OnComplete(Response)` | 请求完成 | | `OnError(ErrorMsg, ErrorCode)` | 错误事件 | ## 详细文档 * [完整方法参考](../ai/methods.md) * [属性参考](../ai/properties.md) * [事件参考](../ai/events.md) * [组件概述](../ai/overview.md) --- --- url: /zh/vbman/global/baidu.md --- # VBMAN.Baidu - 百度 API 接口对象 ## 概述 `VBMAN.Baidu` 预留用于封装百度 API 接口（如地图、语音识别、OCR、翻译等）。 ## 注意 **该类目前尚未实现具体功能**，仅作为占位符保留。 ## 未来计划 计划集成的百度 API： * 地理编码/逆地理编码 * 语音识别 * 文字识别 (OCR) * 翻译服务 ## 替代方案 如需使用百度 API，目前需要直接使用 HTTP 请求： ```vb ' 示例：使用 HttpClient 调用百度 API With VBMAN.HttpClient .SendGet "https://api.baidu.com/..." ' 处理响应... End With ``` --- --- url: /en/vbman/global/baidu.md --- # VBMAN.Baidu - Baidu API Interface Object ## Overview `VBMAN.Baidu` is reserved for encapsulating Baidu API interfaces (such as Maps, Speech Recognition, OCR, Translation, etc.). ## Note **This class is currently not implemented** and is only retained as a placeholder. ## Future Plans Planned Baidu API integrations: * Geocoding / Reverse Geocoding * Speech Recognition * Optical Character Recognition (OCR) * Translation Services ## Alternative Solution To use Baidu APIs, currently you need to make HTTP requests directly: ```vb ' Example: Using HttpClient to call Baidu API With VBMAN.HttpClient .SendGet "https://api.baidu.com/..." ' Process response... End With ``` --- --- url: /zh/vbman/global/cmd.md --- # VBMAN.Cmd - 命令行操作对象 ## 概述 `VBMAN.Cmd` 提供命令行操作功能。 ## 注意 **该类目前尚未实现具体功能**，仅作为占位符保留。如需执行命令行操作，请使用 VB6 内置的 `Shell` 函数或 `WScript.Shell` 对象。 ## 替代方案 ```vb ' 使用 Shell 函数 Dim result As Double result = Shell("notepad.exe", vbNormalFocus) ' 使用 WScript.Shell Dim ws As Object Set ws = CreateObject("WScript.Shell") ws.Run "cmd /c dir", 0, True ``` --- --- url: /en/vbman/global/cmd.md --- # VBMAN.Cmd - Command Line Operation Object ## Overview `VBMAN.Cmd` provides command line operation functionality. ## Note **This class is currently not implemented** and is only retained as a placeholder. To execute command line operations, please use VB6's built-in `Shell` function or the `WScript.Shell` object. ## Alternative Solution ```vb ' Using Shell function Dim result As Double result = Shell("notepad.exe", vbNormalFocus) ' Using WScript.Shell Dim ws As Object Set ws = CreateObject("WScript.Shell") ws.Run "cmd /c dir", 0, True ``` --- --- url: /zh/vbman/global/collection.md --- # VBMAN.Collection - 增强集合对象 ## 概述 `VBMAN.Collection` 提供了比 VB6 内置 Collection 更强大的功能，支持按键访问、存在性检查、Keys/Items 数组获取等，兼容 Dictionary 的常用操作。 ## 核心特性 * **键值对存储**: 支持使用 Key 访问元素 * **Dictionary 兼容**: 兼容常用 Dictionary 操作 * **存在性检查**: 支持检查 Key 是否存在 * **数组导出**: 支持导出 Keys 和 Items 数组 * **更新支持**: 支持更新已存在的元素 ## 属性 | 属性 | 类型 | 说明 | | ------------------ | ---------- | -------------------------- | | `Item(KeyOrIndex)` | Variant | 获取或设置元素（默认成员） | | `RawCollection` | Collection | 原始 Collection 对象 | | `Count` | Long | 元素数量（方法） | ## 方法 ### Add 添加元素 ```vb Public Sub Add(ByVal Item As Variant, Optional ByVal Key As String = "") ``` **参数**: * `Item` - 要添加的元素 * `Key` - 键名（可选，如果提供且已存在则替换） **示例**: ```vb ' 添加无键元素 VBMAN.Collection.Add "值1" ' 添加带键元素 VBMAN.Collection.Add "张三", "name" VBMAN.Collection.Add 25, "age" ' 添加对象 VBMAN.Collection.Add New cJson, "config" ``` ### Remove 删除元素 ```vb Public Sub Remove(ByVal KeyOrIndex As Variant) ``` **示例**: ```vb ' 通过 Key 删除 VBMAN.Collection.Remove "name" ' 通过索引删除（从1开始） VBMAN.Collection.Remove 1 ``` ### RemoveAll 清空所有元素 ```vb Public Sub RemoveAll() ``` **示例**: ```vb VBMAN.Collection.RemoveAll ``` ### Exists 检查 Key 是否存在 ```vb Public Function Exists(ByVal Key As String, Optional CompareCase As Boolean) As Boolean ``` **示例**: ```vb If VBMAN.Collection.Exists("name") Then Debug.Print VBMAN.Collection("name") End If ``` ### Update 更新已存在的元素 ```vb Public Function Update(ByVal Item As Variant, ByVal Key As String) As Boolean ``` **示例**: ```vb If VBMAN.Collection.Update("李四", "name") Then Debug.Print "更新成功" End If ``` ### Keys 返回所有 Key 的数组 ```vb Public Function Keys() As String() ``` **示例**: ```vb Dim keyArray() As String keyArray = VBMAN.Collection.Keys Dim i As Long For i = LBound(keyArray) To UBound(keyArray) Debug.Print keyArray(i) Next i ``` ### Items 返回所有 Value 的数组 ```vb Public Function Items() As Variant() ``` **示例**: ```vb Dim itemArray() As Variant itemArray = VBMAN.Collection.Items ``` ### KeyByIndex 通过索引获取 Key ```vb Public Function KeyByIndex(ByVal Index As Long) As String ``` **示例**: ```vb Dim key As String key = VBMAN.Collection.KeyByIndex(1) ``` ### Count 返回元素数量 ```vb Public Function Count() As Long ``` **示例**: ```vb Debug.Print "共有 " & VBMAN.Collection.Count & " 个元素" ``` ## 综合示例 ### 示例1: 基本操作 ```vb Private Sub BasicOperations() ' 清空 VBMAN.Collection.RemoveAll ' 添加数据 VBMAN.Collection.Add "张三", "name" VBMAN.Collection.Add 25, "age" VBMAN.Collection.Add "北京", "city" ' 访问数据 Debug.Print VBMAN.Collection("name") ' 张三 Debug.Print VBMAN.Collection("age") ' 25 ' 修改数据 VBMAN.Collection("age") = 26 ' 检查存在性 If VBMAN.Collection.Exists("name") Then Debug.Print "name 存在" End If ' 删除数据 VBMAN.Collection.Remove "city" End Sub ``` ### 示例2: 遍历集合 ```vb Private Sub IterateCollection() ' 方式1: 通过索引 Dim i As Long For i = 1 To VBMAN.Collection.Count Dim key As String key = VBMAN.Collection.KeyByIndex(i) If key <> "" Then Debug.Print key & " = " & VBMAN.Collection(key) End If Next i ' 方式2: 通过 Keys 数组 Dim keys() As String keys = VBMAN.Collection.Keys Dim k As Variant For Each k In keys Debug.Print k & " = " & VBMAN.Collection(CStr(k)) Next k End Sub ``` ### 示例3: 存储对象 ```vb Private Sub StoreObjects() Dim json1 As New cJson json1("id") = 1 json1("name") = "产品A" Dim json2 As New cJson json2("id") = 2 json2("name") = "产品B" ' 存储对象 VBMAN.Collection.Add json1, "product1" VBMAN.Collection.Add json2, "product2" ' 读取对象 Dim product As cJson Set product = VBMAN.Collection("product1") Debug.Print product("name") End Sub ``` ## 最佳实践 1. **键名规范**: 使用有意义的键名，建议使用驼峰或下划线命名 2. **存在性检查**: 访问前使用 Exists 检查键是否存在 3. **类型注意**: VB6 是弱类型，注意存储和读取时的类型转换 4. **对象释放**: 存储对象时，注意对象生命周期管理 --- --- url: /en/vbman/global/collection.md --- # VBMAN.Collection - Enhanced Collection Object ## Overview `VBMAN.Collection` provides more powerful functionality than VB6's built-in Collection, supporting key-based access, existence checks, Keys/Items array retrieval, etc., compatible with common Dictionary operations. ## Core Features * **Key-Value Pair Storage**: Supports accessing elements using Key * **Dictionary Compatible**: Compatible with common Dictionary operations * **Existence Check**: Supports checking if a Key exists * **Array Export**: Supports exporting Keys and Items arrays * **Update Support**: Supports updating existing elements ## Properties | Property | Type | Description | | ------------------ | ---------- | ----------------------------------- | | `Item(KeyOrIndex)` | Variant | Get or set element (default member) | | `RawCollection` | Collection | Raw Collection object | | `Count` | Long | Number of elements (method) | ## Methods ### Add Add element ```vb Public Sub Add(ByVal Item As Variant, Optional ByVal Key As String = "") ``` **Parameters**: * `Item` - Element to add * `Key` - Key name (optional, if provided and already exists, it will be replaced) **Example**: ```vb ' Add element without key VBMAN.Collection.Add "Value1" ' Add element with key VBMAN.Collection.Add "Zhang San", "name" VBMAN.Collection.Add 25, "age" ' Add object VBMAN.Collection.Add New cJson, "config" ``` ### Remove Delete element ```vb Public Sub Remove(ByVal KeyOrIndex As Variant) ``` **Example**: ```vb ' Delete by Key VBMAN.Collection.Remove "name" ' Delete by index (starts from 1) VBMAN.Collection.Remove 1 ``` ### RemoveAll Clear all elements ```vb Public Sub RemoveAll() ``` **Example**: ```vb VBMAN.Collection.RemoveAll ``` ### Exists Check if Key exists ```vb Public Function Exists(ByVal Key As String, Optional CompareCase As Boolean) As Boolean ``` **Example**: ```vb If VBMAN.Collection.Exists("name") Then Debug.Print VBMAN.Collection("name") End If ``` ### Update Update existing element ```vb Public Function Update(ByVal Item As Variant, ByVal Key As String) As Boolean ``` **Example**: ```vb If VBMAN.ToolsDic.Update("Li Si", "name") Then Debug.Print "Update successful" End If ``` ### Keys Return array of all Keys ```vb Public Function Keys() As String() ``` **Example**: ```vb Dim keyArray() As String keyArray = VBMAN.Collection.Keys Dim i As Long For i = LBound(keyArray) To UBound(keyArray) Debug.Print keyArray(i) Next i ``` ### Items Return array of all Values ```vb Public Function Items() As Variant() ``` **Example**: ```vb Dim itemArray() As Variant itemArray = VBMAN.Collection.Items ``` ### KeyByIndex Get Key by index ```vb Public Function KeyByIndex(ByVal Index As Long) As String ``` **Example**: ```vb Dim key As String key = VBMAN.Collection.KeyByIndex(1) ``` ### Count Return number of elements ```vb Public Function Count() As Long ``` **Example**: ```vb Debug.Print "Total " & VBMAN.Collection.Count & " elements" ``` ## Comprehensive Examples ### Example 1: Basic Operations ```vb Private Sub BasicOperations() ' Clear VBMAN.Collection.RemoveAll ' Add data VBMAN.Collection.Add "Zhang San", "name" VBMAN.Collection.Add 25, "age" VBMAN.Collection.Add "Beijing", "city" ' Access data Debug.Print VBMAN.Collection("name") ' Zhang San Debug.Print VBMAN.Collection("age") ' 25 ' Modify data VBMAN.Collection("age") = 26 ' Check existence If VBMAN.Collection.Exists("name") Then Debug.Print "name exists" End If ' Delete data VBMAN.Collection.Remove "city" End Sub ``` ### Example 2: Iterate Collection ```vb Private Sub IterateCollection() ' Method 1: By index Dim i As Long For i = 1 To VBMAN.Collection.Count Dim key As String key = VBMAN.Collection.KeyByIndex(i) If key <> "" Then Debug.Print key & " = " & VBMAN.Collection(key) End If Next i ' Method 2: By Keys array Dim keys() As String keys = VBMAN.Collection.Keys Dim k As Variant For Each k In keys Debug.Print k & " = " & VBMAN.Collection(CStr(k)) Next k End Sub ``` ### Example 3: Store Objects ```vb Private Sub StoreObjects() Dim json1 As New cJson json1("id") = 1 json1("name") = "Product A" Dim json2 As New cJson json2("id") = 2 json2("name") = "Product B" ' Store objects VBMAN.Collection.Add json1, "product1" VBMAN.Collection.Add json2, "product2" ' Read objects Dim product As cJson Set product = VBMAN.Collection("product1") Debug.Print product("name") End Sub ``` ## Best Practices 1. **Key Naming Convention**: Use meaningful key names, recommend camelCase or snake\_case naming 2. **Existence Check**: Use Exists to check if key exists before accessing 3. **Type Awareness**: VB6 is weakly typed, pay attention to type conversion when storing and reading 4. **Object Release**: When storing objects, pay attention to object lifecycle management --- --- url: /zh/vbman/global/csv.md --- # VBMAN.Csv - CSV 文件操作对象 ## 概述 `VBMAN.Csv` 提供了强大的 CSV 文件读写功能，支持从文件加载、保存到文件、与数据库记录集交互，以及直接在 ListView 中显示数据。 ## 核心特性 * **自动编码识别**: 支持 UTF-8、ANSI 等多种编码 * **标准 CSV 解析**: 正确处理逗号、引号、换行等特殊字符 * **数据绑定**: 直接绑定到 ListView 控件显示 * **进度事件**: 大文件处理支持进度反馈 * **链式调用**: 流畅的 API 设计 ## 属性 | 属性 | 类型 | 说明 | | ----------------------- | ---------- | --------------------------- | | `Data` | Dictionary | CSV 数据字典（行号→行数据） | | `CurrentLineDic` | Dictionary | 当前行数据字典 | | `CurrentLineNumber` | Long | 当前行号 | | `Delimiter` | String | 分隔符（默认逗号） | | `LastError` | String | 最后错误信息 | | `HasHeadTitle` | Boolean | 是否有标题行 | | `HeadTitle` | Dictionary | 标题字典 | | `HeadTitleWidth` | Dictionary | 列宽字典 | | `HeadTitleWidthDefault` | Long | 默认列宽（默认1500） | | `HeadTitleWidthMax` | Long | 最大列宽（默认8000） | | `HeadTitleWidthAuto` | Boolean | 是否自动调整列宽 | | `IsFirstLineToHead` | Boolean | 首行是否作为标题 | ## 方法 ### 数据操作 #### NewLine 添加新行数据 ```vb Public Function NewLine(ParamArray FieldsData() As Variant) As Boolean ``` **示例**: ```vb ' 添加单行数据 VBMAN.Csv.NewLine "张三", "25", "北京" VBMAN.Csv.NewLine "李四", "30", "上海" ' 从字典添加 Dim rowData As New Dictionary rowData(1) = "王五" rowData(2) = "28" rowData(3) = "广州" VBMAN.Csv.NewLine rowData ``` #### NewColumn 添加新列 ```vb Public Function NewColumn(ByVal Title As String, Optional Width As Long, Optional Content As String) As Boolean ``` **示例**: ```vb ' 添加新列 VBMAN.Csv.NewColumn "年龄", 1000, "0" VBMAN.Csv.NewColumn "城市" ``` #### GetLine / SetLine 获取/设置行数据 ```vb Public Function GetLine(ByVal LineNumber As Long, Optional ByRef LineDic As Dictionary) As Boolean Public Function SetLine(ByVal LineNumber As Long, ByRef LineDic As Dictionary) As Boolean ``` **示例**: ```vb ' 获取第2行数据 Dim rowDic As Dictionary If VBMAN.Csv.GetLine(2, rowDic) Then Debug.Print rowDic(1) ' 第一列数据 Debug.Print rowDic(2) ' 第二列数据 End If ' 修改第2行数据 rowDic(2) = "新值" VBMAN.Csv.SetLine 2, rowDic ``` #### Value 属性 直接访问单元格值 ```vb ' 读取 Dim val As Variant val = VBMAN.Csv.Value(2, 3) ' 第2行第3列 ' 写入 VBMAN.Csv.Value(2, 3) = "新值" ``` ### 文件操作 #### LoadFrom 从文件加载 CSV ```vb Public Function LoadFrom(ByVal FilePath As String, Optional IsFirstHead As Boolean = True, Optional CharSet As String = "UTF-8") As cCsv ``` **参数**: * `FilePath` - 文件路径 * `IsFirstHead` - 首行是否作为标题（默认True） * `CharSet` - 字符编码（默认UTF-8） **示例**: ```vb ' 基本加载 If VBMAN.Csv.LoadFrom("C:\\data.csv") Then Debug.Print "加载成功，共 " & VBMAN.Csv.Data.Count & " 行" Else Debug.Print "加载失败: " & VBMAN.Csv.LastError End If ' 链式调用 With VBMAN.Csv .LoadFrom("C:\\data.csv") Debug.Print .CountLine & " 行, " & .CountColumn & " 列" End With ``` #### SaveTo 保存到文件 ```vb Public Function SaveTo(ByVal FilePath As String, Optional CharSet As String = "UTF-8") As Boolean ``` **示例**: ```vb ' 保存到文件 If VBMAN.Csv.SaveTo("C:\\output.csv") Then Debug.Print "保存成功" Else Debug.Print "保存失败: " & VBMAN.Csv.LastError End If ``` ### 数据库交互 #### LoadFromRecordSet 从 ADODB.Recordset 加载 ```vb Public Function LoadFromRecordSet(ByVal Rs As Object, Optional IsFirstHead As Boolean = True) As cCsv ``` **示例**: ```vb ' 从记录集加载 Dim rs As ADODB.Recordset Set rs = New ADODB.Recordset rs.Open "SELECT * FROM users", conn VBMAN.Csv.LoadFromRecordSet rs, True rs.Close ``` #### SaveFromRecordSet 直接将记录集保存为 CSV 文件 ```vb Public Function SaveFromRecordSet(ByVal Rs As Object, ByVal SaveToFilePath As String, Optional IncludeFieldNames As Boolean = True) As Boolean ``` **示例**: ```vb ' 直接将查询结果导出为 CSV Dim rs As ADODB.Recordset Set rs = conn.Execute("SELECT * FROM users") VBMAN.Csv.SaveFromRecordSet rs, "C:\\users.csv", True ``` ### 界面显示 #### ShowTo 显示到 ListView 控件 ```vb Public Function ShowTo(Lv As Object, Optional DefaultWidth As Long = 800) As Boolean ``` **示例**: ```vb ' 显示到 ListView Private Sub LoadCsvToListView() ' 加载 CSV 文件 VBMAN.Csv.LoadFrom "C:\\data.csv" ' 显示到 ListView1 VBMAN.Csv.ShowTo ListView1, 1000 End Sub ``` ### 其他方法 | 方法 | 说明 | | ---------------------------------------------- | ------------------------- | | `Reset(Optional OnlyData As Boolean)` | 重置对象状态 | | `StopLoop()` | 中断加载/保存操作 | | `CanStop()` | 启用可中断模式（返回 Me） | | `DeleteColumn(Optional ColumnNumber As Long)` | 删除列 | | `SetHeadTitleWidth(ColumnNumber, ColumnWidth)` | 设置列宽 | | `CountLine` | 返回行数（Property Get） | | `CountColumn` | 返回列数（Property Get） | ## 事件 ```vb ' 进度事件 Public Event Progress(ByVal Operation As CsvOperationType, ByVal CurrentLine As Long, ByVal TotalLines As Long, ByVal Percent As String, LineDataArray As Variant) ' 完成事件 Public Event Complete(ByVal Operation As CsvOperationType, ByVal TotalLines As Long, ByVal Success As Boolean) ``` **操作类型枚举**: ```vb Public Enum CsvOperationType OperationNone = 0 OperationLoadFrom = 1 OperationLoadFromRecordSet = 2 OperationSaveTo = 3 OperationSaveFromRecordSet = 4 End Enum ``` **事件使用示例**: ```vb ' 需要声明带事件的变量 Private WithEvents mCsv As cCsv Private Sub Form_Load() Set mCsv = VBMAN.Csv End Sub Private Sub mCsv_Progress(ByVal Operation As CsvOperationType, ByVal CurrentLine As Long, ByVal TotalLines As Long, ByVal Percent As String, LineDataArray As Variant) ProgressBar1.Value = CLng(Replace(Percent, "%", "")) DoEvents End Sub Private Sub mCsv_Complete(ByVal Operation As CsvOperationType, ByVal TotalLines As Long, ByVal Success As Boolean) If Success Then MsgBox "处理完成，共 " & TotalLines & " 行" Else MsgBox "处理失败" End If End Sub ``` ## 综合示例 ### 示例1: 创建并保存 CSV ```vb Private Sub CreateCsv() ' 重置 VBMAN.Csv.Reset ' 添加标题行 VBMAN.Csv.NewLine "姓名", "年龄", "城市" ' 添加数据行 VBMAN.Csv.NewLine "张三", "25", "北京" VBMAN.Csv.NewLine "李四", "30", "上海" VBMAN.Csv.NewLine "王五", "28", "广州" ' 保存 If VBMAN.Csv.SaveTo("C:\\users.csv") Then MsgBox "CSV 创建成功！" End If End Sub ``` ### 示例2: 读取并修改 CSV ```vb Private Sub ModifyCsv() ' 加载文件 If Not VBMAN.Csv.LoadFrom("C:\\users.csv") Then MsgBox "加载失败: " & VBMAN.Csv.LastError Exit Sub End If ' 遍历所有行 Dim i As Long For i = 1 To VBMAN.Csv.CountLine Dim rowDic As Dictionary If VBMAN.Csv.GetLine(i, rowDic) Then ' 修改年龄列（第2列） If i > 1 Then ' 跳过标题行 rowDic(2) = CInt(rowDic(2)) + 1 ' 年龄加1 VBMAN.Csv.SetLine i, rowDic End If End If Next i ' 保存修改 VBMAN.Csv.SaveTo "C:\\users.csv" End Sub ``` ### 示例3: 数据库导出到 CSV ```vb Private Sub ExportToCsv() Dim conn As ADODB.Connection Set conn = New ADODB.Connection conn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=C:\\data.mdb" Dim rs As ADODB.Recordset Set rs = New ADODB.Recordset rs.Open "SELECT * FROM orders WHERE date >= #2024-01-01#", conn ' 导出到 CSV If VBMAN.Csv.SaveFromRecordSet(rs, "C:\\orders_2024.csv", True) Then MsgBox "导出成功！" Else MsgBox "导出失败: " & VBMAN.Csv.LastError End If rs.Close conn.Close End Sub ``` ### 示例4: 大文件处理（带进度条） ```vb Private WithEvents mCsv As cCsv Private Sub LoadLargeFile() Set mCsv = VBMAN.Csv ' 启用中断支持 mCsv.CanStop.LoadFrom "C:\\large_file.csv" End Sub Private Sub mCsv_Progress(ByVal Operation As CsvOperationType, ByVal CurrentLine As Long, ByVal TotalLines As Long, ByVal Percent As String, LineDataArray As Variant) ProgressBar1.Max = 100 ProgressBar1.Value = CLng(Replace(Percent, "%", "")) Label1.Caption = "已处理: " & CurrentLine & " / " & TotalLines DoEvents End Sub Private Sub CommandCancel_Click() mCsv.StopLoop ' 取消操作 End Sub ``` ## 最佳实践 1. **始终检查 LastError**: 文件操作可能失败，建议检查错误信息 2. **使用链式调用**: 充分利用链式调用使代码更简洁 3. **大数据量使用事件**: 处理大文件时使用进度事件避免界面卡死 4. **正确编码**: 根据实际文件编码指定 CharSet 参数 5. **及时 Reset**: 重复使用对象时先调用 Reset 清除旧数据 --- --- url: /en/vbman/global/csv.md --- # VBMAN.Csv - CSV File Operation Object ## Overview `VBMAN.Csv` provides powerful CSV file read/write functionality, supporting loading from files, saving to files, interacting with database recordsets, and directly displaying data in ListView. ## Core Features * **Automatic Encoding Recognition**: Supports UTF-8, ANSI, and other encodings * **Standard CSV Parsing**: Correctly handles commas, quotes, newlines, and other special characters * **Data Binding**: Directly bind to ListView control for display * **Progress Events**: Large file processing supports progress feedback * **Chain Calling**: Fluent API design ## Properties | Property | Type | Description | | ----------------------- | ---------- | ------------------------------------------- | | `Data` | Dictionary | CSV data dictionary (row number → row data) | | `CurrentLineDic` | Dictionary | Current row data dictionary | | `CurrentLineNumber` | Long | Current row number | | `Delimiter` | String | Delimiter (default comma) | | `LastError` | String | Last error message | | `HasHeadTitle` | Boolean | Whether there is a header row | | `HeadTitle` | Dictionary | Header dictionary | | `HeadTitleWidth` | Dictionary | Column width dictionary | | `HeadTitleWidthDefault` | Long | Default column width (default 1500) | | `HeadTitleWidthMax` | Long | Maximum column width (default 8000) | | `HeadTitleWidthAuto` | Boolean | Whether to auto-adjust column width | | `IsFirstLineToHead` | Boolean | Whether first row is header | ## Methods ### Data Operations #### NewLine Add new row data ```vb Public Function NewLine(ParamArray FieldsData() As Variant) As Boolean ``` **Example**: ```vb ' Add single row data VBMAN.Csv.NewLine "Zhang San", "25", "Beijing" VBMAN.Csv.NewLine "Li Si", "30", "Shanghai" ' Add from dictionary Dim rowData As New Dictionary rowData(1) = "Wang Wu" rowData(2) = "28" rowData(3) = "Guangzhou" VBMAN.Csv.NewLine rowData ``` #### NewColumn Add new column ```vb Public Function NewColumn(ByVal Title As String, Optional Width As Long, Optional Content As String) As Boolean ``` **Example**: ```vb ' Add new columns VBMAN.Csv.NewColumn "Age", 1000, "0" VBMAN.Csv.NewColumn "City" ``` #### GetLine / SetLine Get/set row data ```vb Public Function GetLine(ByVal LineNumber As Long, Optional ByRef LineDic As Dictionary) As Boolean Public Function SetLine(ByVal LineNumber As Long, ByRef LineDic As Dictionary) As Boolean ``` **Example**: ```vb ' Get row 2 data Dim rowDic As Dictionary If VBMAN.Csv.GetLine(2, rowDic) Then Debug.Print rowDic(1) ' First column data Debug.Print rowDic(2) ' Second column data End If ' Modify row 2 data rowDic(2) = "New Value" VBMAN.Csv.SetLine 2, rowDic ``` #### Value Property Direct cell value access ```vb ' Read Dim val As Variant val = VBMAN.Csv.Value(2, 3) ' Row 2, Column 3 ' Write VBMAN.Csv.Value(2, 3) = "New Value" ``` ### File Operations #### LoadFrom Load CSV from file ```vb Public Function LoadFrom(ByVal FilePath As String, Optional IsFirstHead As Boolean = True, Optional CharSet As String = "UTF-8") As cCsv ``` **Parameters**: * `FilePath` - File path * `IsFirstHead` - Whether first row is header (default True) * `CharSet` - Character encoding (default UTF-8) **Example**: ```vb ' Basic loading If VBMAN.Csv.LoadFrom("C:\\data.csv") Then Debug.Print "Load successful, total " & VBMAN.Csv.Data.Count & " rows" Else Debug.Print "Load failed: " & VBMAN.Csv.LastError End If ' Chain calling With VBMAN.Csv .LoadFrom("C:\\data.csv") Debug.Print .CountLine & " rows, " & .CountColumn & " columns" End With ``` #### SaveTo Save to file ```vb Public Function SaveTo(ByVal FilePath As String, Optional CharSet As String = "UTF-8") As Boolean ``` **Example**: ```vb ' Save to file If VBMAN.Csv.SaveTo("C:\\output.csv") Then Debug.Print "Save successful" Else Debug.Print "Save failed: " & VBMAN.Csv.LastError End If ``` ### Database Interaction #### LoadFromRecordSet Load from ADODB.Recordset ```vb Public Function LoadFromRecordSet(ByVal Rs As Object, Optional IsFirstHead As Boolean = True) As cCsv ``` **Example**: ```vb ' Load from recordset Dim rs As ADODB.Recordset Set rs = New ADODB.Recordset rs.Open "SELECT * FROM users", conn VBMAN.Csv.LoadFromRecordSet rs, True rs.Close ``` #### SaveFromRecordSet Directly save recordset as CSV file ```vb Public Function SaveFromRecordSet(ByVal Rs As Object, ByVal SaveToFilePath As String, Optional IncludeFieldNames As Boolean = True) As Boolean ``` **Example**: ```vb ' Directly export query results to CSV Dim rs As ADODB.Recordset Set rs = conn.Execute("SELECT * FROM users") VBMAN.Csv.SaveFromRecordSet rs, "C:\\users.csv", True ``` ### UI Display #### ShowTo Display to ListView control ```vb Public Function ShowTo(Lv As Object, Optional DefaultWidth As Long = 800) As Boolean ``` **Example**: ```vb ' Display to ListView Private Sub LoadCsvToListView() ' Load CSV file VBMAN.Csv.LoadFrom "C:\\data.csv" ' Display to ListView1 VBMAN.Csv.ShowTo ListView1, 1000 End Sub ``` ### Other Methods | Method | Description | | ---------------------------------------------- | -------------------------------------- | | `Reset(Optional OnlyData As Boolean)` | Reset object state | | `StopLoop()` | Interrupt load/save operation | | `CanStop()` | Enable interruptible mode (returns Me) | | `DeleteColumn(Optional ColumnNumber As Long)` | Delete column | | `SetHeadTitleWidth(ColumnNumber, ColumnWidth)` | Set column width | | `CountLine` | Return row count (Property Get) | | `CountColumn` | Return column count (Property Get) | ## Events ```vb ' Progress event Public Event Progress(ByVal Operation As CsvOperationType, ByVal CurrentLine As Long, ByVal TotalLines As Long, ByVal Percent As String, LineDataArray As Variant) ' Complete event Public Event Complete(ByVal Operation As CsvOperationType, ByVal TotalLines As Long, ByVal Success As Boolean) ``` **Operation Type Enum**: ```vb Public Enum CsvOperationType OperationNone = 0 OperationLoadFrom = 1 OperationLoadFromRecordSet = 2 OperationSaveTo = 3 OperationSaveFromRecordSet = 4 End Enum ``` **Event Usage Example**: ```vb ' Need to declare variable with events Private WithEvents mCsv As cCsv Private Sub Form_Load() Set mCsv = VBMAN.Csv End Sub Private Sub mCsv_Progress(ByVal Operation As CsvOperationType, ByVal CurrentLine As Long, ByVal TotalLines As Long, ByVal Percent As String, LineDataArray As Variant) ProgressBar1.Value = CLng(Replace(Percent, "%", "")) DoEvents End Sub Private Sub mCsv_Complete(ByVal Operation As CsvOperationType, ByVal TotalLines As Long, ByVal Success As Boolean) If Success Then MsgBox "Processing complete, total " & TotalLines & " rows" Else MsgBox "Processing failed" End If End Sub ``` ## Comprehensive Examples ### Example 1: Create and Save CSV ```vb Private Sub CreateCsv() ' Reset VBMAN.Csv.Reset ' Add header row VBMAN.Csv.NewLine "Name", "Age", "City" ' Add data rows VBMAN.Csv.NewLine "Zhang San", "25", "Beijing" VBMAN.Csv.NewLine "Li Si", "30", "Shanghai" VBMAN.Csv.NewLine "Wang Wu", "28", "Guangzhou" ' Save If VBMAN.Csv.SaveTo("C:\\users.csv") Then MsgBox "CSV created successfully!" End If End Sub ``` ### Example 2: Read and Modify CSV ```vb Private Sub ModifyCsv() ' Load file If Not VBMAN.Csv.LoadFrom("C:\\users.csv") Then MsgBox "Load failed: " & VBMAN.Csv.LastError Exit Sub End If ' Iterate all rows Dim i As Long For i = 1 To VBMAN.Csv.CountLine Dim rowDic As Dictionary If VBMAN.Csv.GetLine(i, rowDic) Then ' Modify age column (column 2) If i > 1 Then ' Skip header row rowDic(2) = CInt(rowDic(2)) + 1 ' Age + 1 VBMAN.Csv.SetLine i, rowDic End If End If Next i ' Save modifications VBMAN.Csv.SaveTo "C:\\users.csv" End Sub ``` ### Example 3: Database Export to CSV ```vb Private Sub ExportToCsv() Dim conn As ADODB.Connection Set conn = New ADODB.Connection conn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=C:\\data.mdb" Dim rs As ADODB.Recordset Set rs = New ADODB.Recordset rs.Open "SELECT * FROM orders WHERE date >= #2024-01-01#", conn ' Export to CSV If VBMAN.Csv.SaveFromRecordSet(rs, "C:\\orders_2024.csv", True) Then MsgBox "Export successful!" Else MsgBox "Export failed: " & VBMAN.Csv.LastError End If rs.Close conn.Close End Sub ``` ### Example 4: Large File Processing (with Progress Bar) ```vb Private WithEvents mCsv As cCsv Private Sub LoadLargeFile() Set mCsv = VBMAN.Csv ' Enable interrupt support mCsv.CanStop.LoadFrom "C:\\large_file.csv" End Sub Private Sub mCsv_Progress(ByVal Operation As CsvOperationType, ByVal CurrentLine As Long, ByVal TotalLines As Long, ByVal Percent As String, LineDataArray As Variant) ProgressBar1.Max = 100 ProgressBar1.Value = CLng(Replace(Percent, "%", "")) Label1.Caption = "Processed: " & CurrentLine & " / " & TotalLines DoEvents End Sub Private Sub CommandCancel_Click() mCsv.StopLoop ' Cancel operation End Sub ``` ## Best Practices 1. **Always Check LastError**: File operations may fail, check error messages 2. **Use Chain Calling**: Take full advantage of chain calling for cleaner code 3. **Use Events for Large Data**: Use progress events when processing large files to avoid UI freezing 4. **Correct Encoding**: Specify CharSet parameter according to actual file encoding 5. **Reset in Time**: Call Reset to clear old data when reusing the object --- --- url: /zh/vbman/global/database.md --- # VBMAN.Db - 数据库操作对象 ## 概述 `VBMAN.Db` 提供了数据库操作功能，封装了 ADO 数据库访问，支持参数化查询、事务处理、结果集操作等。 ## 核心特性 * **参数化查询**: 防止 SQL 注入攻击 * **链式调用**: 流畅的 SQL 构建 API * **链式 CURD**: 无需手写 SQL，链式构建增删改查（详见 [链式CURD概述](../database/chain-curd.md)，[条件方法](../database/chain-curd-where.md)，[终结方法](../database/chain-curd-terminal.md) 等） * **自动连接管理**: 连接池和自动开关连接 * **事务支持**: 完整的事务处理功能 * **结果集操作**: 便捷的数据访问方式 ## 主要方法 ### 链式 CURD 快速入门 无需手写 SQL，通过链式方法构建增删改查操作： ```vb ' 查询 - 读取一行 VBMAN.Db.Table("users").Where("id", 1).RowRead Debug.Print VBMAN.Db.Row("username") ' 查询 - 条件筛选 + 排序 + 分页 VBMAN.Db.Table("users").Where("status", "active").OrderByDesc("id").Page(1, 20).RowRead ' 新增 VBMAN.Db.Table("users").Field("username", "admin").Field("email", "a@test.com").RowCreate ' 更新 VBMAN.Db.Table("users").Where("id", 1).Field("email", "new@test.com").RowUpdate ' 删除 VBMAN.Db.Table("users").Where("id", 1).RowDelete ' 聚合查询 VBMAN.Db.Table("orders").Where("status", "paid").RowCount ' 计数 VBMAN.Db.Table("orders").Where("status", "paid").RowSum("amount") ' 求和 ``` > 完整链式 CURD 方法列表、用法和示例请参阅：[链式CURD概述](../database/chain-curd.md) → [条件方法](../database/chain-curd-where.md) / [终结方法](../database/chain-curd-terminal.md) / [综合示例](../database/chain-curd-examples.md) *** ### 连接管理 #### Connect 连接数据库 ```vb Public Function Connect(ByVal DbType As enumDbType, Optional ByVal DbAddress As String = "127.0.0.1,1433", Optional ByVal username As String = "sa", Optional ByVal Password As String = "Sa123456", Optional ByVal DefaultDataBase As String = "master") As Boolean ``` **参数**: * `DbType` - 数据库类型 (Access=1, Mysql=2, MsSql=3, Csv=4, Custom=5) * `DbAddress` - 服务器地址和端口 * `username` - 用户名 * `Password` - 密码 * `DefaultDataBase` - 默认数据库 **示例**: ```vb ' 连接 SQL Server If VBMAN.Db.Connect(MsSql, "192.168.1.100,1433", "sa", "password", "mydb") Then MsgBox "连接成功" Else MsgBox "连接失败: " & VBMAN.Db.LastErr End If ' 连接 Access VBMAN.Db.Connect Access, "C:\\data.mdb" ``` #### DisConnect 断开连接 ```vb Public Function DisConnect() As Boolean ``` ### SQL 执行 #### Sql 设置 SQL 语句（链式调用起点） ```vb Public Function Sql(sqlText As String) As cDataBase ``` **示例**: ```vb VBMAN.Db.Sql("SELECT * FROM users WHERE id=1") ``` #### Param 添加参数 ```vb Public Function Param(paramName As String, paramValue As Variant) As cDataBase ``` **示例**: ```vb VBMAN.Db.Sql("SELECT * FROM users WHERE id=? AND status=?").Param("id", 1).Param("status", "active") ``` #### Fetch / FetchParam 执行查询 ```vb Public Function Fetch() As cDataBase Public Function FetchParam() As cDataBase ``` **示例**: ```vb ' 简单查询 VBMAN.Db.Sql("SELECT * FROM users WHERE id=1").Fetch Debug.Print VBMAN.Db.Row("username") ' 参数化查询 VBMAN.Db.Sql("SELECT * FROM users WHERE id=? AND age>?").Param("id", 1).Param("age", 18).FetchParam Debug.Print VBMAN.Db.Row("username") ``` #### Exec / ExecParam 执行非查询语句 ```vb Public Function Exec() As cDataBase Public Function ExecParam() As cDataBase ``` **示例**: ```vb ' 插入数据 VBMAN.Db.Sql("INSERT INTO users (username, email) VALUES ('admin', 'admin@test.com')").Exec ' 参数化插入 VBMAN.Db.Sql("INSERT INTO users (username, email) VALUES (?, ?)").Param("username", "admin").Param("email", "admin@test.com").ExecParam ' 更新数据 VBMAN.Db.Sql("UPDATE users SET last_login=? WHERE id=?").Param("last_login", Now).Param("id", 1).ExecParam ' 删除数据 VBMAN.Db.Sql("DELETE FROM users WHERE id=?").Param("id", 1).ExecParam ``` ### 事务处理 ```vb ' 开始事务 VBMAN.Db.TransBegin On Error GoTo Rollback ' 执行多个操作 VBMAN.Db.Sql("INSERT INTO orders (user_id, total) VALUES (?, ?)").Param("user_id", 1).Param("total", 100).ExecParam ' 提交事务 VBMAN.Db.TransCommit Exit Sub Rollback: VBMAN.Db.TransRollback MsgBox "操作失败: " & Err.Description ``` ### 结果集访问 #### Row 访问当前行数据（Dictionary） ```vb ' 访问字段 Dim username As String username = VBMAN.Db.Row("username") ' 检查字段是否存在 If VBMAN.Db.Row.Exists("email") Then Debug.Print VBMAN.Db.Row("email") End If ``` #### Rs 原始 ADODB.Recordset 对象 ```vb Do While Not VBMAN.Db.Rs.EOF Debug.Print VBMAN.Db.Rs("username") VBMAN.Db.Rs.MoveNext Loop ``` ### 分页查询 ```vb VBMAN.Db.Sql("SELECT * FROM users").Page(2, 10).Fetch ``` ## 综合示例 ### 示例1: 用户 CRUD 操作 ```vb ' 创建用户 Private Sub CreateUser(username As String, email As String) VBMAN.Db.Sql("INSERT INTO users (username, email, created_at) VALUES (?, ?, ?)"). _ Param("username", username). _ Param("email", email). _ Param("created_at", Now). _ ExecParam MsgBox "用户创建成功！" End Sub ' 读取用户 Private Sub LoadUser(userId As Long) VBMAN.Db.Sql("SELECT * FROM users WHERE id=?").Param("id", userId).FetchParam If VBMAN.Db.Row.Count > 0 Then TextUsername.Text = VBMAN.Db.Row("username") TextEmail.Text = VBMAN.Db.Row("email") Else MsgBox "用户不存在！" End If End Sub ' 更新用户 Private Sub UpdateUser(userId As Long, email As String) VBMAN.Db.Sql("UPDATE users SET email=?, updated_at=? WHERE id=?"). _ Param("email", email). _ Param("updated_at", Now). _ Param("id", userId). _ ExecParam MsgBox "更新成功" End Sub ' 删除用户 Private Sub DeleteUser(userId As Long) VBMAN.Db.Sql("DELETE FROM users WHERE id=?").Param("id", userId).ExecParam MsgBox "删除成功" End Sub ``` ### 示例2: 分页查询 ```vb Private Sub LoadUserList(page As Integer, pageSize As Integer) ' 查询数据 VBMAN.Db.Sql("SELECT * FROM users ORDER BY id DESC"). _ Page(page, pageSize). _ Fetch ' 绑定到列表 ListView1.ListItems.Clear Do While Not VBMAN.Db.Rs.EOF With ListView1.ListItems.Add(, , VBMAN.Db.Rs("id")) .SubItems(1) = VBMAN.Db.Rs("username") .SubItems(2) = VBMAN.Db.Rs("email") End With VBMAN.Db.Rs.MoveNext Loop End Sub ``` ## 最佳实践 1. **使用参数化查询**: 始终使用 Param 方法，防止 SQL 注入 2. **及时断开连接**: 操作完成后调用 DisConnect 3. **错误处理**: 添加 On Error 处理数据库异常 4. **事务使用**: 多表操作使用事务保证数据一致性 5. **连接字符串安全**: 不要在代码中硬编码密码 ## 数据库文档导航 | 文档 | 说明 | | ---------------------------------------------------------- | ------------------------------------- | | [快速入门](../database/quickstart.md) | 5 分钟上手数据库操作 | | [连接管理](../database/connection.md) | 数据库连接配置 | | [参数化查询](../database/parameterized.md) | 防止 SQL 注入 | | [链式 CURD - 概述](../database/chain-curd.md) | 链式查询构建器概述与速查表 | | [链式 CURD - 条件方法](../database/chain-curd-where.md) | Where/OrWhere/WhereIn 等 | | [链式 CURD - 终结方法](../database/chain-curd-terminal.md) | RowCreate/RowRead/RowUpdate/RowDelete | | [链式 CURD - 综合示例](../database/chain-curd-examples.md) | SQL对比、FAQ、最佳实践 | | [分页查询](../database/pagination.md) | 大数据量分页方案 | | [事务处理](../database/transaction.md) | 事务与数据一致性 | | [高级功能](../database/advanced.md) | 批量操作、多结果集等 | | [工具函数](../database/utilities.md) | 辅助工具方法 | --- --- url: /en/vbman/global/database.md --- # VBMAN.Db - Database Operation Object ## Overview `VBMAN.Db` provides database operation functionality, encapsulating ADO database access, supporting parameterized queries, transaction processing, result set operations, etc. ## Core Features * **Parameterized Queries**: Prevents SQL injection attacks * **Chain Calling**: Fluent SQL building API * **Chained CRUD**: No need to write SQL, chain-construct CRUD operations (see [Overview](../database/chain-curd.md), [Condition Methods](../database/chain-curd-where.md), [Terminal Methods](../database/chain-curd-terminal.md) etc.) * **Automatic Connection Management**: Connection pooling and automatic open/close * **Transaction Support**: Complete transaction processing functionality * **Result Set Operations**: Convenient data access methods ## Main Methods ### Chained CRUD Quick Start No need to write SQL, build CRUD operations through chained methods: ```vb ' Query - read one row VBMAN.Db.Table("users").Where("id", 1).RowRead Debug.Print VBMAN.Db.Row("username") ' Query - filter + sort + pagination VBMAN.Db.Table("users").Where("status", "active").OrderByDesc("id").Page(1, 20).RowRead ' Create VBMAN.Db.Table("users").Field("username", "admin").Field("email", "a@test.com").RowCreate ' Update VBMAN.Db.Table("users").Where("id", 1).Field("email", "new@test.com").RowUpdate ' Delete VBMAN.Db.Table("users").Where("id", 1).RowDelete ' Aggregate query VBMAN.Db.Table("orders").Where("status", "paid").RowCount ' Count VBMAN.Db.Table("orders").Where("status", "paid").RowSum("amount") ' Sum ``` > For complete chained CRUD method list, usage, and examples, see: [Overview](../database/chain-curd.md) → [Condition Methods](../database/chain-curd-where.md) / [Terminal Methods](../database/chain-curd-terminal.md) / [Examples](../database/chain-curd-examples.md) *** ### Connection Management #### Connect Connect to database ```vb Public Function Connect(ByVal DbType As enumDbType, Optional ByVal DbAddress As String = "127.0.0.1,1433", Optional ByVal username As String = "sa", Optional ByVal Password As String = "Sa123456", Optional ByVal DefaultDataBase As String = "master") As Boolean ``` **Parameters**: * `DbType` - Database type (Access=1, Mysql=2, MsSql=3, Csv=4, Custom=5) * `DbAddress` - Server address and port * `username` - Username * `Password` - Password * `DefaultDataBase` - Default database **Example**: ```vb ' Connect to SQL Server If VBMAN.Db.Connect(MsSql, "192.168.1.100,1433", "sa", "password", "mydb") Then MsgBox "Connection successful" Else MsgBox "Connection failed: " & VBMAN.Db.LastErr End If ' Connect to Access VBMAN.Db.Connect Access, "C:\\data.mdb" ``` #### DisConnect Disconnect ```vb Public Function DisConnect() As Boolean ``` ### SQL Execution #### Sql Set SQL statement (starting point for chain calling) ```vb Public Function Sql(sqlText As String) As cDataBase ``` **Example**: ```vb VBMAN.Db.Sql("SELECT * FROM users WHERE id=1") ``` #### Param Add parameter ```vb Public Function Param(paramName As String, paramValue As Variant) As cDataBase ``` **Example**: ```vb VBMAN.Db.Sql("SELECT * FROM users WHERE id=? AND status=?").Param("id", 1).Param("status", "active") ``` #### Fetch / FetchParam Execute query ```vb Public Function Fetch() As cDataBase Public Function FetchParam() As cDataBase ``` **Example**: ```vb ' Simple query VBMAN.Db.Sql("SELECT * FROM users WHERE id=1").Fetch Debug.Print VBMAN.Db.Row("username") ' Parameterized query VBMAN.Db.Sql("SELECT * FROM users WHERE id=? AND age>?").Param("id", 1).Param("age", 18).FetchParam Debug.Print VBMAN.Db.Row("username") ``` #### Exec / ExecParam Execute non-query statements ```vb Public Function Exec() As cDataBase Public Function ExecParam() As cDataBase ``` **Example**: ```vb ' Insert data VBMAN.Db.Sql("INSERT INTO users (username, email) VALUES ('admin', 'admin@test.com')").Exec ' Parameterized insert VBMAN.Db.Sql("INSERT INTO users (username, email) VALUES (?, ?)").Param("username", "admin").Param("email", "admin@test.com").ExecParam ' Update data VBMAN.Db.Sql("UPDATE users SET last_login=? WHERE id=?").Param("last_login", Now).Param("id", 1).ExecParam ' Delete data VBMAN.Db.Sql("DELETE FROM users WHERE id=?").Param("id", 1).ExecParam ``` ### Transaction Processing ```vb ' Begin transaction VBMAN.Db.TransBegin On Error GoTo Rollback ' Execute multiple operations VBMAN.Db.Sql("INSERT INTO orders (user_id, total) VALUES (?, ?)").Param("user_id", 1).Param("total", 100).ExecParam ' Commit transaction VBMAN.Db.TransCommit Exit Sub Rollback: VBMAN.Db.TransRollback MsgBox "Operation failed: " & Err.Description ``` ### Result Set Access #### Row Access current row data (Dictionary) ```vb ' Access field Dim username As String username = VBMAN.Db.Row("username") ' Check if field exists If VBMAN.Db.Row.Exists("email") Then Debug.Print VBMAN.Db.Row("email") End If ``` #### Rs Raw ADODB.Recordset object ```vb Do While Not VBMAN.Db.Rs.EOF Debug.Print VBMAN.Db.Rs("username") VBMAN.Db.Rs.MoveNext Loop ``` ### Paged Query ```vb VBMAN.Db.Sql("SELECT * FROM users").Page(2, 10).Fetch ``` ## Comprehensive Examples ### Example 1: User CRUD Operations ```vb ' Create user Private Sub CreateUser(username As String, email As String) VBMAN.Db.Sql("INSERT INTO users (username, email, created_at) VALUES (?, ?, ?)"). _ Param("username", username). _ Param("email", email). _ Param("created_at", Now). _ ExecParam MsgBox "User created successfully!" End Sub ' Read user Private Sub LoadUser(userId As Long) VBMAN.Db.Sql("SELECT * FROM users WHERE id=?").Param("id", userId).FetchParam If VBMAN.Db.Row.Count > 0 Then TextUsername.Text = VBMAN.Db.Row("username") TextEmail.Text = VBMAN.Db.Row("email") Else MsgBox "User does not exist!" End If End Sub ' Update user Private Sub UpdateUser(userId As Long, email As String) VBMAN.Db.Sql("UPDATE users SET email=?, updated_at=? WHERE id=?"). _ Param("email", email). _ Param("updated_at", Now). _ Param("id", userId). _ ExecParam MsgBox "Update successful" End Sub ' Delete user Private Sub DeleteUser(userId As Long) VBMAN.Db.Sql("DELETE FROM users WHERE id=?").Param("id", userId).ExecParam MsgBox "Delete successful" End Sub ``` ### Example 2: Paged Query ```vb Private Sub LoadUserList(page As Integer, pageSize As Integer) ' Query data VBMAN.Db.Sql("SELECT * FROM users ORDER BY id DESC"). _ Page(page, pageSize). _ Fetch ' Bind to list ListView1.ListItems.Clear Do While Not VBMAN.Db.Rs.EOF With ListView1.ListItems.Add(, , VBMAN.Db.Rs("id")) .SubItems(1) = VBMAN.Db.Rs("username") .SubItems(2) = VBMAN.Db.Rs("email") End With VBMAN.Db.Rs.MoveNext Loop End Sub ``` ## Database Documentation Navigation | Document | Description | | --------------------------------------------------------------------- | ------------------------------------------------- | | [Quick Start](../database/quickstart.md) | 5 minutes to get started with database operations | | [Connection Management](../database/connection.md) | Database connection configuration | | [Parameterized Queries](../database/parameterized.md) | Prevent SQL injection | | [Chained CRUD - Overview](../database/chain-curd.md) | Overview & quick reference | | [Chained CRUD - Condition Methods](../database/chain-curd-where.md) | Where/OrWhere/WhereIn etc. | | [Chained CRUD - Terminal Methods](../database/chain-curd-terminal.md) | RowCreate/RowRead/RowUpdate/RowDelete | | [Chained CRUD - Examples](../database/chain-curd-examples.md) | SQL comparison, FAQ, best practices | | [Pagination](../database/pagination.md) | Large data pagination solution | | [Transaction Processing](../database/transaction.md) | Transactions and data consistency | | [Advanced Features](../database/advanced.md) | Batch operations, multi-result sets, etc. | | [Utility Functions](../database/utilities.md) | Auxiliary utility methods | --- --- url: /zh/vbman/global/delay.md --- # VBMAN.Delay - 延迟执行对象 ## 概述 `VBMAN.Delay` 提供了延迟执行和异步回调功能，可以在指定时间后执行代码，避免阻塞主线程，适用于需要延时操作的场景。 ## 核心特性 * **非阻塞延迟**: 不会冻结界面 * **回调支持**: 支持对象方法回调 * **可取消**: 可以取消待执行的延迟任务 * **链式调用**: 流畅的 API 设计 ## 方法 ### Callback 设置回调对象和方法 ```vb Public Function Callback(ByVal obj As Object, ByVal methodName As String) As cDelay ``` **参数**: * `obj` - 回调对象 * `methodName` - 要调用的方法名 **示例**: ```vb ' 设置回调 VBMAN.Delay.Callback Me, "DelayedMethod" ``` ### CountDown 开始倒计时（毫秒） ```vb Public Function CountDown(ByVal milliseconds As Long) As cDelay ``` **示例**: ```vb ' 2秒后执行 VBMAN.Delay.Callback(Me, "ShowMessage").CountDown 2000 ' 5秒后执行 VBMAN.Delay.Callback(Me, "AutoSave").CountDown 5000 ``` ## 综合示例 ### 示例1: 延迟显示消息 ```vb ' 在窗体模块中 Public Sub ShowDelayedMessage() VBMAN.Delay.Callback Me, "ShowWelcome" VBMAN.Delay.CountDown 1000 End Sub Public Sub ShowWelcome() MsgBox "欢迎使用本系统！" End Sub ' 使用 Private Sub Form_Load() ShowDelayedMessage End Sub ``` ### 示例2: 异步显示主窗体（来自 cs-auther 案例） ```vb ' 异步显示主窗体的原因： ' 因为 bUser.Info 在 TCP 接收处理器内部执行，而 fLogin 也监听了 TCP 事件。 ' 如果直接在 Info 中 Unload fLogin，会引发事件重入冲突。 ' 因此使用 VBMAN.Delay.Callback(Me, "ShowMainForm").CountDown 2000 延迟 2 秒后异步执行。 Public Sub ShowMainForm() fLogin.Hide Form1.Show End Sub ' 在登录成功后调用 Private Sub LoginSuccess() VBMAN.Delay.Callback(Me, "ShowMainForm").CountDown 2000 End Sub ``` ### 示例3: 自动保存功能 ```vb Private Sub TextEditor_Change() ' 内容改变后，3秒后自动保存 VBMAN.Delay.Callback(Me, "AutoSave").CountDown 3000 End Sub Public Sub AutoSave() ' 保存文件 SaveFile TextEditor.Text, CurrentFilePath VBMAN.Toast.Show "已自动保存", 1000 End Sub ``` ### 示例4: 重试机制 ```vb Private retryCount As Integer Private Sub ConnectToServer() If Not TryConnect() Then retryCount = retryCount + 1 If retryCount <= 3 Then VBMAN.Toast.Show "连接失败，" & retryCount & "秒后重试...", 2000 VBMAN.Delay.Callback(Me, "ConnectToServer").CountDown retryCount * 1000 Else MsgBox "连接失败，请检查网络设置" End If End If End Sub ``` ### 示例5: 延时关闭 ```vb Private Sub ShutdownWithDelay() VBMAN.Toast.Show "系统将在5秒后关闭", 5000 VBMAN.Delay.Callback(Me, "DoShutdown").CountDown 5000 End Sub Public Sub DoShutdown() ' 执行清理操作 Cleanup ' 关闭程序 Unload Me End Sub ``` ## 最佳实践 1. **避免循环调用**: 注意防止无限递归的延时调用 2. **对象生命周期**: 确保回调对象在延时执行时仍然存在 3. **线程安全**: 在多线程环境中使用时注意线程安全 4. **错误处理**: 回调方法中添加错误处理 5. **适时取消**: 如果不再需要延时执行，及时取消 --- --- url: /en/vbman/global/delay.md --- # VBMAN.Delay - Delayed Execution Object ## Overview `VBMAN.Delay` provides delayed execution and asynchronous callback functionality, allowing code execution after a specified time without blocking the main thread, suitable for scenarios requiring delayed operations. ## Core Features * **Non-blocking Delay**: Does not freeze the UI * **Callback Support**: Supports object method callbacks * **Cancellable**: Can cancel pending delayed tasks * **Chain Calling**: Fluent API design ## Methods ### Callback Set callback object and method ```vb Public Function Callback(ByVal obj As Object, ByVal methodName As String) As cDelay ``` **Parameters**: * `obj` - Callback object * `methodName` - Method name to call **Example**: ```vb ' Set callback VBMAN.Delay.Callback Me, "DelayedMethod" ``` ### CountDown Start countdown (milliseconds) ```vb Public Function CountDown(ByVal milliseconds As Long) As cDelay ``` **Example**: ```vb ' Execute after 2 seconds VBMAN.Delay.Callback(Me, "ShowMessage").CountDown 2000 ' Execute after 5 seconds VBMAN.Delay.Callback(Me, "AutoSave").CountDown 5000 ``` ## Comprehensive Examples ### Example 1: Delayed Message Display ```vb ' In form module Public Sub ShowDelayedMessage() VBMAN.Delay.Callback Me, "ShowWelcome" VBMAN.Delay.CountDown 1000 End Sub Public Sub ShowWelcome() MsgBox "Welcome to the system!" End Sub ' Usage Private Sub Form_Load() ShowDelayedMessage End Sub ``` ### Example 2: Asynchronous Main Form Display (from cs-auther case) ```vb ' Reason for asynchronous main form display: ' Because bUser.Info executes inside the TCP receive handler, and fLogin also listens to TCP events. ' If fLogin is unloaded directly in Info, it causes event re-entry conflicts. ' Therefore, use VBMAN.Delay.Callback(Me, "ShowMainForm").CountDown 2000 to execute asynchronously after 2 seconds delay. Public Sub ShowMainForm() fLogin.Hide Form1.Show End Sub ' Call after successful login Private Sub LoginSuccess() VBMAN.Delay.Callback(Me, "ShowMainForm").CountDown 2000 End Sub ``` ### Example 3: Auto-save Feature ```vb Private Sub TextEditor_Change() ' Auto-save 3 seconds after content change VBMAN.Delay.Callback(Me, "AutoSave").CountDown 3000 End Sub Public Sub AutoSave() ' Save file SaveFile TextEditor.Text, CurrentFilePath VBMAN.Toast.Show "Auto-saved", 1000 End Sub ``` ### Example 4: Retry Mechanism ```vb Private retryCount As Integer Private Sub ConnectToServer() If Not TryConnect() Then retryCount = retryCount + 1 If retryCount <= 3 Then VBMAN.Toast.Show "Connection failed, retrying in " & retryCount & " seconds...", 2000 VBMAN.Delay.Callback(Me, "ConnectToServer").CountDown retryCount * 1000 Else MsgBox "Connection failed, please check network settings" End If End If End Sub ``` ### Example 5: Delayed Shutdown ```vb Private Sub ShutdownWithDelay() VBMAN.Toast.Show "System will shut down in 5 seconds", 5000 VBMAN.Delay.Callback(Me, "DoShutdown").CountDown 5000 End Sub Public Sub DoShutdown() ' Perform cleanup Cleanup ' Close application Unload Me End Sub ``` ## Best Practices 1. **Avoid Circular Calls**: Be careful to prevent infinite recursive delayed calls 2. **Object Lifetime**: Ensure callback object still exists when delay executes 3. **Thread Safety**: Pay attention to thread safety when using in multi-threaded environments 4. **Error Handling**: Add error handling in callback methods 5. **Cancel in Time**: Cancel promptly if delayed execution is no longer needed --- --- url: /zh/vbman/global/dialog.md --- # VBMAN.Dialog - 文件对话框对象 ## 概述 `VBMAN.Dialog` 提供了 Windows 标准文件对话框功能，包括打开文件、保存文件、选择文件夹等。 ## 核心特性 * **打开文件对话框**: 支持单选/多选、文件过滤 * **保存文件对话框**: 支持覆盖提示、默认扩展名 * **文件夹浏览对话框**: 支持新建对话框样式 * **属性配置**: 通过属性设置对话框选项 ## 属性 | 属性 | 类型 | 说明 | |------|------|------| | `DialogTitle` | String | 对话框标题 | | `InitialDir` | String | 初始目录 | | `DefaultExt` | String | 默认扩展名 | | `FileName` | String | 默认/返回文件名 | | `Filter` | String | 文件过滤器 | | `MultiSelect` | Boolean | 允许多选（默认 False） | | `OverwritePrompt` | Boolean | 覆盖提示（默认 True） | | `PathMustExist` | Boolean | 路径必须存在（默认 True） | | `FileMustExist` | Boolean | 文件必须存在（默认 True） | | `HideReadOnly` | Boolean | 隐藏只读选项（默认 True） | ## 方法 ### ShowOpen 显示打开文件对话框 ```vb Public Function ShowOpen() As Variant ``` **返回**: 选中的文件路径，取消返回 Empty **示例**: ```vb With VBMAN.Dialog .DialogTitle = "选择文件" .InitialDir = "C:\\" .Filter = "文本文件 (*.txt)|*.txt|所有文件 (*.*)|*.*" .FileName = "" Dim result As Variant result = .ShowOpen If Not IsEmpty(result) Then MsgBox "选择了: " & result End If End With ``` ### ShowSave 显示保存文件对话框 ```vb Public Function ShowSave() As String ``` **返回**: 保存的文件路径，取消返回空字符串 **示例**: ```vb With VBMAN.Dialog .DialogTitle = "保存文件" .InitialDir = App.Path .DefaultExt = "txt" .Filter = "文本文件 (*.txt)|*.txt" .FileName = "新建文件.txt" Dim savePath As String savePath = .ShowSave If savePath <> "" Then ' 保存文件... End If End With ``` ### ShowBrowseForFolder 显示文件夹浏览对话框 ```vb Public Function ShowBrowseForFolder() As String ``` **返回**: 选择的文件夹路径，取消返回空字符串 **示例**: ```vb With VBMAN.Dialog .DialogTitle = "选择文件夹" Dim folderPath As String folderPath = .ShowBrowseForFolder If folderPath <> "" Then MsgBox "选择了: " & folderPath End If End With ``` ### SelectFiles 选择多个文件返回集合 ```vb Public Function SelectFiles() As cCollection ``` **返回**: 选中文件路径的集合 **示例**: ```vb With VBMAN.Dialog .DialogTitle = "选择多个文件" .MultiSelect = True .Filter = "所有文件 (*.*)|*.*" Dim files As cCollection Set files = .SelectFiles Dim i As Long For i = 1 To files.Count Debug.Print files(i) Next i End With ``` ## 综合示例 ### 示例1: 文本文件打开 ```vb Private Sub OpenTextFile() With VBMAN.Dialog .DialogTitle = "打开文本文件" .InitialDir = App.Path .Filter = "文本文件 (*.txt)|*.txt|所有文件 (*.*)|*.*" .FileMustExist = True Dim filePath As Variant filePath = .ShowOpen If Not IsEmpty(filePath) Then Dim content As String content = VBMAN.ToolsStream.LoadFileAsText(CStr(filePath)) Text1.Text = content End If End With End Sub ``` ### 示例2: 保存配置 ```vb Private Sub SaveConfig() With VBMAN.Dialog .DialogTitle = "保存配置" .InitialDir = App.Path .DefaultExt = "ini" .Filter = "配置文件 (*.ini)|*.ini" .OverwritePrompt = True .FileName = "config.ini" Dim savePath As String savePath = .ShowSave If savePath <> "" Then VBMAN.Ini.SaveTo savePath End If End With End Sub ``` ### 示例3: 选择输出目录 ```vb Private Sub SelectOutputDir() With VBMAN.Dialog .DialogTitle = "选择输出目录" .InitialDir = "C:\\" Dim outputDir As String outputDir = .ShowBrowseForFolder If outputDir <> "" Then LabelOutput.Caption = outputDir End If End With End Sub ``` ## 最佳实践 1. **设置初始目录**: 使用 App.Path 或用户上次选择的目录 2. **文件过滤**: 提供合理的文件类型过滤选项 3. **错误处理**: 检查返回值是否为空/Empty 4. **用户体验**: 设置有意义的对话框标题 --- --- url: /en/vbman/global/dialog.md --- # VBMAN.Dialog - File Dialog Object ## Overview `VBMAN.Dialog` provides Windows standard file dialog functionality, including opening files, saving files, selecting folders, etc. ## Core Features * **Open File Dialog**: Supports single/multi selection, file filtering * **Save File Dialog**: Supports overwrite prompt, default extension * **Folder Browse Dialog**: Supports new dialog style * **Property Configuration**: Set dialog options through properties ## Properties | Property | Type | Description | |----------|------|-------------| | `DialogTitle` | String | Dialog title | | `InitialDir` | String | Initial directory | | `DefaultExt` | String | Default extension | | `FileName` | String | Default/return filename | | `Filter` | String | File filter | | `MultiSelect` | Boolean | Allow multiple selection (default False) | | `OverwritePrompt` | Boolean | Overwrite prompt (default True) | | `PathMustExist` | Boolean | Path must exist (default True) | | `FileMustExist` | Boolean | File must exist (default True) | | `HideReadOnly` | Boolean | Hide read-only option (default True) | ## Methods ### ShowOpen Show open file dialog ```vb Public Function ShowOpen() As Variant ``` **Returns**: Selected file path, returns Empty if cancelled **Example**: ```vb With VBMAN.Dialog .DialogTitle = "Select File" .InitialDir = "C:\\" .Filter = "Text Files (*.txt)|*.txt|All Files (*.*)|*.*" .FileName = "" Dim result As Variant result = .ShowOpen If Not IsEmpty(result) Then MsgBox "Selected: " & result End If End With ``` ### ShowSave Show save file dialog ```vb Public Function ShowSave() As String ``` **Returns**: Saved file path, returns empty string if cancelled **Example**: ```vb With VBMAN.Dialog .DialogTitle = "Save File" .InitialDir = App.Path .DefaultExt = "txt" .Filter = "Text Files (*.txt)|*.txt" .FileName = "New File.txt" Dim savePath As String savePath = .ShowSave If savePath <> "" Then ' Save file... End If End With ``` ### ShowBrowseForFolder Show folder browse dialog ```vb Public Function ShowBrowseForFolder() As String ``` **Returns**: Selected folder path, returns empty string if cancelled **Example**: ```vb With VBMAN.Dialog .DialogTitle = "Select Folder" Dim folderPath As String folderPath = .ShowBrowseForFolder If folderPath <> "" Then MsgBox "Selected: " & folderPath End If End With ``` ### SelectFiles Select multiple files and return collection ```vb Public Function SelectFiles() As cCollection ``` **Returns**: Collection of selected file paths **Example**: ```vb With VBMAN.Dialog .DialogTitle = "Select Multiple Files" .MultiSelect = True .Filter = "All Files (*.*)|*.*" Dim files As cCollection Set files = .SelectFiles Dim i As Long For i = 1 To files.Count Debug.Print files(i) Next i End With ``` ## Comprehensive Examples ### Example 1: Open Text File ```vb Private Sub OpenTextFile() With VBMAN.Dialog .DialogTitle = "Open Text File" .InitialDir = App.Path .Filter = "Text Files (*.txt)|*.txt|All Files (*.*)|*.*" .FileMustExist = True Dim filePath As Variant filePath = .ShowOpen If Not IsEmpty(filePath) Then Dim content As String content = VBMAN.ToolsStream.LoadFileAsText(CStr(filePath)) Text1.Text = content End If End With End Sub ``` ### Example 2: Save Configuration ```vb Private Sub SaveConfig() With VBMAN.Dialog .DialogTitle = "Save Configuration" .InitialDir = App.Path .DefaultExt = "ini" .Filter = "Configuration Files (*.ini)|*.ini" .OverwritePrompt = True .FileName = "config.ini" Dim savePath As String savePath = .ShowSave If savePath <> "" Then VBMAN.Ini.SaveTo savePath End If End With End Sub ``` ### Example 3: Select Output Directory ```vb Private Sub SelectOutputDir() With VBMAN.Dialog .DialogTitle = "Select Output Directory" .InitialDir = "C:\\" Dim outputDir As String outputDir = .ShowBrowseForFolder If outputDir <> "" Then LabelOutput.Caption = outputDir End If End With End Sub ``` ## Best Practices 1. **Set Initial Directory**: Use App.Path or user's last selected directory 2. **File Filtering**: Provide reasonable file type filter options 3. **Error Handling**: Check if return value is empty/Empty 4. **User Experience**: Set meaningful dialog titles --- --- url: /zh/vbman/global/fileex.md --- # VBMAN.FileEx - 高级文件操作对象 ## 概述 `VBMAN.FileEx` 提供了高级文件操作功能，基于 VB 原生 Open 语句实现，支持多种编码格式、灵活的数据读写方式，以及缓冲区操作。 ## 核心特性 * **多编码支持**: UTF-8、ANSI、UTF-16LE 自动识别 * **灵活模式**: 只读、只写、读写模式 * **缓冲区操作**: 支持字节数组、Base64、Hex 等多种格式 * **链式调用**: 流畅的 API 设计 * **大文件支持**: 支持最大 2GB 文件操作 ## 属性 | 属性 | 类型 | 说明 | |------|------|------| | `IsOpen` | Boolean | 文件是否已打开 | | `FilePath` | String | 当前打开的文件路径 | | `LastError` | String | 最后错误信息 | | `FileSize` | Currency | 文件大小（字节） | | `BufferSize` | Long | 当前缓冲区字节数 | ## 方法 ### 文件打开/关闭 #### OpenFile 打开文件 ```vb Public Function OpenFile(ByVal FilePath As String, Optional ByVal AccessMode As String = "RW") As cFileEx ``` **参数**: * `FilePath` - 文件路径 * `AccessMode` - 访问模式："R"=只读, "W"=只写, "RW"=读写(默认) **示例**: ```vb ' 只读模式 VBMAN.FileEx.OpenFile "C:\\data.txt", "R" ' 读写模式（默认） VBMAN.FileEx.OpenFile "C:\\data.txt" ' 链式调用 VBMAN.FileEx.OpenFile("C:\\data.txt").ReadData.ReturnText ``` #### CloseFile 关闭文件 ```vb Public Sub CloseFile() ``` **示例**: ```vb VBMAN.FileEx.OpenFile "C:\\data.txt", "R" ' ... 操作 ... VBMAN.FileEx.CloseFile ``` ### 缓冲区设置 #### ClearBuffer 清空内部缓冲区 ```vb Public Function ClearBuffer() As cFileEx ``` #### SetBuffer 用字节数组填充缓冲区 ```vb Public Function SetBuffer(Data() As Byte) As cFileEx ``` **示例**: ```vb Dim bytes(0 To 3) As Byte bytes(0) = &H41: bytes(1) = &H42 bytes(2) = &H43: bytes(3) = &H44 VBMAN.FileEx.SetBuffer bytes ``` #### SetBufferText 用字符串填充缓冲区（指定编码） ```vb Public Function SetBufferText(ByVal Text As String, Optional ByVal CharSet As String = "UTF-8") As cFileEx ``` **示例**: ```vb VBMAN.FileEx.SetBufferText "Hello 世界", "UTF-8" ``` #### SetBufferBase64 用 Base64 字符串填充缓冲区 ```vb Public Function SetBufferBase64(ByVal Base64String As String) As cFileEx ``` **示例**: ```vb VBMAN.FileEx.SetBufferBase64 "SGVsbG8gV29ybGQ=" ``` #### SetBufferHex 用 Hex 字符串填充缓冲区 ```vb Public Function SetBufferHex(ByVal HexString As String, Optional ByVal Separator As String = " ") As cFileEx ``` **示例**: ```vb VBMAN.FileEx.SetBufferHex "48 65 6C 6C 6F" VBMAN.FileEx.SetBufferHex "48656C6C6F" ``` #### SetBufferBinString 用二进制字符串填充缓冲区 ```vb Public Function SetBufferBinString(ByVal BinString As String, Optional ByVal Separator As String = " ") As cFileEx ``` **示例**: ```vb VBMAN.FileEx.SetBufferBinString "01001000 01100101" ``` #### AppendBuffer 追加字节到缓冲区 ```vb Public Function AppendBuffer(Data() As Byte) As cFileEx ``` ### 数据读取 #### ReadData 读取文件数据到内部缓冲区 ```vb Public Function ReadData(Optional ByVal StartPos As Long = -1, Optional ByVal EndPos As Long = -1) As cFileEx ``` **参数**: * `StartPos` - 起始位置（1-based，-1=文件开头） * `EndPos` - 结束位置（1-based，-1=文件末尾） **示例**: ```vb ' 读取整个文件 VBMAN.FileEx.OpenFile("C:\\data.txt").ReadData.ReturnText ' 读取指定范围 VBMAN.FileEx.OpenFile "C:\\data.txt", "R" VBMAN.FileEx.ReadData 1, 100 ' 读取前100字节 ``` ### 数据返回 #### ReturnText 返回缓冲区内容为文本 ```vb Public Function ReturnText(Optional ByVal CharSet As String = "UTF-8") As String ``` **示例**: ```vb Dim text As String text = VBMAN.FileEx.OpenFile("C:\\utf8.txt").ReadData.ReturnText("UTF-8") ``` #### ReturnBytes 返回缓冲区内容为字节数组 ```vb Public Function ReturnBytes() As Byte() ``` **示例**: ```vb Dim bytes() As Byte bytes = VBMAN.FileEx.OpenFile("C:\\data.bin").ReadData.ReturnBytes ``` #### ReturnBase64 返回缓冲区内容为 Base64 字符串 ```vb Public Function ReturnBase64() As String ``` **示例**: ```vb Dim base64 As String base64 = VBMAN.FileEx.OpenFile("C:\\image.png").ReadData.ReturnBase64 ``` #### ReturnHex 返回缓冲区内容为 Hex 字符串 ```vb Public Function ReturnHex(Optional ByVal Separator As String = " ") As String ``` **示例**: ```vb Dim hex As String hex = VBMAN.FileEx.OpenFile("C:\\data.bin").ReadData.ReturnHex(" ") ' 结果: 48 65 6C 6C 6F ``` #### ReturnBinString 返回缓冲区内容为二进制字符串 ```vb Public Function ReturnBinString(Optional ByVal Separator As String = " ") As String ``` **示例**: ```vb Dim bin As String bin = VBMAN.FileEx.OpenFile("C:\\data.bin").ReadData.ReturnBinString(" ") ' 结果: 01001000 01100101 ``` ### 数据写入 #### SaveData 将缓冲区写入文件 ```vb Public Function SaveData(Optional ByVal FilePath As String, Optional ByVal IsAppend As Boolean = False) As cFileEx ``` **参数**: * `FilePath` - 目标路径（默认使用 OpenFile 的路径） * `IsAppend` - 是否追加（默认 False=覆盖） **示例**: ```vb ' 写入新文件 VBMAN.FileEx.SetBufferText("Hello World", "UTF-8").SaveData "C:\\output.txt" ' 追加到文件 VBMAN.FileEx.SetBufferText("New Line" & vbCrLf, "UTF-8").SaveData "C:\\log.txt", True ``` ## 综合示例 ### 示例1: 快速读取文本文件 ```vb Private Function ReadTextFile(filePath As String, Optional charSet As String = "UTF-8") As String On Error GoTo ErrorHandler ReadTextFile = VBMAN.FileEx.OpenFile(filePath, "R").ReadData.ReturnText(charSet) VBMAN.FileEx.CloseFile Exit Function ErrorHandler: ReadTextFile = "" End Function Private Sub TestRead() Dim content As String content = ReadTextFile("C:\\data.txt", "UTF-8") TextBox1.Text = content End Sub ``` ### 示例2: 快速写入文本文件 ```vb Private Sub WriteTextFile(filePath As String, content As String, Optional charSet As String = "UTF-8") On Error GoTo ErrorHandler VBMAN.FileEx.SetBufferText(content, charSet).SaveData filePath Exit Sub ErrorHandler: MsgBox "写入失败: " & Err.Description End Sub Private Sub TestWrite() WriteTextFile "C:\\output.txt", TextBox1.Text, "UTF-8" End Sub ``` ### 示例3: 文件编码转换 ```vb Private Sub ConvertFileEncoding(sourcePath As String, destPath As String, sourceCharset As String, destCharset As String) ' 读取源文件 Dim content As String content = VBMAN.FileEx.OpenFile(sourcePath, "R").ReadData.ReturnText(sourceCharset) VBMAN.FileEx.CloseFile ' 写入目标文件 VBMAN.FileEx.SetBufferText(content, destCharset).SaveData destPath MsgBox "转换完成！" End Sub Private Sub TestConvert() ' GB2312 转 UTF-8 ConvertFileEncoding "C:\\gbk.txt", "C:\\utf8.txt", "GB2312", "UTF-8" End Sub ``` ### 示例4: 处理二进制文件 ```vb Private Sub ProcessBinaryFile() ' 读取二进制文件 VBMAN.FileEx.OpenFile "C:\\data.bin", "R" ' 读取前 16 字节 Dim hexData As String hexData = VBMAN.FileEx.ReadData(1, 16).ReturnHex(" ") Debug.Print "Hex: " & hexData ' 读取全部并转 Base64 Dim base64Data As String base64Data = VBMAN.FileEx.ReadData.ReturnBase64 VBMAN.FileEx.CloseFile ' 保存 Base64 到文本文件 VBMAN.FileEx.SetBufferText(base64Data, "UTF-8").SaveData "C:\\base64.txt" End Sub ``` ### 示例5: 大文件分块读取 ```vb Private Sub ReadLargeFile(filePath As String) Const CHUNK_SIZE = 1048576 ' 1MB VBMAN.FileEx.OpenFile filePath, "R" Dim fileSize As Currency fileSize = VBMAN.FileEx.FileSize Dim totalRead As Currency totalRead = 0 Do While totalRead < fileSize Dim startPos As Long Dim endPos As Long startPos = totalRead + 1 endPos = totalRead + CHUNK_SIZE If endPos > fileSize Then endPos = fileSize ' 读取一块数据 Dim chunk As String chunk = VBMAN.FileEx.ReadData(startPos, endPos).ReturnText("UTF-8") ' 处理这块数据... ProcessChunk chunk totalRead = endPos ' 显示进度 Debug.Print "进度: " & Int(totalRead / fileSize * 100) & "%" DoEvents Loop VBMAN.FileEx.CloseFile End Sub ``` ### 示例6: 日志文件追加 ```vb Private Sub AppendLog(message As String) Dim logEntry As String logEntry = Format(Now, "yyyy-MM-dd hh:mm:ss") & " " & message & vbCrLf VBMAN.FileEx.SetBufferText(logEntry, "UTF-8").SaveData App.Path & "\\app.log", True End Sub Private Sub TestLog() AppendLog "程序启动" AppendLog "执行操作 A" AppendLog "执行操作 B" End Sub ``` ## 最佳实践 1. **及时关闭**: 文件使用完毕后及时调用 CloseFile 2. **错误处理**: 文件操作添加错误处理机制 3. **编码一致**: 读写使用相同的字符编码 4. **大文件分块**: 超过内存容量的文件分块读写 5. **路径检查**: 操作前检查文件/目录是否存在 --- --- url: /en/vbman/global/fileex.md --- # VBMAN.FileEx - Advanced File Operation Object ## Overview `VBMAN.FileEx` provides advanced file operation functionality, implemented based on VB's native Open statement, supporting multiple encoding formats, flexible data read/write methods, and buffer operations. ## Core Features * **Multi-encoding Support**: UTF-8, ANSI, UTF-16LE auto-detection * **Flexible Modes**: Read-only, write-only, read-write modes * **Buffer Operations**: Supports byte arrays, Base64, Hex, and other formats * **Chain Calling**: Fluent API design * **Large File Support**: Supports file operations up to 2GB ## Properties | Property | Type | Description | |----------|------|-------------| | `IsOpen` | Boolean | Whether file is open | | `FilePath` | String | Currently open file path | | `LastError` | String | Last error message | | `FileSize` | Currency | File size (bytes) | | `BufferSize` | Long | Current buffer byte count | ## Methods ### File Open/Close #### OpenFile Open file ```vb Public Function OpenFile(ByVal FilePath As String, Optional ByVal AccessMode As String = "RW") As cFileEx ``` **Parameters**: * `FilePath` - File path * `AccessMode` - Access mode: "R"=Read-only, "W"=Write-only, "RW"=Read-write (default) **Example**: ```vb ' Read-only mode VBMAN.FileEx.OpenFile "C:\\data.txt", "R" ' Read-write mode (default) VBMAN.FileEx.OpenFile "C:\\data.txt" ' Chain calling VBMAN.FileEx.OpenFile("C:\\data.txt").ReadData.ReturnText ``` #### CloseFile Close file ```vb Public Sub CloseFile() ``` **Example**: ```vb VBMAN.FileEx.OpenFile "C:\\data.txt", "R" ' ... operations ... VBMAN.FileEx.CloseFile ``` ### Buffer Settings #### ClearBuffer Clear internal buffer ```vb Public Function ClearBuffer() As cFileEx ``` #### SetBuffer Fill buffer with byte array ```vb Public Function SetBuffer(Data() As Byte) As cFileEx ``` **Example**: ```vb Dim bytes(0 To 3) As Byte bytes(0) = &H41: bytes(1) = &H42 bytes(2) = &H43: bytes(3) = &H44 VBMAN.FileEx.SetBuffer bytes ``` #### SetBufferText Fill buffer with string (specify encoding) ```vb Public Function SetBufferText(ByVal Text As String, Optional ByVal CharSet As String = "UTF-8") As cFileEx ``` **Example**: ```vb VBMAN.FileEx.SetBufferText "Hello World", "UTF-8" ``` #### SetBufferBase64 Fill buffer with Base64 string ```vb Public Function SetBufferBase64(ByVal Base64String As String) As cFileEx ``` **Example**: ```vb VBMAN.FileEx.SetBufferBase64 "SGVsbG8gV29ybGQ=" ``` #### SetBufferHex Fill buffer with Hex string ```vb Public Function SetBufferHex(ByVal HexString As String, Optional ByVal Separator As String = " ") As cFileEx ``` **Example**: ```vb VBMAN.FileEx.SetBufferHex "48 65 6C 6C 6F" VBMAN.FileEx.SetBufferHex "48656C6C6F" ``` #### SetBufferBinString Fill buffer with binary string ```vb Public Function SetBufferBinString(ByVal BinString As String, Optional ByVal Separator As String = " ") As cFileEx ``` **Example**: ```vb VBMAN.FileEx.SetBufferBinString "01001000 01100101" ``` #### AppendBuffer Append bytes to buffer ```vb Public Function AppendBuffer(Data() As Byte) As cFileEx ``` ### Data Reading #### ReadData Read file data to internal buffer ```vb Public Function ReadData(Optional ByVal StartPos As Long = -1, Optional ByVal EndPos As Long = -1) As cFileEx ``` **Parameters**: * `StartPos` - Start position (1-based, -1=file beginning) * `EndPos` - End position (1-based, -1=file end) **Example**: ```vb ' Read entire file VBMAN.FileEx.OpenFile("C:\\data.txt").ReadData.ReturnText ' Read specified range VBMAN.FileEx.OpenFile "C:\\data.txt", "R" VBMAN.FileEx.ReadData 1, 100 ' Read first 100 bytes ``` ### Data Return #### ReturnText Return buffer content as text ```vb Public Function ReturnText(Optional ByVal CharSet As String = "UTF-8") As String ``` **Example**: ```vb Dim text As String text = VBMAN.FileEx.OpenFile("C:\\utf8.txt").ReadData.ReturnText("UTF-8") ``` #### ReturnBytes Return buffer content as byte array ```vb Public Function ReturnBytes() As Byte() ``` **Example**: ```vb Dim bytes() As Byte bytes = VBMAN.FileEx.OpenFile("C:\\data.bin").ReadData.ReturnBytes ``` #### ReturnBase64 Return buffer content as Base64 string ```vb Public Function ReturnBase64() As String ``` **Example**: ```vb Dim base64 As String base64 = VBMAN.FileEx.OpenFile("C:\\image.png").ReadData.ReturnBase64 ``` #### ReturnHex Return buffer content as Hex string ```vb Public Function ReturnHex(Optional ByVal Separator As String = " ") As String ``` **Example**: ```vb Dim hex As String hex = VBMAN.FileEx.OpenFile("C:\\data.bin").ReadData.ReturnHex(" ") ' Result: 48 65 6C 6C 6F ``` #### ReturnBinString Return buffer content as binary string ```vb Public Function ReturnBinString(Optional ByVal Separator As String = " ") As String ``` **Example**: ```vb Dim bin As String bin = VBMAN.FileEx.OpenFile("C:\\data.bin").ReadData.ReturnBinString(" ") ' Result: 01001000 01100101 ``` ### Data Writing #### SaveData Write buffer to file ```vb Public Function SaveData(Optional ByVal FilePath As String, Optional ByVal IsAppend As Boolean = False) As cFileEx ``` **Parameters**: * `FilePath` - Target path (default uses OpenFile path) * `IsAppend` - Whether to append (default False=overwrite) **Example**: ```vb ' Write new file VBMAN.FileEx.SetBufferText("Hello World", "UTF-8").SaveData "C:\\output.txt" ' Append to file VBMAN.FileEx.SetBufferText("New Line" & vbCrLf, "UTF-8").SaveData "C:\\log.txt", True ``` ## Comprehensive Examples ### Example 1: Quick Text File Reading ```vb Private Function ReadTextFile(filePath As String, Optional charSet As String = "UTF-8") As String On Error GoTo ErrorHandler ReadTextFile = VBMAN.FileEx.OpenFile(filePath, "R").ReadData.ReturnText(charSet) VBMAN.FileEx.CloseFile Exit Function ErrorHandler: ReadTextFile = "" End Function Private Sub TestRead() Dim content As String content = ReadTextFile("C:\\data.txt", "UTF-8") TextBox1.Text = content End Sub ``` ### Example 2: Quick Text File Writing ```vb Private Sub WriteTextFile(filePath As String, content As String, Optional charSet As String = "UTF-8") On Error GoTo ErrorHandler VBMAN.FileEx.SetBufferText(content, charSet).SaveData filePath Exit Sub ErrorHandler: MsgBox "Write failed: " & Err.Description End Sub Private Sub TestWrite() WriteTextFile "C:\\output.txt", TextBox1.Text, "UTF-8" End Sub ``` ### Example 3: File Encoding Conversion ```vb Private Sub ConvertFileEncoding(sourcePath As String, destPath As String, sourceCharset As String, destCharset As String) ' Read source file Dim content As String content = VBMAN.FileEx.OpenFile(sourcePath, "R").ReadData.ReturnText(sourceCharset) VBMAN.FileEx.CloseFile ' Write destination file VBMAN.FileEx.SetBufferText(content, destCharset).SaveData destPath MsgBox "Conversion complete!" End Sub Private Sub TestConvert() ' GB2312 to UTF-8 ConvertFileEncoding "C:\\gbk.txt", "C:\\utf8.txt", "GB2312", "UTF-8" End Sub ``` ### Example 4: Processing Binary Files ```vb Private Sub ProcessBinaryFile() ' Read binary file VBMAN.FileEx.OpenFile "C:\\data.bin", "R" ' Read first 16 bytes Dim hexData As String hexData = VBMAN.FileEx.ReadData(1, 16).ReturnHex(" ") Debug.Print "Hex: " & hexData ' Read all and convert to Base64 Dim base64Data As String base64Data = VBMAN.FileEx.ReadData.ReturnBase64 VBMAN.FileEx.CloseFile ' Save Base64 to text file VBMAN.FileEx.SetBufferText(base64Data, "UTF-8").SaveData "C:\\base64.txt" End Sub ``` ### Example 5: Large File Chunked Reading ```vb Private Sub ReadLargeFile(filePath As String) Const CHUNK_SIZE = 1048576 ' 1MB VBMAN.FileEx.OpenFile filePath, "R" Dim fileSize As Currency fileSize = VBMAN.FileEx.FileSize Dim totalRead As Currency totalRead = 0 Do While totalRead < fileSize Dim startPos As Long Dim endPos As Long startPos = totalRead + 1 endPos = totalRead + CHUNK_SIZE If endPos > fileSize Then endPos = fileSize ' Read chunk of data Dim chunk As String chunk = VBMAN.FileEx.ReadData(startPos, endPos).ReturnText("UTF-8") ' Process this chunk... ProcessChunk chunk totalRead = endPos ' Show progress Debug.Print "Progress: " & Int(totalRead / fileSize * 100) & "%" DoEvents Loop VBMAN.FileEx.CloseFile End Sub ``` ### Example 6: Log File Appending ```vb Private Sub AppendLog(message As String) Dim logEntry As String logEntry = Format(Now, "yyyy-MM-dd hh:mm:ss") & " " & message & vbCrLf VBMAN.FileEx.SetBufferText(logEntry, "UTF-8").SaveData App.Path & "\\app.log", True End Sub Private Sub TestLog() AppendLog "Application started" AppendLog "Execute operation A" AppendLog "Execute operation B" End Sub ``` ## Best Practices 1. **Close in Time**: Call CloseFile promptly after file usage 2. **Error Handling**: Add error handling mechanism for file operations 3. **Consistent Encoding**: Use the same character encoding for reading and writing 4. **Chunk Large Files**: Read/write large files exceeding memory capacity in chunks 5. **Path Checking**: Check if file/directory exists before operation --- --- url: /zh/vbman/global/formater.md --- # VBMAN.Formater - 格式化工具对象 ## 概述 `VBMAN.Formater` 提供了各种数据格式化功能，包括数字、日期、文件大小等的格式化显示。 **使用方式**：通过链式调用 `Data(值).ReturnXXX()` 的方式使用。 ## 核心特性 * **数字格式化**: 货币、百分比、千分位、罗马数字 * **日期格式化**: 多种日期时间格式、相对时间 * **文件大小**: 自动转换为 B/KB/MB/GB/TB/PB * **文本格式化**: 对齐、填充、截断、命名风格转换 * **掩码格式化**: 手机号、身份证号、邮箱脱敏 * **编码转换**: HTML编码、URL编码、Base64、十六进制 ## 方法 ### Data 设置数据源，返回 Me 支持链式调用（入口方法） ```vb Public Function Data(ByVal Source As Variant) As cFormater ``` ### 文件大小格式化 #### ReturnFileSize 返回格式化后的文件大小字符串 (B/KB/MB/GB/TB/PB) ```vb Public Function ReturnFileSize(Optional ByVal DecimalPlaces As Long = 2, Optional ByVal ForceUnit As String = "") As String ``` ### 时间格式化 #### ReturnTimeAgo 返回相对时间描述（刚刚、5秒前、3分钟前等） ```vb Public Function ReturnTimeAgo() As String ``` #### ReturnDateTime 返回格式化日期时间 ```vb Public Function ReturnDateTime(Optional ByVal FormatStr As String = "yyyy-MM-dd HH:mm:ss") As String ``` #### ReturnShortDate 返回日期（短格式 yyyy-MM-dd） ```vb Public Function ReturnShortDate() As String ``` #### ReturnShortTime 返回时间（短格式 HH:mm:ss） ```vb Public Function ReturnShortTime() As String ``` ### 数字格式化 #### ReturnNumber 返回格式化数字（千分位） ```vb Public Function ReturnNumber(Optional ByVal DecimalPlaces As Long = 0) As String ``` #### ReturnCurrency 返回货币格式 ```vb Public Function ReturnCurrency(Optional ByVal Symbol As String = "¥") As String ``` #### ReturnPercent 返回百分比 ```vb Public Function ReturnPercent(Optional ByVal DecimalPlaces As Long = 0) As String ``` #### ReturnRoman 返回罗马数字（支持 1-3999） ```vb Public Function ReturnRoman() As String ``` ### 文本格式化 #### ReturnTruncate 返回限制长度的文本，超长时显示省略号 ```vb Public Function ReturnTruncate(ByVal MaxLength As Long, Optional ByVal Suffix As String = "...") As String ``` #### ReturnPadLeft 返回左侧填充后的文本 ```vb Public Function ReturnPadLeft(ByVal TotalWidth As Long, Optional ByVal PadChar As String = " ") As String ``` #### ReturnPadRight 返回右侧填充后的文本 ```vb Public Function ReturnPadRight(ByVal TotalWidth As Long, Optional ByVal PadChar As String = " ") As String ``` #### ReturnProperCase 返回首字母大写 ```vb Public Function ReturnProperCase() As String ``` #### ReturnCamelCase 返回驼峰命名 (helloWorldExample) ```vb Public Function ReturnCamelCase() As String ``` #### ReturnPascalCase 返回帕斯卡命名 (HelloWorldExample) ```vb Public Function ReturnPascalCase() As String ``` #### ReturnSnakeCase 返回下划线命名 (hello\_world\_example) ```vb Public Function ReturnSnakeCase() As String ``` #### ReturnKebabCase 返回短横线命名 (hello-world-example) ```vb Public Function ReturnKebabCase() As String ``` #### ReturnHtmlEncode 返回HTML转义文本 ```vb Public Function ReturnHtmlEncode() As String ``` #### ReturnUrlEncode 返回URL编码文本 ```vb Public Function ReturnUrlEncode() As String ``` ### 掩码格式化 #### ReturnMaskedPhone 返回手机号掩码 (138\*\*\*\*8888) ```vb Public Function ReturnMaskedPhone() As String ``` #### ReturnMaskedIDCard 返回身份证号掩码 (110101\*\*\*\*\*\*\*\*1234) ```vb Public Function ReturnMaskedIDCard() As String ``` #### ReturnMaskedEmail 返回邮箱掩码 (a\*\*\*@gmail.com) ```vb Public Function ReturnMaskedEmail() As String ``` ### 其他格式化 #### ReturnHex 返回十六进制字符串 ```vb Public Function ReturnHex() As String ``` #### ReturnBase64 返回Base64编码 ```vb Public Function ReturnBase64() As String ``` #### ReturnBooleanText 返回布尔值的友好文本 ```vb Public Function ReturnBooleanText(Optional ByVal TrueText As String = "是", Optional ByVal FalseText As String = "否") As String ``` #### ReturnFileName 返回文件名（含扩展名） ```vb Public Function ReturnFileName() As String ``` #### ReturnFileNameWithoutExt 返回文件名（不含扩展名） ```vb Public Function ReturnFileNameWithoutExt() As String ``` #### ReturnFileExt 返回文件扩展名 ```vb Public Function ReturnFileExt() As String ``` #### ReturnFilePath 返回文件路径（不含文件名） ```vb Public Function ReturnFilePath() As String ``` ## 综合示例 ### 示例1: 基本格式化 ```vb Private Sub BasicFormat() ' 货币显示 Dim price As Currency price = 1234567.89 LabelPrice.Caption = VBMAN.Formater.Data(price).ReturnCurrency("¥") ' 结果: ¥1,234,567.89 ' 文件大小 Dim fileSize As Currency fileSize = 1536000000 LabelSize.Caption = VBMAN.Formater.Data(fileSize).ReturnFileSize() ' 结果: 1.43 GB ' 百分比 Dim rate As Double rate = 0.8567 LabelRate.Caption = VBMAN.Formater.Data(rate).ReturnPercent(2) ' 结果: 85.67% ' 相对时间 Dim postTime As Date postTime = DateAdd("h", -2, Now) LabelTime.Caption = VBMAN.Formater.Data(postTime).ReturnTimeAgo() ' 结果: 2小时前 End Sub ``` ### 示例2: 文本格式化 ```vb Private Sub TextFormat() Dim text As String text = "hello world example" ' 驼峰命名 Debug.Print VBMAN.Formater.Data(text).ReturnCamelCase() ' 结果: helloWorldExample ' 帕斯卡命名 Debug.Print VBMAN.Formater.Data(text).ReturnPascalCase() ' 结果: HelloWorldExample ' 截断文本 Debug.Print VBMAN.Formater.Data("这是一段很长的文本").ReturnTruncate(6) ' 结果: 这是一段... ' 左填充 Debug.Print VBMAN.Formater.Data("123").ReturnPadLeft(6, "0") ' 结果: 000123 End Sub ``` ### 示例3: 数据脱敏 ```vb Private Sub MaskSensitiveData() ' 手机号脱敏 Debug.Print VBMAN.Formater.Data("13812345678").ReturnMaskedPhone() ' 结果: 138****5678 ' 身份证号脱敏 Debug.Print VBMAN.Formater.Data("110101199001011234").ReturnMaskedIDCard() ' 结果: 110101********1234 ' 邮箱脱敏 Debug.Print VBMAN.Formater.Data("admin@gmail.com").ReturnMaskedEmail() ' 结果: a***@gmail.com End Sub ``` ### 示例4: 列表格式化显示 ```vb Private Sub FormatListView() Dim li As ListItem For Each li In ListView1.ListItems ' 格式化金额列 li.SubItems(2) = VBMAN.Formater.Data(li.SubItems(2)).ReturnCurrency() ' 格式化日期列 li.SubItems(3) = VBMAN.Formater.Data(CDate(li.SubItems(3))).ReturnShortDate() ' 格式化文件大小列 li.SubItems(4) = VBMAN.Formater.Data(li.SubItems(4)).ReturnFileSize() Next li End Sub ``` ## 最佳实践 1. **链式调用**: 使用 `Data(值).ReturnXXX()` 的方式保持代码简洁 2. **类型检查**: 格式化前确保数据类型正确，错误类型会返回默认值 3. **本地化**: 根据用户地区使用相应的货币符号和日期格式 4. **一致性**: 同类数据使用相同的格式化方式 --- --- url: /en/vbman/global/formater.md --- # VBMAN.Formater - Formatting Tool Object ## Overview `VBMAN.Formater` provides various data formatting functions, including number, date, file size, and other formatting displays. **Usage**: Use through chain calling `Data(Value).ReturnXXX()` method. ## Core Features * **Number Formatting**: Currency, percentage, thousands separator, Roman numerals * **Date Formatting**: Multiple date/time formats, relative time * **File Size**: Automatic conversion to B/KB/MB/GB/TB/PB * **Text Formatting**: Alignment, padding, truncation, naming style conversion * **Mask Formatting**: Phone number, ID card, email desensitization * **Encoding Conversion**: HTML encoding, URL encoding, Base64, hexadecimal ## Methods ### Data Set data source, returns Me to support chain calling (entry method) ```vb Public Function Data(ByVal Source As Variant) As cFormater ``` ### File Size Formatting #### ReturnFileSize Return formatted file size string (B/KB/MB/GB/TB/PB) ```vb Public Function ReturnFileSize(Optional ByVal DecimalPlaces As Long = 2, Optional ByVal ForceUnit As String = "") As String ``` ### Time Formatting #### ReturnTimeAgo Return relative time description (just now, 5 seconds ago, 3 minutes ago, etc.) ```vb Public Function ReturnTimeAgo() As String ``` #### ReturnDateTime Return formatted date and time ```vb Public Function ReturnDateTime(Optional ByVal FormatStr As String = "yyyy-MM-dd HH:mm:ss") As String ``` #### ReturnShortDate Return date (short format yyyy-MM-dd) ```vb Public Function ReturnShortDate() As String ``` #### ReturnShortTime Return time (short format HH:mm:ss) ```vb Public Function ReturnShortTime() As String ``` ### Number Formatting #### ReturnNumber Return formatted number (thousands separator) ```vb Public Function ReturnNumber(Optional ByVal DecimalPlaces As Long = 0) As String ``` #### ReturnCurrency Return currency format ```vb Public Function ReturnCurrency(Optional ByVal Symbol As String = "$") As String ``` #### ReturnPercent Return percentage ```vb Public Function ReturnPercent(Optional ByVal DecimalPlaces As Long = 0) As String ``` #### ReturnRoman Return Roman numeral (supports 1-3999) ```vb Public Function ReturnRoman() As String ``` ### Text Formatting #### ReturnTruncate Return text with limited length, show ellipsis if too long ```vb Public Function ReturnTruncate(ByVal MaxLength As Long, Optional ByVal Suffix As String = "...") As String ``` #### ReturnPadLeft Return left-padded text ```vb Public Function ReturnPadLeft(ByVal TotalWidth As Long, Optional ByVal PadChar As String = " ") As String ``` #### ReturnPadRight Return right-padded text ```vb Public Function ReturnPadRight(ByVal TotalWidth As Long, Optional ByVal PadChar As String = " ") As String ``` #### ReturnProperCase Return proper case (first letter capitalized) ```vb Public Function ReturnProperCase() As String ``` #### ReturnCamelCase Return camelCase (helloWorldExample) ```vb Public Function ReturnCamelCase() As String ``` #### ReturnPascalCase Return PascalCase (HelloWorldExample) ```vb Public Function ReturnPascalCase() As String ``` #### ReturnSnakeCase Return snake\_case (hello\_world\_example) ```vb Public Function ReturnSnakeCase() As String ``` #### ReturnKebabCase Return kebab-case (hello-world-example) ```vb Public Function ReturnKebabCase() As String ``` #### ReturnHtmlEncode Return HTML escaped text ```vb Public Function ReturnHtmlEncode() As String ``` #### ReturnUrlEncode Return URL encoded text ```vb Public Function ReturnUrlEncode() As String ``` ### Mask Formatting #### ReturnMaskedPhone Return phone number mask (138\*\*\*\*8888) ```vb Public Function ReturnMaskedPhone() As String ``` #### ReturnMaskedIDCard Return ID card mask (110101\*\*\*\*\*\*\*\*1234) ```vb Public Function ReturnMaskedIDCard() As String ``` #### ReturnMaskedEmail Return email mask (a\*\*\*@gmail.com) ```vb Public Function ReturnMaskedEmail() As String ``` ### Other Formatting #### ReturnHex Return hexadecimal string ```vb Public Function ReturnHex() As String ``` #### ReturnBase64 Return Base64 encoding ```vb Public Function ReturnBase64() As String ``` #### ReturnBooleanText Return friendly text for boolean value ```vb Public Function ReturnBooleanText(Optional ByVal TrueText As String = "Yes", Optional ByVal FalseText As String = "No") As String ``` #### ReturnFileName Return filename (with extension) ```vb Public Function ReturnFileName() As String ``` #### ReturnFileNameWithoutExt Return filename (without extension) ```vb Public Function ReturnFileNameWithoutExt() As String ``` #### ReturnFileExt Return file extension ```vb Public Function ReturnFileExt() As String ``` #### ReturnFilePath Return file path (without filename) ```vb Public Function ReturnFilePath() As String ``` ## Comprehensive Examples ### Example 1: Basic Formatting ```vb Private Sub BasicFormat() ' Currency display Dim price As Currency price = 1234567.89 LabelPrice.Caption = VBMAN.Formater.Data(price).ReturnCurrency("$") ' Result: $1,234,567.89 ' File size Dim fileSize As Currency fileSize = 1536000000 LabelSize.Caption = VBMAN.Formater.Data(fileSize).ReturnFileSize() ' Result: 1.43 GB ' Percentage Dim rate As Double rate = 0.8567 LabelRate.Caption = VBMAN.Formater.Data(rate).ReturnPercent(2) ' Result: 85.67% ' Relative time Dim postTime As Date postTime = DateAdd("h", -2, Now) LabelTime.Caption = VBMAN.Formater.Data(postTime).ReturnTimeAgo() ' Result: 2 hours ago End Sub ``` ### Example 2: Text Formatting ```vb Private Sub TextFormat() Dim text As String text = "hello world example" ' CamelCase Debug.Print VBMAN.Formater.Data(text).ReturnCamelCase() ' Result: helloWorldExample ' PascalCase Debug.Print VBMAN.Formater.Data(text).ReturnPascalCase() ' Result: HelloWorldExample ' Truncate text Debug.Print VBMAN.Formater.Data("This is a very long text").ReturnTruncate(6) ' Result: This i... ' Left pad Debug.Print VBMAN.Formater.Data("123").ReturnPadLeft(6, "0") ' Result: 000123 End Sub ``` ### Example 3: Data Desensitization ```vb Private Sub MaskSensitiveData() ' Phone number mask Debug.Print VBMAN.Formater.Data("13812345678").ReturnMaskedPhone() ' Result: 138****5678 ' ID card mask Debug.Print VBMAN.Formater.Data("110101199001011234").ReturnMaskedIDCard() ' Result: 110101********1234 ' Email mask Debug.Print VBMAN.Formater.Data("admin@gmail.com").ReturnMaskedEmail() ' Result: a***@gmail.com End Sub ``` ### Example 4: List Formatting Display ```vb Private Sub FormatListView() Dim li As ListItem For Each li In ListView1.ListItems ' Format amount column li.SubItems(2) = VBMAN.Formater.Data(li.SubItems(2)).ReturnCurrency() ' Format date column li.SubItems(3) = VBMAN.Formater.Data(CDate(li.SubItems(3))).ReturnShortDate() ' Format file size column li.SubItems(4) = VBMAN.Formater.Data(li.SubItems(4)).ReturnFileSize() Next li End Sub ``` ## Best Practices 1. **Chain Calling**: Use `Data(Value).ReturnXXX()` to keep code concise 2. **Type Checking**: Ensure data type is correct before formatting, wrong types return default values 3. **Localization**: Use appropriate currency symbols and date formats based on user region 4. **Consistency**: Use the same formatting method for the same type of data --- --- url: /zh/vbman/global/crypto-hash.md --- # VBMAN.Hash - 哈希计算对象 ## 概述 `VBMAN.Hash` 提供了基于 Windows CryptoAPI 的哈希计算功能，支持 MD5、SHA1、SHA256、SHA384、SHA512 等多种哈希算法。支持字符串、字节数组和文件的哈希计算，输出格式支持十六进制字符串、Base64 和原始字节数组。 ## 核心特性 * **多种算法**: 支持 MD5、SHA1、SHA256、SHA384、SHA512 * **多格式输入**: 支持字符串、字节数组、文件 * **UTF8 支持**: 完美支持 UTF8 编码的中文字符串 * **链式调用**: 流畅的 API 设计 * **灵活输出**: 支持 Hex、Base64、字节数组等多种输出格式 ## 枚举 ### CryptoHashAlgorithm 哈希算法枚举 ```vb Public Enum CryptoHashAlgorithm HASH_ALG_DEFAULT = 0 ' 使用类属性默认算法 (SHA256) HASH_ALG_MD5 = 32771 ' MD5 算法 (128位) HASH_ALG_SHA1 = 32772 ' SHA1 算法 (160位) HASH_ALG_SHA256 = 32780 ' SHA256 算法 (256位) HASH_ALG_SHA384 = 32781 ' SHA384 算法 (384位) HASH_ALG_SHA512 = 32782 ' SHA512 算法 (512位) End Enum ``` ### CryptoStringEncoding 字符串编码枚举 ```vb Public Enum CryptoStringEncoding ENCODING_ANSI = 0 ' ANSI 编码 ENCODING_UTF8 = 1 ' UTF8 编码（默认） End Enum ``` ## 传统调用方法 ### ComputeHash 计算字符串的哈希值（返回十六进制字符串） ```vb Public Function ComputeHash(ByVal Text As String, _ Optional ByVal Algorithm As CryptoHashAlgorithm, _ Optional ByVal Encoding As CryptoStringEncoding = ENCODING_UTF8) As String ``` **参数**: * `Text` - 要哈希的文本字符串 * `Algorithm` - 可选参数，哈希算法，默认使用类属性值 (SHA256) * `Encoding` - 可选参数，字符串编码，默认 UTF8 **返回**: 十六进制格式的哈希字符串 **示例**: ```vb ' MD5 计算（默认 UTF8 编码） Dim md5Result As String md5Result = VBMAN.Hash.ComputeHash("邓伟", HASH_ALG_MD5) Debug.Print md5Result ' 输出: c518f98015a0e6a6b3ea15c5c7f4a8e2 ' MD5 计算（ANSI 编码） md5Result = VBMAN.Hash.ComputeHash("邓伟", HASH_ALG_MD5, ENCODING_ANSI) Debug.Print md5Result ' SHA256 计算 Dim sha256Result As String sha256Result = VBMAN.Hash.ComputeHash("Hello World", HASH_ALG_SHA256) Debug.Print sha256Result ``` ### ComputeHashBytesToHex 计算字节数组的哈希值（返回十六进制字符串） ```vb Public Function ComputeHashBytesToHex(ByRef Data() As Byte, _ Optional ByVal Algorithm As CryptoHashAlgorithm) As String ``` **示例**: ```vb Dim bytes() As Byte bytes = VBMAN.ToolsUtf8.Encode("Hello") Dim hash As String hash = VBMAN.Hash.ComputeHashBytesToHex(bytes, HASH_ALG_MD5) Debug.Print hash ``` ### ComputeHashBytes 计算字节数组的哈希值（返回原始字节数组） ```vb Public Function ComputeHashBytes(ByRef Data() As Byte, _ Optional ByVal Algorithm As CryptoHashAlgorithm) As Byte() ``` **示例**: ```vb Dim bytes() As Byte bytes = VBMAN.ToolsUtf8.Encode("Hello") Dim hashBytes() As Byte hashBytes = VBMAN.Hash.ComputeHashBytes(bytes, HASH_ALG_SHA256) ``` ### ComputeFileHash 计算文件的哈希值（返回十六进制字符串） ```vb Public Function ComputeFileHash(ByVal FilePath As String, _ Optional ByVal Algorithm As CryptoHashAlgorithm) As String ``` **说明**: 直接二进制读取文件内容计算哈希，不进行字符编码处理 **示例**: ```vb ' 计算文件 MD5 Dim fileMd5 As String fileMd5 = VBMAN.Hash.ComputeFileHash("C:\\file.txt", HASH_ALG_MD5) Debug.Print fileMd5 ' 计算文件 SHA256 Dim fileSha256 As String fileSha256 = VBMAN.Hash.ComputeFileHash("C:\\file.txt", HASH_ALG_SHA256) Debug.Print fileSha256 ``` ## 链式调用方法（推荐） ### Mode 设置哈希算法（链式调用入口，可选） ```vb Public Function Mode(ByVal Algorithm As CryptoHashAlgorithm) As cCryptoHash ``` **说明**: 如果不调用此方法，默认使用 `HASH_ALG_SHA256` **示例**: ```vb ' 设置算法为 MD5 VBMAN.Hash.Mode(HASH_ALG_MD5).DataString("hello").ReturnHex() ``` ### DataString 输入字符串数据（链式调用） ```vb Public Function DataString(ByVal Text As String, _ Optional ByVal Encoding As CryptoStringEncoding = ENCODING_UTF8) As cCryptoHash ``` **示例**: ```vb ' 输入 UTF8 字符串 VBMAN.Hash.DataString("你好世界", ENCODING_UTF8).ReturnHex() ' 输入 ANSI 字符串 VBMAN.Hash.DataString("Hello", ENCODING_ANSI).ReturnHex() ``` ### DataBytes 输入字节数组数据（链式调用） ```vb Public Function DataBytes(ByRef Data() As Byte) As cCryptoHash ``` **示例**: ```vb Dim bytes() As Byte bytes = VBMAN.ToolsUtf8.Encode("Hello") VBMAN.Hash.Mode(HASH_ALG_MD5).DataBytes(bytes).ReturnHex() ``` ## 结果返回方法 ### ReturnHex 返回十六进制格式的哈希值（链式调用） ```vb Public Function ReturnHex(Optional ByVal UpperCase As Boolean = False) As String ``` **参数**: * `UpperCase` - 可选参数，是否使用大写字母，默认 False（小写） **示例**: ```vb ' 返回小写 MD5 Dim md5 As String md5 = VBMAN.Hash.Mode(HASH_ALG_MD5).DataString("邓伟").ReturnHex() Debug.Print md5 ' c518f98015a0e6a6b3ea15c5c7f4a8e2 ' 返回大写 MD5 Dim md5Upper As String md5Upper = VBMAN.Hash.Mode(HASH_ALG_MD5).DataString("邓伟").ReturnHex(True) Debug.Print md5Upper ' C518F98015A0E6A6B3EA15C5C7F4A8E2 ``` ### ReturnBase64 返回 Base64 格式的哈希值（链式调用） ```vb Public Function ReturnBase64() As String ``` **示例**: ```vb Dim base64Hash As String base64Hash = VBMAN.Hash.Mode(HASH_ALG_SHA256).DataString("Hello").ReturnBase64() Debug.Print base64Hash ``` ### ReturnBytes 返回字节数组格式的哈希值（链式调用） ```vb Public Function ReturnBytes() As Byte() ``` **示例**: ```vb Dim hashBytes() As Byte hashBytes = VBMAN.Hash.Mode(HASH_ALG_MD5).DataString("Hello").ReturnBytes() ' 遍历字节数组 Dim i As Integer For i = LBound(hashBytes) To UBound(hashBytes) Debug.Print Hex(hashBytes(i)); Next ``` ## 综合示例 ### 示例1: MD5 哈希计算（UTF8 中文支持） ```vb Private Sub MD5Example() ' 基础用法 - 计算 UTF8 字符串的 MD5 Dim result As String ' 中文姓名 MD5 计算 result = VBMAN.Hash("邓伟").Mode(HASH_ALG_MD5).ReturnHex() Debug.Print "邓伟 的 MD5: " & result ' 输出: c518f98015a0e6a6b3ea15c5c7f4a8e2 ' 其他方式实现相同结果 result = VBMAN.Hash.Mode(HASH_ALG_MD5).DataString("邓伟").ReturnHex() Debug.Print result ' 使用传统方法 result = VBMAN.Hash.ComputeHash("邓伟", HASH_ALG_MD5) Debug.Print result End Sub ``` ### 示例2: 多种算法对比 ```vb Private Sub CompareAlgorithms() Dim text As String text = "Hello World" Debug.Print "原文: " & text Debug.Print "MD5: " & VBMAN.Hash.Mode(HASH_ALG_MD5).DataString(text).ReturnHex() Debug.Print "SHA1: " & VBMAN.Hash.Mode(HASH_ALG_SHA1).DataString(text).ReturnHex() Debug.Print "SHA256: " & VBMAN.Hash.Mode(HASH_ALG_SHA256).DataString(text).ReturnHex() Debug.Print "SHA384: " & VBMAN.Hash.Mode(HASH_ALG_SHA384).DataString(text).ReturnHex() Debug.Print "SHA512: " & VBMAN.Hash.Mode(HASH_ALG_SHA512).DataString(text).ReturnHex() End Sub ``` ### 示例3: 密码哈希存储 ```vb Private Function HashPassword(password As String, salt As String) As String ' 组合密码和盐值 Dim saltedPassword As String saltedPassword = password & salt ' 使用 SHA256 计算哈希 Dim hash As String hash = VBMAN.Hash.Mode(HASH_ALG_SHA256).DataString(saltedPassword).ReturnHex() HashPassword = hash End Function Private Sub TestPasswordHash() Dim password As String Dim salt As String Dim hashed As String password = "MySecretPassword" salt = "random_salt_123" hashed = HashPassword(password, salt) Debug.Print "密码哈希: " & hashed End Sub ``` ### 示例4: 文件完整性校验 ```vb Private Function CalculateFileMD5(filePath As String) As String On Error GoTo ErrorHandler ' 计算文件 MD5 Dim md5 As String md5 = VBMAN.Hash.ComputeFileHash(filePath, HASH_ALG_MD5) CalculateFileMD5 = md5 Exit Function ErrorHandler: CalculateFileMD5 = "" End Function Private Sub VerifyFileIntegrity() Dim filePath As String Dim expectedMD5 As String Dim actualMD5 As String filePath = "C:\\important\\document.pdf" expectedMD5 = "a1b2c3d4e5f6..." actualMD5 = CalculateFileMD5(filePath) If LCase(actualMD5) = LCase(expectedMD5) Then Debug.Print "文件校验通过" Else Debug.Print "文件校验失败，可能被篡改" End If End Sub ``` ### 示例5: 批量哈希计算 ```vb Private Sub BatchHashCalculation() Dim items As Variant items = Array("张三", "李四", "王五", "邓伟") Dim i As Integer For i = LBound(items) To UBound(items) Dim name As String name = items(i) ' 计算 MD5 Dim md5 As String md5 = VBMAN.Hash.Mode(HASH_ALG_MD5).DataString(name).ReturnHex() ' 计算 SHA256 Dim sha256 As String sha256 = VBMAN.Hash.Mode(HASH_ALG_SHA256).DataString(name).ReturnHex() Debug.Print "姓名: " & name Debug.Print " MD5: " & md5 Debug.Print " SHA256: " & sha256 Next i End Sub ``` ### 示例6: 数据签名前处理 ```vb Private Function PrepareDataForSignature(data As String, timestamp As String) As String ' 组合数据和 timestamp Dim payload As String payload = data & "|" & timestamp ' 使用 SHA256 计算哈希 Dim hash As String hash = VBMAN.Hash.Mode(HASH_ALG_SHA256).DataString(payload).ReturnHex(True) PrepareDataForSignature = hash End Function Private Sub TestDataSignature() Dim data As String Dim timestamp As String Dim signature As String data = "order_id=12345&amount=100.00" timestamp = CStr(Now()) signature = PrepareDataForSignature(data, timestamp) Debug.Print "数据签名: " & signature End Sub ``` ## 最佳实践 1. **UTF8 中文支持**: 处理中文字符串时，默认使用 UTF8 编码，确保跨平台一致性 2. **算法选择**: * MD5: 速度快，但安全性较低，适合非安全场景（如缓存键、简单校验） * SHA1: 安全性较 MD5 高，但也不推荐用于安全场景 * SHA256/SHA384/SHA512: 安全性高，推荐用于密码、数字签名等安全场景 3. **链式调用**: 推荐使用链式调用方式，代码更清晰 4. **盐值使用**: 密码哈希务必添加随机盐值，防止彩虹表攻击 5. **文件哈希**: 大文件计算时注意内存使用，类库会自动分块处理 ## 常见 MD5 参考值 ```vb ' 空字符串 MD5 Debug.Print VBMAN.Hash.Mode(HASH_ALG_MD5).DataString("").ReturnHex() ' 结果: d41d8cd98f00b204e9800998ecf8427e ' "123456" MD5 Debug.Print VBMAN.Hash.Mode(HASH_ALG_MD5).DataString("123456").ReturnHex() ' 结果: e10adc3949ba59abbe56e057f20f883e ' 中文 "你好" MD5 Debug.Print VBMAN.Hash.Mode(HASH_ALG_MD5).DataString("你好").ReturnHex() ' 结果: 7eca689f0d3389d9dea66ae112e5cfd7 ``` ## 算法输出长度 | 算法 | 输出长度 (Hex) | 输出长度 (Bytes) | |------|---------------|-----------------| | MD5 | 32 字符 | 16 字节 | | SHA1 | 40 字符 | 20 字节 | | SHA256 | 64 字符 | 32 字节 | | SHA384 | 96 字符 | 48 字节 | | SHA512 | 128 字符 | 64 字节 | --- --- url: /en/vbman/global/crypto-hash.md --- # VBMAN.Hash - Hash Calculation Object ## Overview `VBMAN.Hash` provides hash calculation functionality based on Windows CryptoAPI, supporting multiple hash algorithms including MD5, SHA1, SHA256, SHA384, and SHA512. It supports hash calculation for strings, byte arrays, and files, with output formats including hexadecimal strings, Base64, and raw byte arrays. ## Core Features * **Multiple Algorithms**: Supports MD5, SHA1, SHA256, SHA384, SHA512 * **Multi-format Input**: Supports strings, byte arrays, and files * **UTF8 Support**: Perfect support for UTF8 encoded Chinese strings * **Chain Calls**: Fluent API design * **Flexible Output**: Supports Hex, Base64, byte array, and other output formats ## Enumerations ### CryptoHashAlgorithm Hash algorithm enumeration ```vb Public Enum CryptoHashAlgorithm HASH_ALG_DEFAULT = 0 ' Use class default algorithm (SHA256) HASH_ALG_MD5 = 32771 ' MD5 algorithm (128-bit) HASH_ALG_SHA1 = 32772 ' SHA1 algorithm (160-bit) HASH_ALG_SHA256 = 32780 ' SHA256 algorithm (256-bit) HASH_ALG_SHA384 = 32781 ' SHA384 algorithm (384-bit) HASH_ALG_SHA512 = 32782 ' SHA512 algorithm (512-bit) End Enum ``` ### CryptoStringEncoding String encoding enumeration ```vb Public Enum CryptoStringEncoding ENCODING_ANSI = 0 ' ANSI encoding ENCODING_UTF8 = 1 ' UTF8 encoding (default) End Enum ``` ## Traditional Call Methods ### ComputeHash Calculate hash value of a string (returns hexadecimal string) ```vb Public Function ComputeHash(ByVal Text As String, _ Optional ByVal Algorithm As CryptoHashAlgorithm, _ Optional ByVal Encoding As CryptoStringEncoding = ENCODING_UTF8) As String ``` **Parameters**: * `Text` - The text string to hash * `Algorithm` - Optional parameter, hash algorithm, defaults to class property value (SHA256) * `Encoding` - Optional parameter, string encoding, defaults to UTF8 **Returns**: Hexadecimal formatted hash string **Example**: ```vb ' MD5 calculation (default UTF8 encoding) Dim md5Result As String md5Result = VBMAN.Hash.ComputeHash("邓伟", HASH_ALG_MD5) Debug.Print md5Result ' Output: c518f98015a0e6a6b3ea15c5c7f4a8e2 ' MD5 calculation (ANSI encoding) md5Result = VBMAN.Hash.ComputeHash("邓伟", HASH_ALG_MD5, ENCODING_ANSI) Debug.Print md5Result ' SHA256 calculation Dim sha256Result As String sha256Result = VBMAN.Hash.ComputeHash("Hello World", HASH_ALG_SHA256) Debug.Print sha256Result ``` ### ComputeHashBytesToHex Calculate hash value of a byte array (returns hexadecimal string) ```vb Public Function ComputeHashBytesToHex(ByRef Data() As Byte, _ Optional ByVal Algorithm As CryptoHashAlgorithm) As String ``` **Example**: ```vb Dim bytes() As Byte bytes = VBMAN.ToolsUtf8.Encode("Hello") Dim hash As String hash = VBMAN.Hash.ComputeHashBytesToHex(bytes, HASH_ALG_MD5) Debug.Print hash ``` ### ComputeHashBytes Calculate hash value of a byte array (returns raw byte array) ```vb Public Function ComputeHashBytes(ByRef Data() As Byte, _ Optional ByVal Algorithm As CryptoHashAlgorithm) As Byte() ``` **Example**: ```vb Dim bytes() As Byte bytes = VBMAN.ToolsUtf8.Encode("Hello") Dim hashBytes() As Byte hashBytes = VBMAN.Hash.ComputeHashBytes(bytes, HASH_ALG_SHA256) ``` ### ComputeFileHash Calculate hash value of a file (returns hexadecimal string) ```vb Public Function ComputeFileHash(ByVal FilePath As String, _ Optional ByVal Algorithm As CryptoHashAlgorithm) As String ``` **Description**: Directly reads file content in binary mode to calculate hash, without character encoding processing **Example**: ```vb ' Calculate file MD5 Dim fileMd5 As String fileMd5 = VBMAN.Hash.ComputeFileHash("C:\\file.txt", HASH_ALG_MD5) Debug.Print fileMd5 ' Calculate file SHA256 Dim fileSha256 As String fileSha256 = VBMAN.Hash.ComputeFileHash("C:\\file.txt", HASH_ALG_SHA256) Debug.Print fileSha256 ``` ## Chain Call Methods (Recommended) ### Mode Set hash algorithm (chain call entry point, optional) ```vb Public Function Mode(ByVal Algorithm As CryptoHashAlgorithm) As cCryptoHash ``` **Description**: If this method is not called, defaults to `HASH_ALG_SHA256` **Example**: ```vb ' Set algorithm to MD5 VBMAN.Hash.Mode(HASH_ALG_MD5).DataString("hello").ReturnHex() ``` ### DataString Input string data (chain call) ```vb Public Function DataString(ByVal Text As String, _ Optional ByVal Encoding As CryptoStringEncoding = ENCODING_UTF8) As cCryptoHash ``` **Example**: ```vb ' Input UTF8 string VBMAN.Hash.DataString("你好世界", ENCODING_UTF8).ReturnHex() ' Input ANSI string VBMAN.Hash.DataString("Hello", ENCODING_ANSI).ReturnHex() ``` ### DataBytes Input byte array data (chain call) ```vb Public Function DataBytes(ByRef Data() As Byte) As cCryptoHash ``` **Example**: ```vb Dim bytes() As Byte bytes = VBMAN.ToolsUtf8.Encode("Hello") VBMAN.Hash.Mode(HASH_ALG_MD5).DataBytes(bytes).ReturnHex() ``` ## Result Return Methods ### ReturnHex Return hexadecimal formatted hash value (chain call) ```vb Public Function ReturnHex(Optional ByVal UpperCase As Boolean = False) As String ``` **Parameters**: * `UpperCase` - Optional parameter, whether to use uppercase letters, default False (lowercase) **Example**: ```vb ' Return lowercase MD5 Dim md5 As String md5 = VBMAN.Hash.Mode(HASH_ALG_MD5).DataString("邓伟").ReturnHex() Debug.Print md5 ' c518f98015a0e6a6b3ea15c5c7f4a8e2 ' Return uppercase MD5 Dim md5Upper As String md5Upper = VBMAN.Hash.Mode(HASH_ALG_MD5).DataString("邓伟").ReturnHex(True) Debug.Print md5Upper ' C518F98015A0E6A6B3EA15C5C7F4A8E2 ``` ### ReturnBase64 Return Base64 formatted hash value (chain call) ```vb Public Function ReturnBase64() As String ``` **Example**: ```vb Dim base64Hash As String base64Hash = VBMAN.Hash.Mode(HASH_ALG_SHA256).DataString("Hello").ReturnBase64() Debug.Print base64Hash ``` ### ReturnBytes Return byte array formatted hash value (chain call) ```vb Public Function ReturnBytes() As Byte() ``` **Example**: ```vb Dim hashBytes() As Byte hashBytes = VBMAN.Hash.Mode(HASH_ALG_MD5).DataString("Hello").ReturnBytes() ' Iterate through byte array Dim i As Integer For i = LBound(hashBytes) To UBound(hashBytes) Debug.Print Hex(hashBytes(i)); Next ``` ## Comprehensive Examples ### Example 1: MD5 Hash Calculation (UTF8 Chinese Support) ```vb Private Sub MD5Example() ' Basic usage - Calculate MD5 of UTF8 string Dim result As String ' Chinese name MD5 calculation result = VBMAN.Hash("邓伟").Mode(HASH_ALG_MD5).ReturnHex() Debug.Print "MD5 of 邓伟: " & result ' Output: c518f98015a0e6a6b3ea15c5c7f4a8e2 ' Other ways to achieve the same result result = VBMAN.Hash.Mode(HASH_ALG_MD5).DataString("邓伟").ReturnHex() Debug.Print result ' Using traditional method result = VBMAN.Hash.ComputeHash("邓伟", HASH_ALG_MD5) Debug.Print result End Sub ``` ### Example 2: Multiple Algorithms Comparison ```vb Private Sub CompareAlgorithms() Dim text As String text = "Hello World" Debug.Print "Original: " & text Debug.Print "MD5: " & VBMAN.Hash.Mode(HASH_ALG_MD5).DataString(text).ReturnHex() Debug.Print "SHA1: " & VBMAN.Hash.Mode(HASH_ALG_SHA1).DataString(text).ReturnHex() Debug.Print "SHA256: " & VBMAN.Hash.Mode(HASH_ALG_SHA256).DataString(text).ReturnHex() Debug.Print "SHA384: " & VBMAN.Hash.Mode(HASH_ALG_SHA384).DataString(text).ReturnHex() Debug.Print "SHA512: " & VBMAN.Hash.Mode(HASH_ALG_SHA512).DataString(text).ReturnHex() End Sub ``` ### Example 3: Password Hash Storage ```vb Private Function HashPassword(password As String, salt As String) As String ' Combine password and salt value Dim saltedPassword As String saltedPassword = password & salt ' Calculate hash using SHA256 Dim hash As String hash = VBMAN.Hash.Mode(HASH_ALG_SHA256).DataString(saltedPassword).ReturnHex() HashPassword = hash End Function Private Sub TestPasswordHash() Dim password As String Dim salt As String Dim hashed As String password = "MySecretPassword" salt = "random_salt_123" hashed = HashPassword(password, salt) Debug.Print "Password Hash: " & hashed End Sub ``` ### Example 4: File Integrity Verification ```vb Private Function CalculateFileMD5(filePath As String) As String On Error GoTo ErrorHandler ' Calculate file MD5 Dim md5 As String md5 = VBMAN.Hash.ComputeFileHash(filePath, HASH_ALG_MD5) CalculateFileMD5 = md5 Exit Function ErrorHandler: CalculateFileMD5 = "" End Function Private Sub VerifyFileIntegrity() Dim filePath As String Dim expectedMD5 As String Dim actualMD5 As String filePath = "C:\\important\\document.pdf" expectedMD5 = "a1b2c3d4e5f6..." actualMD5 = CalculateFileMD5(filePath) If LCase(actualMD5) = LCase(expectedMD5) Then Debug.Print "File verification passed" Else Debug.Print "File verification failed, may have been tampered with" End If End Sub ``` ### Example 5: Batch Hash Calculation ```vb Private Sub BatchHashCalculation() Dim items As Variant items = Array("张三", "李四", "王五", "邓伟") Dim i As Integer For i = LBound(items) To UBound(items) Dim name As String name = items(i) ' Calculate MD5 Dim md5 As String md5 = VBMAN.Hash.Mode(HASH_ALG_MD5).DataString(name).ReturnHex() ' Calculate SHA256 Dim sha256 As String sha256 = VBMAN.Hash.Mode(HASH_ALG_SHA256).DataString(name).ReturnHex() Debug.Print "Name: " & name Debug.Print " MD5: " & md5 Debug.Print " SHA256: " & sha256 Next i End Sub ``` ### Example 6: Data Pre-processing for Signature ```vb Private Function PrepareDataForSignature(data As String, timestamp As String) As String ' Combine data and timestamp Dim payload As String payload = data & "|" & timestamp ' Calculate hash using SHA256 Dim hash As String hash = VBMAN.Hash.Mode(HASH_ALG_SHA256).DataString(payload).ReturnHex(True) PrepareDataForSignature = hash End Function Private Sub TestDataSignature() Dim data As String Dim timestamp As String Dim signature As String data = "order_id=12345&amount=100.00" timestamp = CStr(Now()) signature = PrepareDataForSignature(data, timestamp) Debug.Print "Data Signature: " & signature End Sub ``` ## Best Practices 1. **UTF8 Chinese Support**: When processing Chinese strings, use UTF8 encoding by default to ensure cross-platform consistency 2. **Algorithm Selection**: * MD5: Fast but low security, suitable for non-security scenarios (e.g., cache keys, simple verification) * SHA1: Higher security than MD5, but also not recommended for security scenarios * SHA256/SHA384/SHA512: High security, recommended for passwords, digital signatures, and other security scenarios 3. **Chain Calls**: Recommended to use chain call method for clearer code 4. **Salt Usage**: Password hashes must include random salt to prevent rainbow table attacks 5. **File Hash**: When calculating hashes for large files, be mindful of memory usage; the class library automatically handles in chunks ## Common MD5 Reference Values ```vb ' Empty string MD5 Debug.Print VBMAN.Hash.Mode(HASH_ALG_MD5).DataString("").ReturnHex() ' Result: d41d8cd98f00b204e9800998ecf8427e ' "123456" MD5 Debug.Print VBMAN.Hash.Mode(HASH_ALG_MD5).DataString("123456").ReturnHex() ' Result: e10adc3949ba59abbe56e057f20f883e ' Chinese "你好" MD5 Debug.Print VBMAN.Hash.Mode(HASH_ALG_MD5).DataString("你好").ReturnHex() ' Result: 7eca689f0d3389d9dea66ae112e5cfd7 ``` ## Algorithm Output Length | Algorithm | Output Length (Hex) | Output Length (Bytes) | |-----------|---------------------|-----------------------| | MD5 | 32 characters | 16 bytes | | SHA1 | 40 characters | 20 bytes | | SHA256 | 64 characters | 32 bytes | | SHA384 | 96 characters | 48 bytes | | SHA512 | 128 characters | 64 bytes | --- --- url: /zh/vbman/global/crypto-hashmac.md --- # VBMAN.HashMAC - HMAC 消息认证码对象 ## 概述 `VBMAN.HashMAC` 提供了 HMAC（Hash-based Message Authentication Code）消息认证码计算功能，支持 HMAC-SHA1 和 HMAC-SHA256 算法。HMAC 使用密钥对数据进行哈希计算，可用于验证数据完整性和身份认证。 ## 核心特性 * **标准算法**: 支持 HMAC-SHA1 和 HMAC-SHA256（RFC 2104 标准） * **密钥灵活**: 支持字符串、Hex、Base64 格式的密钥输入 * **UTF8 支持**: 完美支持 UTF8 编码的中文字符串 * **链式调用**: 流畅的 API 设计 * **多种输出**: 支持 Hex、Base64、字节数组等多种输出格式 ## 枚举 ### HMACAlgorithm HMAC 算法枚举 ```vb Public Enum HMACAlgorithm HMAC_ALG_SHA1 = 32772 ' HMAC-SHA1 算法 HMAC_ALG_SHA256 = 32780 ' HMAC-SHA256 算法（默认） End Enum ``` ### HMACStringEncoding 字符串编码枚举 ```vb Public Enum HMACStringEncoding HMAC_ENCODING_ANSI = 0 ' ANSI 编码 HMAC_ENCODING_UTF8 = 1 ' UTF8 编码（默认） End Enum ``` ### SecretKeyType 密钥输入类型枚举 ```vb Public Enum SecretKeyType SECRET_KEY_STRING = 0 ' 普通字符串密钥 SECRET_KEY_HEX = 1 ' Hex 格式密钥 SECRET_KEY_BASE64 = 2 ' Base64 格式密钥 End Enum ``` ## 传统调用方法 ### SetKey / SetKeyBytes 设置 HMAC 密钥 ```vb ' 从字符串设置密钥 Public Sub SetKey(ByVal KeyString As String, _ Optional ByVal Encoding As HMACStringEncoding = HMAC_ENCODING_UTF8) ' 从字节数组设置密钥 Public Sub SetKeyBytes(ByRef KeyBytes() As Byte) ``` **示例**: ```vb ' 使用字符串密钥 VBMAN.HashMAC.SetKey "my_secret_key" ' 使用 UTF8 编码的密钥 VBMAN.HashMAC.SetKey "密钥", HMAC_ENCODING_UTF8 ' 使用字节数组密钥 Dim keyBytes() As Byte keyBytes = VBMAN.ToolsUtf8.Encode("secret") VBMAN.HashMAC.SetKeyBytes keyBytes ``` ### Compute 计算字符串数据的 HMAC（返回十六进制字符串） ```vb Public Function Compute(ByVal Data As String, _ ByVal KeyString As String, _ Optional ByVal Algorithm As HMACAlgorithm, _ Optional ByVal Encoding As HMACStringEncoding = HMAC_ENCODING_UTF8) As String ``` **参数**: * `Data` - 要签名的数据 * `KeyString` - 密钥字符串 * `Algorithm` - 可选参数，HMAC 算法，默认使用类属性值 (SHA256) * `Encoding` - 可选参数，字符串编码，默认 UTF8 **返回**: 十六进制格式的 HMAC 字符串 **示例**: ```vb ' 使用 HMAC-SHA256 计算 Dim hmac As String hmac = VBMAN.HashMAC.Compute("Hello World", "my_secret_key", HMAC_ALG_SHA256) Debug.Print hmac ' 中文数据 HMAC 计算 hmac = VBMAN.HashMAC.Compute("邓伟", "密钥", HMAC_ALG_SHA256, HMAC_ENCODING_UTF8) Debug.Print hmac ``` ### ComputeBytesToHex 计算字节数组的 HMAC（返回十六进制字符串） ```vb Public Function ComputeBytesToHex(ByRef Data() As Byte, _ ByRef Key() As Byte, _ Optional ByVal Algorithm As HMACAlgorithm) As String ``` **示例**: ```vb Dim dataBytes() As Byte dataBytes = VBMAN.ToolsUtf8.Encode("Hello") Dim keyBytes() As Byte keyBytes = VBMAN.ToolsUtf8.Encode("secret") Dim hmac As String hmac = VBMAN.HashMAC.ComputeBytesToHex(dataBytes, keyBytes, HMAC_ALG_SHA256) Debug.Print hmac ``` ### ComputeBytes 计算字节数组的 HMAC（返回字节数组） ```vb Public Function ComputeBytes(ByRef Data() As Byte, _ ByRef Key() As Byte, _ Optional ByVal Algorithm As HMACAlgorithm) As Byte() ``` **示例**: ```vb Dim dataBytes() As Byte dataBytes = VBMAN.ToolsUtf8.Encode("Hello") Dim keyBytes() As Byte keyBytes = VBMAN.ToolsUtf8.Encode("secret") Dim hmacBytes() As Byte hmacBytes = VBMAN.HashMAC.ComputeBytes(dataBytes, keyBytes, HMAC_ALG_SHA256) ``` ## 链式调用方法（推荐） ### Mode 设置 HMAC 算法（链式调用） ```vb Public Function Mode(ByVal Algorithm As HMACAlgorithm) As cCryptoHMAC ``` **示例**: ```vb ' 设置算法为 HMAC-SHA256 VBMAN.HashMAC.Mode(HMAC_ALG_SHA256).Secret("key").DataString("data").ReturnHex() ``` ### Secret 设置密钥（链式调用） ```vb Public Function Secret(ByVal KeyString As String, _ Optional ByVal KeyType As SecretKeyType = SECRET_KEY_STRING, _ Optional ByVal Encoding As HMACStringEncoding = HMAC_ENCODING_UTF8) As cCryptoHMAC ``` **参数**: * `KeyString` - 密钥字符串 * `KeyType` - 密钥输入类型（STRING/HEX/BASE64），默认 STRING * `Encoding` - 字符串编码，默认 UTF8 **示例**: ```vb ' 普通字符串密钥 VBMAN.HashMAC.Secret("my_secret_key").DataString("Hello").ReturnHex() ' Hex 格式密钥 VBMAN.HashMAC.Secret("6B6579", SECRET_KEY_HEX).DataString("Hello").ReturnHex() ' Base64 格式密钥 VBMAN.HashMAC.Secret("a2V5", SECRET_KEY_BASE64).DataString("Hello").ReturnHex() ``` ### SecretBytes 从字节数组设置密钥（链式调用） ```vb Public Function SecretBytes(ByRef KeyBytes() As Byte) As cCryptoHMAC ``` **示例**: ```vb Dim keyBytes() As Byte keyBytes = VBMAN.ToolsUtf8.Encode("secret") VBMAN.HashMAC.SecretBytes(keyBytes).DataString("Hello").ReturnHex() ``` ### DataString 输入字符串数据（链式调用） ```vb Public Function DataString(ByVal Text As String, _ Optional ByVal Encoding As HMACStringEncoding = HMAC_ENCODING_UTF8) As cCryptoHMAC ``` **示例**: ```vb ' 输入 UTF8 字符串 VBMAN.HashMAC.Secret("key").DataString("你好世界", HMAC_ENCODING_UTF8).ReturnHex() ' 输入 ANSI 字符串 VBMAN.HashMAC.Secret("key").DataString("Hello", HMAC_ENCODING_ANSI).ReturnHex() ``` ### DataBytes 输入字节数组数据（链式调用） ```vb Public Function DataBytes(ByRef Data() As Byte) As cCryptoHMAC ``` **示例**: ```vb Dim dataBytes() As Byte dataBytes = VBMAN.ToolsUtf8.Encode("Hello") VBMAN.HashMAC.Secret("key").DataBytes(dataBytes).ReturnHex() ``` ## 结果返回方法 ### ReturnHex 返回十六进制格式的 HMAC（链式调用） ```vb Public Function ReturnHex(Optional ByVal UpperCase As Boolean = False) As String ``` **参数**: * `UpperCase` - 可选参数，是否使用大写字母，默认 False（小写） **示例**: ```vb ' 返回小写 HMAC Dim hmac As String hmac = VBMAN.HashMAC.Mode(HMAC_ALG_SHA256).Secret("key").DataString("邓伟").ReturnHex() Debug.Print hmac ' 返回大写 HMAC Dim hmacUpper As String hmacUpper = VBMAN.HashMAC.Mode(HMAC_ALG_SHA256).Secret("key").DataString("邓伟").ReturnHex(True) Debug.Print hmacUpper ``` ### ReturnBase64 返回 Base64 格式的 HMAC（链式调用） ```vb Public Function ReturnBase64() As String ``` **示例**: ```vb Dim base64Hmac As String base64Hmac = VBMAN.HashMAC.Mode(HMAC_ALG_SHA256).Secret("key").DataString("Hello").ReturnBase64() Debug.Print base64Hmac ``` ### ReturnBytes 返回字节数组格式的 HMAC（链式调用） ```vb Public Function ReturnBytes() As Byte() ``` **示例**: ```vb Dim hmacBytes() As Byte hmacBytes = VBMAN.HashMAC.Mode(HMAC_ALG_SHA256).Secret("key").DataString("Hello").ReturnBytes() ' 遍历字节数组 Dim i As Integer For i = LBound(hmacBytes) To UBound(hmacBytes) Debug.Print Hex(hmacBytes(i)); Next ``` ## 综合示例 ### 示例1: 基础 HMAC 计算（UTF8 中文支持） ```vb Private Sub BasicHMACExample() Dim key As String Dim data As String Dim hmac As String ' 中文密钥和数据 key = "我的密钥" data = "邓伟" ' HMAC-SHA256 计算（默认 UTF8 编码） hmac = VBMAN.HashMAC.Mode(HMAC_ALG_SHA256).Secret(key).DataString(data).ReturnHex() Debug.Print "HMAC-SHA256: " & hmac ' HMAC-SHA1 计算 hmac = VBMAN.HashMAC.Mode(HMAC_ALG_SHA1).Secret(key).DataString(data).ReturnHex() Debug.Print "HMAC-SHA1: " & hmac ' 使用传统方法 hmac = VBMAN.HashMAC.Compute(data, key, HMAC_ALG_SHA256) Debug.Print "传统方法: " & hmac End Sub ``` ### 示例2: API 请求签名 ```vb Private Function GenerateAPISignature(apiKey As String, apiSecret As String, _ params As String, timestamp As String) As String ' 构建待签名数据 Dim dataToSign As String dataToSign = apiKey & "|" & params & "|" & timestamp ' 使用 HMAC-SHA256 计算签名 Dim signature As String signature = VBMAN.HashMAC.Mode(HMAC_ALG_SHA256).Secret(apiSecret).DataString(dataToSign).ReturnHex(True) GenerateAPISignature = signature End Function Private Sub TestAPIRequest() Dim apiKey As String Dim apiSecret As String Dim params As String Dim timestamp As String Dim signature As String apiKey = "AKIAIOSFODNN7EXAMPLE" apiSecret = "wJalrXUtnFEMI/K7MDENG/bPxRfiCYEXAMPLEKEY" params = "action=getUser&id=12345" timestamp = CStr(Now()) signature = GenerateAPISignature(apiKey, apiSecret, params, timestamp) Debug.Print "API Key: " & apiKey Debug.Print "Timestamp: " & timestamp Debug.Print "Signature: " & signature End Sub ``` ### 示例3: Webhook 签名验证 ```vb Private Function VerifyWebhookSignature(payload As String, signature As String, secret As String) As Boolean ' 计算期望的签名 Dim expectedSignature As String expectedSignature = VBMAN.HashMAC.Mode(HMAC_ALG_SHA256).Secret(secret).DataString(payload).ReturnHex() ' 比较签名（不区分大小写） VerifyWebhookSignature = (LCase(expectedSignature) = LCase(signature)) End Function Private Sub TestWebhookVerification() Dim secret As String Dim payload As String Dim receivedSignature As String Dim isValid As Boolean secret = "webhook_secret_key" payload = "{event:user.created,user_id:12345}" receivedSignature = "a1b2c3d4..." ' 接收到的签名 isValid = VerifyWebhookSignature(payload, receivedSignature, secret) If isValid Then Debug.Print "Webhook 签名验证通过" Else Debug.Print "Webhook 签名验证失败" End If End Sub ``` ### 示例4: 消息完整性校验 ```vb Private Function CreateMessageWithMAC(message As String, key As String) As String ' 计算 HMAC Dim mac As String mac = VBMAN.HashMAC.Mode(HMAC_ALG_SHA256).Secret(key).DataString(message).ReturnHex() ' 将 MAC 附加到消息中 CreateMessageWithMAC = message & "|" & mac End Function Private Function VerifyAndExtractMessage(messageWithMAC As String, key As String) As String On Error GoTo ErrorHandler ' 分离消息和 MAC Dim parts() As String parts = Split(messageWithMAC, "|") If UBound(parts) <> 1 Then VerifyAndExtractMessage = "" Exit Function End If Dim message As String Dim receivedMAC As String message = parts(0) receivedMAC = parts(1) ' 重新计算 MAC Dim calculatedMAC As String calculatedMAC = VBMAN.HashMAC.Mode(HMAC_ALG_SHA256).Secret(key).DataString(message).ReturnHex() ' 验证 MAC If LCase(calculatedMAC) = LCase(receivedMAC) Then VerifyAndExtractMessage = message Else VerifyAndExtractMessage = "" ' 验证失败 End If Exit Function ErrorHandler: VerifyAndExtractMessage = "" End Function Private Sub TestMessageIntegrity() Dim key As String Dim originalMessage As String Dim messageWithMAC As String Dim extractedMessage As String key = "shared_secret_key" originalMessage = "重要数据:转账金额1000元" ' 发送方创建带 MAC 的消息 messageWithMAC = CreateMessageWithMAC(originalMessage, key) Debug.Print "带 MAC 的消息: " & messageWithMAC ' 接收方验证并提取消息 extractedMessage = VerifyAndExtractMessage(messageWithMAC, key) If extractedMessage <> "" Then Debug.Print "消息验证通过: " & extractedMessage Else Debug.Print "消息验证失败" End If End Sub ``` ## 最佳实践 1. **密钥安全**: HMAC 密钥应安全存储，不要硬编码在代码中 2. **算法选择**: 推荐使用 HMAC-SHA256，安全性更高 3. **UTF8 编码**: 处理中文字符串时，默认使用 UTF8 编码 4. **密钥长度**: 密钥长度建议至少 32 字节（256位） 5. **签名比较**: 比较 HMAC 值时使用恒定时间比较，防止时序攻击 6. **链式调用**: 推荐使用链式调用方式，代码更清晰 ## HMAC vs 普通哈希 | 特性 | HMAC | 普通哈希 (MD5/SHA) | |------|------|-------------------| | 密钥 | 需要密钥 | 不需要密钥 | | 用途 | 身份认证、完整性校验 | 数据校验、指纹 | | 安全性 | 高（依赖密钥） | 中（仅防篡改） | | 应用场景 | API 签名、Token | 文件校验、缓存键 | ## 常见应用场景 1. **API 请求签名**: 验证请求来源和完整性 2. **Webhook 验证**: 确认回调通知的真实性 3. **消息认证**: 确保消息未被篡改 4. **Token 生成**: 创建带签名的临时令牌 5. **文件传输**: 验证传输文件的完整性 --- --- url: /en/vbman/global/crypto-hashmac.md --- # VBMAN.HashMAC - HMAC Message Authentication Code Object ## Overview `VBMAN.HashMAC` provides HMAC (Hash-based Message Authentication Code) calculation functionality, supporting HMAC-SHA1 and HMAC-SHA256 algorithms. HMAC uses a secret key to hash data, which can be used for data integrity verification and authentication. ## Core Features * **Standard Algorithms**: Supports HMAC-SHA1 and HMAC-SHA256 (RFC 2104 standard) * **Flexible Key**: Supports key input in string, Hex, and Base64 formats * **UTF8 Support**: Perfect support for UTF8 encoded Chinese strings * **Chain Calls**: Fluent API design * **Multiple Outputs**: Supports Hex, Base64, byte array, and other output formats ## Enumerations ### HMACAlgorithm HMAC algorithm enumeration ```vb Public Enum HMACAlgorithm HMAC_ALG_SHA1 = 32772 ' HMAC-SHA1 algorithm HMAC_ALG_SHA256 = 32780 ' HMAC-SHA256 algorithm (default) End Enum ``` ### HMACStringEncoding String encoding enumeration ```vb Public Enum HMACStringEncoding HMAC_ENCODING_ANSI = 0 ' ANSI encoding HMAC_ENCODING_UTF8 = 1 ' UTF8 encoding (default) End Enum ``` ### SecretKeyType Secret key input type enumeration ```vb Public Enum SecretKeyType SECRET_KEY_STRING = 0 ' Plain string key SECRET_KEY_HEX = 1 ' Hex format key SECRET_KEY_BASE64 = 2 ' Base64 format key End Enum ``` ## Traditional Call Methods ### SetKey / SetKeyBytes Set HMAC secret key ```vb ' Set key from string Public Sub SetKey(ByVal KeyString As String, _ Optional ByVal Encoding As HMACStringEncoding = HMAC_ENCODING_UTF8) ' Set key from byte array Public Sub SetKeyBytes(ByRef KeyBytes() As Byte) ``` **Example**: ```vb ' Use string key VBMAN.HashMAC.SetKey "my_secret_key" ' Use UTF8 encoded key VBMAN.HashMAC.SetKey "密钥", HMAC_ENCODING_UTF8 ' Use byte array key Dim keyBytes() As Byte keyBytes = VBMAN.ToolsUtf8.Encode("secret") VBMAN.HashMAC.SetKeyBytes keyBytes ``` ### Compute Calculate HMAC of string data (returns hexadecimal string) ```vb Public Function Compute(ByVal Data As String, _ ByVal KeyString As String, _ Optional ByVal Algorithm As HMACAlgorithm, _ Optional ByVal Encoding As HMACStringEncoding = HMAC_ENCODING_UTF8) As String ``` **Parameters**: * `Data` - The data to sign * `KeyString` - The key string * `Algorithm` - Optional parameter, HMAC algorithm, defaults to class property value (SHA256) * `Encoding` - Optional parameter, string encoding, defaults to UTF8 **Returns**: Hexadecimal formatted HMAC string **Example**: ```vb ' Calculate using HMAC-SHA256 Dim hmac As String hmac = VBMAN.HashMAC.Compute("Hello World", "my_secret_key", HMAC_ALG_SHA256) Debug.Print hmac ' Chinese data HMAC calculation hmac = VBMAN.HashMAC.Compute("邓伟", "密钥", HMAC_ALG_SHA256, HMAC_ENCODING_UTF8) Debug.Print hmac ``` ### ComputeBytesToHex Calculate HMAC of byte array (returns hexadecimal string) ```vb Public Function ComputeBytesToHex(ByRef Data() As Byte, _ ByRef Key() As Byte, _ Optional ByVal Algorithm As HMACAlgorithm) As String ``` **Example**: ```vb Dim dataBytes() As Byte dataBytes = VBMAN.ToolsUtf8.Encode("Hello") Dim keyBytes() As Byte keyBytes = VBMAN.ToolsUtf8.Encode("secret") Dim hmac As String hmac = VBMAN.HashMAC.ComputeBytesToHex(dataBytes, keyBytes, HMAC_ALG_SHA256) Debug.Print hmac ``` ### ComputeBytes Calculate HMAC of byte array (returns byte array) ```vb Public Function ComputeBytes(ByRef Data() As Byte, _ ByRef Key() As Byte, _ Optional ByVal Algorithm As HMACAlgorithm) As Byte() ``` **Example**: ```vb Dim dataBytes() As Byte dataBytes = VBMAN.ToolsUtf8.Encode("Hello") Dim keyBytes() As Byte keyBytes = VBMAN.ToolsUtf8.Encode("secret") Dim hmacBytes() As Byte hmacBytes = VBMAN.HashMAC.ComputeBytes(dataBytes, keyBytes, HMAC_ALG_SHA256) ``` ## Chain Call Methods (Recommended) ### Mode Set HMAC algorithm (chain call) ```vb Public Function Mode(ByVal Algorithm As HMACAlgorithm) As cCryptoHMAC ``` **Example**: ```vb ' Set algorithm to HMAC-SHA256 VBMAN.HashMAC.Mode(HMAC_ALG_SHA256).Secret("key").DataString("data").ReturnHex() ``` ### Secret Set secret key (chain call) ```vb Public Function Secret(ByVal KeyString As String, _ Optional ByVal KeyType As SecretKeyType = SECRET_KEY_STRING, _ Optional ByVal Encoding As HMACStringEncoding = HMAC_ENCODING_UTF8) As cCryptoHMAC ``` **Parameters**: * `KeyString` - The key string * `KeyType` - Key input type (STRING/HEX/BASE64), default STRING * `Encoding` - String encoding, default UTF8 **Example**: ```vb ' Plain string key VBMAN.HashMAC.Secret("my_secret_key").DataString("Hello").ReturnHex() ' Hex format key VBMAN.HashMAC.Secret("6B6579", SECRET_KEY_HEX).DataString("Hello").ReturnHex() ' Base64 format key VBMAN.HashMAC.Secret("a2V5", SECRET_KEY_BASE64).DataString("Hello").ReturnHex() ``` ### SecretBytes Set key from byte array (chain call) ```vb Public Function SecretBytes(ByRef KeyBytes() As Byte) As cCryptoHMAC ``` **Example**: ```vb Dim keyBytes() As Byte keyBytes = VBMAN.ToolsUtf8.Encode("secret") VBMAN.HashMAC.SecretBytes(keyBytes).DataString("Hello").ReturnHex() ``` ### DataString Input string data (chain call) ```vb Public Function DataString(ByVal Text As String, _ Optional ByVal Encoding As HMACStringEncoding = HMAC_ENCODING_UTF8) As cCryptoHMAC ``` **Example**: ```vb ' Input UTF8 string VBMAN.HashMAC.Secret("key").DataString("你好世界", HMAC_ENCODING_UTF8).ReturnHex() ' Input ANSI string VBMAN.HashMAC.Secret("key").DataString("Hello", HMAC_ENCODING_ANSI).ReturnHex() ``` ### DataBytes Input byte array data (chain call) ```vb Public Function DataBytes(ByRef Data() As Byte) As cCryptoHMAC ``` **Example**: ```vb Dim dataBytes() As Byte dataBytes = VBMAN.ToolsUtf8.Encode("Hello") VBMAN.HashMAC.Secret("key").DataBytes(dataBytes).ReturnHex() ``` ## Result Return Methods ### ReturnHex Return hexadecimal formatted HMAC (chain call) ```vb Public Function ReturnHex(Optional ByVal UpperCase As Boolean = False) As String ``` **Parameters**: * `UpperCase` - Optional parameter, whether to use uppercase letters, default False (lowercase) **Example**: ```vb ' Return lowercase HMAC Dim hmac As String hmac = VBMAN.HashMAC.Mode(HMAC_ALG_SHA256).Secret("key").DataString("邓伟").ReturnHex() Debug.Print hmac ' Return uppercase HMAC Dim hmacUpper As String hmacUpper = VBMAN.HashMAC.Mode(HMAC_ALG_SHA256).Secret("key").DataString("邓伟").ReturnHex(True) Debug.Print hmacUpper ``` ### ReturnBase64 Return Base64 formatted HMAC (chain call) ```vb Public Function ReturnBase64() As String ``` **Example**: ```vb Dim base64Hmac As String base64Hmac = VBMAN.HashMAC.Mode(HMAC_ALG_SHA256).Secret("key").DataString("Hello").ReturnBase64() Debug.Print base64Hmac ``` ### ReturnBytes Return byte array formatted HMAC (chain call) ```vb Public Function ReturnBytes() As Byte() ``` **Example**: ```vb Dim hmacBytes() As Byte hmacBytes = VBMAN.HashMAC.Mode(HMAC_ALG_SHA256).Secret("key").DataString("Hello").ReturnBytes() ' Iterate through byte array Dim i As Integer For i = LBound(hmacBytes) To UBound(hmacBytes) Debug.Print Hex(hmacBytes(i)); Next ``` ## Comprehensive Examples ### Example 1: Basic HMAC Calculation (UTF8 Chinese Support) ```vb Private Sub BasicHMACExample() Dim key As String Dim data As String Dim hmac As String ' Chinese key and data key = "我的密钥" data = "邓伟" ' HMAC-SHA256 calculation (default UTF8 encoding) hmac = VBMAN.HashMAC.Mode(HMAC_ALG_SHA256).Secret(key).DataString(data).ReturnHex() Debug.Print "HMAC-SHA256: " & hmac ' HMAC-SHA1 calculation hmac = VBMAN.HashMAC.Mode(HMAC_ALG_SHA1).Secret(key).DataString(data).ReturnHex() Debug.Print "HMAC-SHA1: " & hmac ' Using traditional method hmac = VBMAN.HashMAC.Compute(data, key, HMAC_ALG_SHA256) Debug.Print "Traditional method: " & hmac End Sub ``` ### Example 2: API Request Signature ```vb Private Function GenerateAPISignature(apiKey As String, apiSecret As String, _ params As String, timestamp As String) As String ' Build data to sign Dim dataToSign As String dataToSign = apiKey & "|" & params & "|" & timestamp ' Calculate signature using HMAC-SHA256 Dim signature As String signature = VBMAN.HashMAC.Mode(HMAC_ALG_SHA256).Secret(apiSecret).DataString(dataToSign).ReturnHex(True) GenerateAPISignature = signature End Function Private Sub TestAPIRequest() Dim apiKey As String Dim apiSecret As String Dim params As String Dim timestamp As String Dim signature As String apiKey = "AKIAIOSFODNN7EXAMPLE" apiSecret = "wJalrXUtnFEMI/K7MDENG/bPxRfiCYEXAMPLEKEY" params = "action=getUser&id=12345" timestamp = CStr(Now()) signature = GenerateAPISignature(apiKey, apiSecret, params, timestamp) Debug.Print "API Key: " & apiKey Debug.Print "Timestamp: " & timestamp Debug.Print "Signature: " & signature End Sub ``` ### Example 3: Webhook Signature Verification ```vb Private Function VerifyWebhookSignature(payload As String, signature As String, secret As String) As Boolean ' Calculate expected signature Dim expectedSignature As String expectedSignature = VBMAN.HashMAC.Mode(HMAC_ALG_SHA256).Secret(secret).DataString(payload).ReturnHex() ' Compare signatures (case-insensitive) VerifyWebhookSignature = (LCase(expectedSignature) = LCase(signature)) End Function Private Sub TestWebhookVerification() Dim secret As String Dim payload As String Dim receivedSignature As String Dim isValid As Boolean secret = "webhook_secret_key" payload = "{event:user.created,user_id:12345}" receivedSignature = "a1b2c3d4..." ' Received signature isValid = VerifyWebhookSignature(payload, receivedSignature, secret) If isValid Then Debug.Print "Webhook signature verification passed" Else Debug.Print "Webhook signature verification failed" End If End Sub ``` ### Example 4: Message Integrity Verification ```vb Private Function CreateMessageWithMAC(message As String, key As String) As String ' Calculate HMAC Dim mac As String mac = VBMAN.HashMAC.Mode(HMAC_ALG_SHA256).Secret(key).DataString(message).ReturnHex() ' Append MAC to message CreateMessageWithMAC = message & "|" & mac End Function Private Function VerifyAndExtractMessage(messageWithMAC As String, key As String) As String On Error GoTo ErrorHandler ' Separate message and MAC Dim parts() As String parts = Split(messageWithMAC, "|") If UBound(parts) <> 1 Then VerifyAndExtractMessage = "" Exit Function End If Dim message As String Dim receivedMAC As String message = parts(0) receivedMAC = parts(1) ' Recalculate MAC Dim calculatedMAC As String calculatedMAC = VBMAN.HashMAC.Mode(HMAC_ALG_SHA256).Secret(key).DataString(message).ReturnHex() ' Verify MAC If LCase(calculatedMAC) = LCase(receivedMAC) Then VerifyAndExtractMessage = message Else VerifyAndExtractMessage = "" ' Verification failed End If Exit Function ErrorHandler: VerifyAndExtractMessage = "" End Function Private Sub TestMessageIntegrity() Dim key As String Dim originalMessage As String Dim messageWithMAC As String Dim extractedMessage As String key = "shared_secret_key" originalMessage = "Important data: Transfer amount 1000 yuan" ' Sender creates message with MAC messageWithMAC = CreateMessageWithMAC(originalMessage, key) Debug.Print "Message with MAC: " & messageWithMAC ' Receiver verifies and extracts message extractedMessage = VerifyAndExtractMessage(messageWithMAC, key) If extractedMessage <> "" Then Debug.Print "Message verification passed: " & extractedMessage Else Debug.Print "Message verification failed" End If End Sub ``` ## Best Practices 1. **Key Security**: HMAC keys should be stored securely, do not hardcode them in code 2. **Algorithm Selection**: HMAC-SHA256 is recommended for higher security 3. **UTF8 Encoding**: Use UTF8 encoding by default when processing Chinese strings 4. **Key Length**: Key length should be at least 32 bytes (256 bits) 5. **Signature Comparison**: Use constant-time comparison when comparing HMAC values to prevent timing attacks 6. **Chain Calls**: Recommended to use chain call method for clearer code ## HMAC vs Regular Hash | Feature | HMAC | Regular Hash (MD5/SHA) | |---------|------|------------------------| | Key | Requires key | No key required | | Purpose | Authentication, integrity verification | Data verification, fingerprinting | | Security | High (depends on key) | Medium (tamper-proof only) | | Use Cases | API signatures, Tokens | File verification, Cache keys | ## Common Application Scenarios 1. **API Request Signing**: Verify request source and integrity 2. **Webhook Verification**: Confirm authenticity of callback notifications 3. **Message Authentication**: Ensure messages have not been tampered with 4. **Token Generation**: Create signed temporary tokens 5. **File Transfer**: Verify integrity of transferred files --- --- url: /zh/vbman/global/httpclient.md --- # VBMAN.HttpClient - HTTP 客户端对象 ## 概述 `VBMAN.HttpClient` 提供了 HTTP 请求功能，支持 GET、POST 等多种请求方法，以及请求头设置、Cookie 管理等特性。 ## 核心特性 * **多方法支持**: GET、POST、PUT、DELETE 等 HTTP 方法 * **SSL/HTTPS**: 支持安全的 HTTPS 请求 * **自动重定向**: 自动处理 3xx 重定向 * **Cookie 管理**: 自动解析和设置 Cookies，请求时自动携带 * **超时设置**: 可配置连接和读取超时 * **链式调用**: 流畅的 API 设计 ## 属性 | 属性 | 类型 | 说明 | | -------------------- | ---------- | --------------------------------------- | | `RequestHeaders` | Dictionary | 请求头字典 | | `RequestContentType` | String | 请求 Content-Type | | `RequestChartSet` | String | 请求字符集 | | `RequestTimeOut` | Long | 超时时间（毫秒） | | `ResponseHeaders` | Dictionary | 响应头字典 | | `Cookies` | Dictionary | Cookie 字典（自动解析，请求时自动携带） | | `StatusCode` | Long | HTTP 响应状态码（只读） | | `StatusText` | String | HTTP 响应状态文本（只读） | | `ResponseRaw` | Variant | 原始响应内容 | | `LastError` | String | 最后错误信息 | | `RequestDataJson` | cJson | JSON 请求数据对象 | | `RequestDataForm` | Dictionary | 表单数据字典 | | `RequestDataQuery` | Dictionary | URL 参数字典 | ## 方法 ### SendGet 发送 GET 请求 ```vb Public Function SendGet(ByVal url As String, Optional Body As String) As cHttpClient ``` **示例**: ```vb VBMAN.HttpClient.SendGet("https://api.example.com/users") ``` ### SendPost 发送 POST 请求 ```vb Public Function SendPost(ByVal url As String, Optional Body As String) As cHttpClient ``` **示例**: ```vb VBMAN.HttpClient.SendPost("https://api.example.com/users", "name=test&age=20") ``` ### SendPut 发送 PUT 请求 ```vb Public Function SendPut(ByVal url As String, Optional Body As String) As cHttpClient ``` ### SendDelete 发送 DELETE 请求 ```vb Public Function SendDelete(ByVal url As String, Optional Body As String) As cHttpClient ``` ### SendOptions 发送 OPTIONS 请求 ```vb Public Function SendOptions(ByVal url As String, Optional Body As String) As cHttpClient ``` ### Send / Fetch 通用请求方法（底层方法） ```vb Public Function Send(Method As EnumRequestMethod, ByVal url As String, Optional Body As String) As cHttpClient Public Function Fetch(Method As EnumRequestMethod, ByVal url As String, Optional Body As String) As cHttpClient ``` ### SetRequestContentType 设置请求 Content-Type ```vb Public Function SetRequestContentType(ReqType As EnumRequestContentType, Optional ContentType As String) As String ``` **请求类型枚举**: * `ReqJson` - application/json * `ReqFormUrlEncoded` - application/x-www-form-urlencoded * `ReqFormMultipart` - multipart/form-data * `ReqTextPlain` - text/plain * `ReqTextHtml` - text/html ### SetCookies 设置 Cookie（支持 `"name=value; name2=value2"` 格式自动解析） ```vb Public Function SetCookies(ByVal Value As String) As cHttpClient ``` **示例**: ```vb VBMAN.HttpClient.SetCookies("sessionid=abc123; user=admin") ' Cookie 在后续请求中自动携带 ``` ### Async 设置异步模式 ```vb Public Function Async(Bool As Boolean) As cHttpClient ``` ### ShowPage 用默认浏览器打开网页 ```vb Public Sub ShowPage(url As String) ``` ## 综合示例 ### 示例1: GET 请求 ```vb Private Sub GetUserList() With VBMAN.HttpClient .SendGet("https://jsonplaceholder.typicode.com/users") If .LastError = "" Then ' 解析 JSON 响应 Dim json As cJson Set json = VBMAN.Json.Decode(.ResponseRaw) Debug.Print "获取成功" Else MsgBox "请求失败: " & .LastError End If End With End Sub ``` ### 示例2: POST 请求（JSON） ```vb Private Sub CreateUser(name As String, email As String) With VBMAN.HttpClient ' 设置 Content-Type .SetRequestContentType ReqJson ' 构建 JSON 请求体 With .RequestDataJson .Item("name") = name .Item("email") = email End With .SendPost "https://api.example.com/users", .RequestDataJson.Encode If .LastError = "" Then Debug.Print "创建成功" End If End With End Sub ``` ### 示例3: 表单提交 ```vb Private Sub SubmitForm(username As String, password As String) With VBMAN.HttpClient ' 设置表单数据 .RequestDataForm("username") = username .RequestDataForm("password") = password ' 转换为表单格式并发送 .SendPost "https://api.example.com/login", VBMAN.ToolsHttp.MakeContent(.RequestDataForm) End With End Sub ``` ### 示例4: 带认证的请求 ```vb Private Sub ApiRequestWithAuth() With VBMAN.HttpClient ' 设置请求头 .RequestHeaders("Authorization") = "Bearer " & GetAccessToken() .RequestHeaders("X-Request-ID") = VBMAN.ToolsStr.GetGUID() .SendGet "https://api.example.com/protected" If .LastError = "" Then ProcessResponse .ResponseRaw End If End With End Sub ``` ### 示例5: URL 参数 ```vb Private Sub SearchUsers(keyword As String) With VBMAN.HttpClient ' 添加 URL 参数 .RequestDataQuery("q") = keyword .RequestDataQuery("page") = 1 .RequestDataQuery("limit") = 20 .SendGet "https://api.example.com/search" End With End Sub ``` ## 事件 ### OnResponseFinished 异步请求响应完成时触发（仅 HTTP 2xx 响应）。 ```vb Public Event OnResponseFinished() ``` ### OnError 异步请求发生错误时触发（包括网络错误和 HTTP 4xx/5xx 响应）。 ```vb Public Event OnError(ByVal ErrorNumber As Long, ByVal ErrorDescription As String) ``` ## 最佳实践 1. **超时设置**: 根据网络情况设置合理的超时时间 2. **错误处理**: 始终检查 LastError，异步模式使用 OnError 事件 3. **HTTPS 优先**: 敏感数据始终使用 HTTPS 4. **请求头管理**: 使用 RequestHeaders 字典设置自定义头 5. **编码处理**: 注意请求和响应的字符编码 6. **Cookie 管理**: 使用 SetCookies 或直接操作 Cookies 字典，请求时自动携带 --- --- url: /en/vbman/global/httpclient.md --- # VBMAN.HttpClient - HTTP Client Object ## Overview `VBMAN.HttpClient` provides HTTP request functionality, supporting GET, POST and other request methods, as well as request header settings, Cookie management, etc. ## Core Features * **Multiple Method Support**: GET, POST, PUT, DELETE and other HTTP methods * **SSL/HTTPS**: Supports secure HTTPS requests * **Auto Redirect**: Automatically handles 3xx redirects * **Cookie Management**: Manage Cookies through RequestHeaders * **Timeout Settings**: Configurable connection and read timeouts * **Chain Calling**: Fluent API design ## Properties | Property | Type | Description | | -------------------- | ---------- | --------------------------- | | `RequestHeaders` | Dictionary | Request headers dictionary | | `RequestContentType` | String | Request Content-Type | | `RequestChartSet` | String | Request charset | | `RequestTimeOut` | Long | Timeout (milliseconds) | | `ResponseHeaders` | Dictionary | Response headers dictionary | | `Cookies` | Dictionary | Cookie dictionary | | `ResponseRaw` | Variant | Raw response content | | `LastError` | String | Last error message | | `RequestDataJson` | cJson | JSON request data object | | `RequestDataForm` | Dictionary | Form data dictionary | | `RequestDataQuery` | Dictionary | URL parameter dictionary | ## Methods ### SendGet Send GET request ```vb Public Function SendGet(ByVal url As String, Optional Body As String) As cHttpClient ``` **Example**: ```vb VBMAN.HttpClient.SendGet("https://api.example.com/users") ``` ### SendPost Send POST request ```vb Public Function SendPost(ByVal url As String, Optional Body As String) As cHttpClient ``` **Example**: ```vb VBMAN.HttpClient.SendPost("https://api.example.com/users", "name=test&age=20") ``` ### SendPut Send PUT request ```vb Public Function SendPut(ByVal url As String, Optional Body As String) As cHttpClient ``` ### SendDelete Send DELETE request ```vb Public Function SendDelete(ByVal url As String, Optional Body As String) As cHttpClient ``` ### SendOptions Send OPTIONS request ```vb Public Function SendOptions(ByVal url As String, Optional Body As String) As cHttpClient ``` ### Send / Fetch General request methods (underlying methods) ```vb Public Function Send(Method As EnumRequestMethod, ByVal url As String, Optional Body As String) As cHttpClient Public Function Fetch(Method As EnumRequestMethod, ByVal url As String, Optional Body As String) As cHttpClient ``` ### SetRequestContentType Set request Content-Type ```vb Public Function SetRequestContentType(ReqType As EnumRequestContentType, Optional ContentType As String) As String ``` **Request Type Enum**: * `ReqJson` - application/json * `ReqFormUrlEncoded` - application/x-www-form-urlencoded * `ReqFormMultipart` - multipart/form-data * `ReqTextPlain` - text/plain * `ReqTextHtml` - text/html ### SetCookies Set Cookie ```vb Public Function SetCookies(ByVal Value As String) As cHttpClient ``` **Example**: ```vb VBMAN.HttpClient.SetCookies("sessionid=abc123; user=admin") ``` ### Async Set async mode ```vb Public Function Async(Bool As Boolean) As cHttpClient ``` ### ShowPage Open webpage with default browser ```vb Public Sub ShowPage(url As String) ``` ## Comprehensive Examples ### Example 1: GET Request ```vb Private Sub GetUserList() With VBMAN.HttpClient .SendGet("https://jsonplaceholder.typicode.com/users") If .LastError = "" Then ' Parse JSON response Dim json As cJson Set json = VBMAN.Json.Decode(.ResponseRaw) Debug.Print "Fetch successful" Else MsgBox "Request failed: " & .LastError End If End With End Sub ``` ### Example 2: POST Request (JSON) ```vb Private Sub CreateUser(name As String, email As String) With VBMAN.HttpClient ' Set Content-Type .SetRequestContentType ReqJson ' Build JSON request body With .RequestDataJson .Item("name") = name .Item("email") = email End With .SendPost "https://api.example.com/users", .RequestDataJson.Encode If .LastError = "" Then Debug.Print "Create successful" End If End With End Sub ``` ### Example 3: Form Submission ```vb Private Sub SubmitForm(username As String, password As String) With VBMAN.HttpClient ' Set form data .RequestDataForm("username") = username .RequestDataForm("password") = password ' Convert to form format and send .SendPost "https://api.example.com/login", VBMAN.ToolsHttp.MakeContent(.RequestDataForm) End With End Sub ``` ### Example 4: Request with Authentication ```vb Private Sub ApiRequestWithAuth() With VBMAN.HttpClient ' Set request headers .RequestHeaders("Authorization") = "Bearer " & GetAccessToken() .RequestHeaders("X-Request-ID") = VBMAN.ToolsStr.GetGUID() .SendGet "https://api.example.com/protected" If .LastError = "" Then ProcessResponse .ResponseRaw End If End With End Sub ``` ### Example 5: URL Parameters ```vb Private Sub SearchUsers(keyword As String) With VBMAN.HttpClient ' Add URL parameters .RequestDataQuery("q") = keyword .RequestDataQuery("page") = 1 .RequestDataQuery("limit") = 20 .SendGet "https://api.example.com/search" End With End Sub ``` ## Best Practices 1. **Timeout Setting**: Set reasonable timeout based on network conditions 2. **Error Handling**: Always check LastError 3. **HTTPS First**: Always use HTTPS for sensitive data 4. **Header Management**: Use RequestHeaders dictionary to set custom headers 5. **Encoding Handling**: Pay attention to character encoding of requests and responses --- --- url: /zh/vbman/global/cimage.md --- # VBMAN.Image - 图片数据互转对象 ## 概述 `VBMAN.Image` 提供了 `Byte()` ↔ `Base64` ↔ `StdPicture` 三种图片数据格式的互转功能，采用链式调用设计，一行代码即可完成复杂转换。 ## 核心特性 * **链式调用**: 流畅的 API 设计，一行代码完成转换 + 输出 * **三种格式互转**: 字节数组、Base64 字符串、StdPicture 对象之间自由转换 * **Data URI 支持**: 自动解析 `data:image/jpeg;base64,...` 格式 * **MIME 类型检测**: 通过文件魔数自动识别 JPEG/PNG/GIF/BMP/WebP/ICO * **控件直赋**: `ShowTo` 方法直接将图片显示到 Image/PictureBox 控件 * **默认成员**: `Data` 方法为默认成员，支持 `VBMAN.Image.(base64Str)` 简写 ## 方法 ### Data 链式调用入口，接受 Byte() 数组、Base64 字符串、StdPicture 对象。为默认成员。 ```vb Public Function Data(ByVal vData As Variant) As cImage ``` **示例**: ```vb ' 从 Base64 字符串 VBMAN.Image.Data(base64Str).ReturnPicture ' 简写法（利用默认成员） VBMAN.Image.(base64Str).ReturnPicture ' 从字节数组 VBMAN.Image.Data(bytes).ReturnBase64 ' 从 StdPicture VBMAN.Image.Data(Image1.Picture).ReturnBase64 ' Data URI 格式自动解析 VBMAN.Image.("data:image/png;base64,iVBOR...").ReturnPicture ``` ### ShowTo 将图片直接显示到目标控件（链式调用）。 ```vb Public Function ShowTo(ByVal Target As Object) As cImage ``` **参数**: * `Target` - 任何拥有 Picture 属性的控件对象（Image、PictureBox 等） **示例**: ```vb ' 一行代码显示到 Image 控件 VBMAN.Image.(base64Str).ShowTo Image1 ' 显示到 PictureBox VBMAN.Image.(bytesArr).ShowTo Picture1 ``` ### ReturnBytes 输出为字节数组。 ```vb Public Function ReturnBytes() As Byte() ``` **示例**: ```vb Dim bytes() As Byte bytes = VBMAN.Image.Data(base64Str).ReturnBytes ``` ### ReturnBase64 输出为 Base64 字符串（不含 `data:` 前缀）。 ```vb Public Function ReturnBase64() As String ``` **示例**: ```vb Dim b64 As String b64 = VBMAN.Image.Data(Image1.Picture).ReturnBase64 ``` ### ReturnPicture 输出为 StdPicture 对象，可直接赋给控件的 Picture 属性。 ```vb Public Function ReturnPicture() As StdPicture ``` **示例**: ```vb Set Image1.Picture = VBMAN.Image.Data(base64Str).ReturnPicture ``` ### ReturnDataUri 输出为 Data URI 格式字符串（如 `data:image/jpeg;base64,...`）。 ```vb Public Function ReturnDataUri(Optional ByVal MimeType As String) As String ``` **参数**: * `MimeType` - 可选，MIME 类型，省略时使用自动检测或默认 `image/jpeg` **示例**: ```vb ' 自动检测 MIME Dim uri As String uri = VBMAN.Image.Data(bytes).ReturnDataUri ' 手动指定 MIME uri = VBMAN.Image.Data(bytes).SetMimeType("image/png").ReturnDataUri ``` ### SetMimeType 手动设置 MIME 类型（链式调用）。 ```vb Public Function SetMimeType(ByVal MimeType As String) As cImage ``` **示例**: ```vb VBMAN.Image.Data(bytes).SetMimeType("image/png").ReturnDataUri ``` ### ReturnMimeType 返回自动检测到的 MIME 类型。 ```vb Public Function ReturnMimeType() As String ``` **支持检测**: JPEG、PNG、GIF、BMP、WebP、ICO **示例**: ```vb Dim mime As String mime = VBMAN.Image.Data(bytes).ReturnMimeType ' image/png ``` ### IsValid 检查数据是否有效。 ```vb Public Function IsValid() As Boolean ``` **示例**: ```vb If VBMAN.Image.Data(base64Str).IsValid Then VBMAN.Image.ShowTo Image1 End If ``` ## 综合示例 ### 从 API 显示头像 ```vb ' 获取头像 Base64，一行显示 Dim resp As String resp = VBMAN.HttpClient.SetUrl("/api/avatar").Get VBMAN.Image.(VBMAN.Json.Decode(resp)("avatar")).ShowTo Image1 ``` ### 图片上传 ```vb ' 读取图片 → Base64 → 上传 VBMAN.FileEx.OpenFile "C:\photo.jpg", "R" Dim bytes() As Byte bytes = VBMAN.FileEx.ReadData.ReturnBytes VBMAN.FileEx.CloseFile Dim json As New cJson json("image") = VBMAN.Image.Data(bytes).ReturnBase64 json("mime") = VBMAN.Image.Data(bytes).ReturnMimeType VBMAN.HttpClient.SetUrl("/api/upload").SetBody(json.Encode).Post ``` ### Data URI 嵌入 HTML ```vb ' 图片 → Data URI → 嵌入页面 Dim dataUri As String dataUri = VBMAN.Image.Data(bytes).ReturnDataUri WebBrowser1.Document.Write "" ``` ## 详细文档 完整 API 文档请参阅: [Tools/Image 文档](../tools/image.md) --- --- url: /en/vbman/global/cimage.md --- # VBMAN.Image - Image Data Conversion Object ## Overview `VBMAN.Image` provides mutual conversion functionality between `Byte()` ↔ `Base64` ↔ `StdPicture` image data formats, using a chained call design that allows complex conversions in a single line of code. ## Core Features * **Chained Calls**: Fluent API design, one line to complete conversion + output * **Three-Format Conversion**: Free conversion between byte arrays, Base64 strings, and StdPicture objects * **Data URI Support**: Automatically parses `data:image/jpeg;base64,...` format * **MIME Type Detection**: Automatically identifies JPEG/PNG/GIF/BMP/WebP/ICO via file magic numbers * **Direct Control Assignment**: `ShowTo` method directly displays images to Image/PictureBox controls * **Default Member**: `Data` method is the default member, supporting `VBMAN.Image.(base64Str)` shorthand ## Methods ### Data Chained call entry point, accepts Byte() array, Base64 string, StdPicture object. Default member. ```vb Public Function Data(ByVal vData As Variant) As cImage ``` **Example**: ```vb ' From Base64 string VBMAN.Image.Data(base64Str).ReturnPicture ' Shorthand (using default member) VBMAN.Image.(base64Str).ReturnPicture ' From byte array VBMAN.Image.Data(bytes).ReturnBase64 ' From StdPicture VBMAN.Image.Data(Image1.Picture).ReturnBase64 ' Data URI format auto-parsing VBMAN.Image.("data:image/png;base64,iVBOR...").ReturnPicture ``` ### ShowTo Directly displays the image to the target control (chained call). ```vb Public Function ShowTo(ByVal Target As Object) As cImage ``` **Parameters**: * `Target` - Any control object with a Picture property (Image, PictureBox, etc.) **Example**: ```vb ' One-line display to Image control VBMAN.Image.(base64Str).ShowTo Image1 ' Display to PictureBox VBMAN.Image.(bytesArr).ShowTo Picture1 ``` ### ReturnBytes Output as byte array. ```vb Public Function ReturnBytes() As Byte() ``` **Example**: ```vb Dim bytes() As Byte bytes = VBMAN.Image.Data(base64Str).ReturnBytes ``` ### ReturnBase64 Output as Base64 string (without `data:` prefix). ```vb Public Function ReturnBase64() As String ``` **Example**: ```vb Dim b64 As String b64 = VBMAN.Image.Data(Image1.Picture).ReturnBase64 ``` ### ReturnPicture Output as StdPicture object, can be directly assigned to control's Picture property. ```vb Public Function ReturnPicture() As StdPicture ``` **Example**: ```vb Set Image1.Picture = VBMAN.Image.Data(base64Str).ReturnPicture ``` ### ReturnDataUri Output as Data URI format string (e.g., `data:image/jpeg;base64,...`). ```vb Public Function ReturnDataUri(Optional ByVal MimeType As String) As String ``` **Parameters**: * `MimeType` - Optional, MIME type. When omitted, uses auto-detection or defaults to `image/jpeg` **Example**: ```vb ' Auto-detect MIME Dim uri As String uri = VBMAN.Image.Data(bytes).ReturnDataUri ' Manually specify MIME uri = VBMAN.Image.Data(bytes).SetMimeType("image/png").ReturnDataUri ``` ### SetMimeType Manually set MIME type (chained call). ```vb Public Function SetMimeType(ByVal MimeType As String) As cImage ``` **Example**: ```vb VBMAN.Image.Data(bytes).SetMimeType("image/png").ReturnDataUri ``` ### ReturnMimeType Returns the auto-detected MIME type. ```vb Public Function ReturnMimeType() As String ``` **Supported detection**: JPEG, PNG, GIF, BMP, WebP, ICO **Example**: ```vb Dim mime As String mime = VBMAN.Image.Data(bytes).ReturnMimeType ' image/png ``` ### IsValid Checks if data is valid. ```vb Public Function IsValid() As Boolean ``` **Example**: ```vb If VBMAN.Image.Data(base64Str).IsValid Then VBMAN.Image.ShowTo Image1 End If ``` ## Comprehensive Examples ### Display Avatar from API ```vb ' Get avatar Base64 from API, display in one line Dim resp As String resp = VBMAN.HttpClient.SetUrl("/api/avatar").Get VBMAN.Image.(VBMAN.Json.Decode(resp)("avatar")).ShowTo Image1 ``` ### Image Upload ```vb ' Read image → Base64 → upload VBMAN.FileEx.OpenFile "C:\photo.jpg", "R" Dim bytes() As Byte bytes = VBMAN.FileEx.ReadData.ReturnBytes VBMAN.FileEx.CloseFile Dim json As New cJson json("image") = VBMAN.Image.Data(bytes).ReturnBase64 json("mime") = VBMAN.Image.Data(bytes).ReturnMimeType VBMAN.HttpClient.SetUrl("/api/upload").SetBody(json.Encode).Post ``` ### Data URI Embedding in HTML ```vb ' Image → Data URI → embed in page Dim dataUri As String dataUri = VBMAN.Image.Data(bytes).ReturnDataUri WebBrowser1.Document.Write "" ``` ## Detailed Documentation For complete API documentation, please refer to: [Tools/Image Documentation](../tools/image.md) --- --- url: /zh/vbman/global/ini.md --- # VBMAN.Ini - INI 配置文件操作对象 ## 概述 `VBMAN.Ini` 提供了方便的 INI 配置文件读写功能，支持多级节点、多行文本，以及自动路径处理。 ## 核心特性 * **多级节点**: 支持 `[Section]` 和 `Key=Value` 结构 * **多行文本**: 支持包含换行符的配置值 * **链式调用**: 流畅的 API 设计 * **自动编码**: 支持 UTF-8 等编码格式 * **路径记忆**: LoadFrom 后可省略路径直接 SaveTo ## 属性 | 属性 | 类型 | 说明 | | ----------- | ---------- | ---------------------- | | `Root` | Dictionary | 根字典对象（默认成员） | | `LastError` | String | 最后错误信息 | ## 方法 ### Section 获取或创建节点（返回字典） ```vb Public Property Get Section(ByVal key As String) As Dictionary ``` **示例**: ```vb ' 读取节点 Dim serverIP As String serverIP = VBMAN.Ini.Section("Server")("IP") ' 写入节点 VBMAN.Ini.Section("Server")("IP") = "192.168.1.1" VBMAN.Ini.Section("Server")("Port") = "8080" ' 链式设置 With VBMAN.Ini.Section("Database") .Item("Host") = "localhost" .Item("Name") = "mydb" .Item("User") = "admin" End With ``` ### MultiLineText 读写多行文本（自动处理换行符转义） ```vb Public Property Get MultiLineText(ByVal SectionName As String, ByVal KeyName As String) As String Public Property Let MultiLineText(ByVal SectionName As String, ByVal KeyName As String, ByVal Text As String) ``` **说明**: 自动将 `\r\n` 与实际的换行符 `vbCrLf` 互相转换 **示例**: ```vb ' 写入多行文本 Dim notice As String notice = "系统维护通知" & vbCrLf & _ "时间：2024-01-01 00:00" & vbCrLf & _ "内容：服务器升级" VBMAN.Ini.MultiLineText("Notify", "Content") = notice ' 读取多行文本 Dim content As String content = VBMAN.Ini.MultiLineText("Notify", "Content") TextBox1.Text = content ``` ### LoadFrom 从文件加载 INI ```vb Public Function LoadFrom(ByVal Path As String, Optional CharSet As String = "UTF-8") As cIni ``` **参数**: * `Path` - 文件路径 * `CharSet` - 字符编码（默认UTF-8） **示例**: ```vb ' 基本加载 VBMAN.Ini.LoadFrom App.Path & "\\config.ini" ' 链式调用 With VBMAN.Ini .LoadFrom App.Path & "\\config.ini" Debug.Print .Section("Server")("IP") End With ``` ### SaveTo 保存到文件 ```vb Public Function SaveTo(Optional ByVal Path As String, Optional CharSet As String = "UTF-8") As Boolean ``` **说明**: 如果省略 Path，使用上次 LoadFrom 的路径 **示例**: ```vb ' 保存到指定路径 VBMAN.Ini.SaveTo "C:\\config.ini" ' 保存到上次加载的路径（推荐） VBMAN.Ini.SaveTo ' 完整示例 With VBMAN.Ini .LoadFrom App.Path & "\\config.ini" .Section("Settings")("Theme") = "Dark" .SaveTo ' 自动保存到原路径 End With ``` ### Password 设置加密密码（链式调用） ```vb Public Function Password(ByVal Pwd As String) As cIni ``` **示例**: ```vb ' 设置密码（功能预留） VBMAN.Ini.Password("mysecret").LoadFrom "config.ini" ``` ## 综合示例 ### 示例1: 读写服务器配置 ```vb Private Sub SaveServerConfig() With VBMAN.Ini ' 加载或创建配置 .LoadFrom App.Path & "\\server.ini" ' 写入服务器配置 With .Section("Server") .Item("IP") = TextIP.Text .Item("Port") = TextPort.Text .Item("Timeout") = "30" End With ' 写入数据库配置 With .Section("Database") .Item("Host") = "localhost" .Item("Port") = "3306" .Item("Name") = "production" End With ' 保存 If .SaveTo Then MsgBox "配置保存成功！" Else MsgBox "保存失败: " & .LastError End If End With End Sub Private Sub LoadServerConfig() With VBMAN.Ini .LoadFrom App.Path & "\\server.ini" TextIP.Text = .Section("Server")("IP") TextPort.Text = .Section("Server")("Port") End With End Sub ``` ### 示例2: 读取公告信息 ```vb ' 在实际项目中的使用示例（来自 cs-auther 案例） Private Sub LoadNotice() VBMAN.Ini.LoadFrom App.Path & "\\config.ini" ' 检查是否存在公告 If VBMAN.Ini.Root.Exists("Notify") Then TextTitle.Text = VBMAN.Ini("Notify")("Title") TextContent.Text = VBMAN.Ini.MultiLineText("Notify", "Content") LabelTime.Caption = VBMAN.Ini("Notify")("Time") End If End Sub Private Sub SaveNotice() VBMAN.Ini.Section("Notify")("Title") = TextTitle.Text VBMAN.Ini.MultiLineText("Notify", "Content") = TextContent.Text VBMAN.Ini.Section("Notify")("Time") = Format(Now, "yyyy-MM-dd hh:mm:ss") VBMAN.Ini.SaveTo End Sub ``` ### 示例3: 删除节点 ```vb Private Sub ClearNotice() VBMAN.Ini.LoadFrom App.Path & "\\config.ini" ' 删除整个 Notify 节点 If VBMAN.Ini.Root.Exists("Notify") Then VBMAN.Ini.Root.Remove "Notify" End If VBMAN.Ini.SaveTo End Sub ``` ### 示例4: 遍历所有配置 ```vb Private Sub ShowAllConfig() VBMAN.Ini.LoadFrom App.Path & "\\config.ini" Dim sectionKey As Variant Dim key As Variant ' 遍历所有节点 For Each sectionKey In VBMAN.Ini.Root.Keys Debug.Print "[" & sectionKey & "]" ' 遍历节点内所有键值 For Each key In VBMAN.Ini.Root(sectionKey).Keys Debug.Print " " & key & " = " & VBMAN.Ini.Root(sectionKey)(key) Next key Next sectionKey End Sub ``` ## INI 文件格式示例 ```ini [Server] IP=192.168.1.100 Port=8080 Timeout=30 [Database] Host=localhost Port=3306 Name=mydb User=admin Password=secret [Notify] Title=系统公告 Time=2024-01-15 10:30:00 Content=系统将于今晚进行维护 预计耗时2小时 请提前保存工作 ``` ## 最佳实践 1. **使用 App.Path**: 配置文件建议放在程序目录下 2. **检查节点存在性**: 读取前先检查节点是否存在避免错误 3. **使用 MultiLineText**: 多行内容使用专用方法处理换行符 4. **错误处理**: 文件操作可能失败，建议添加错误处理 5. **定期保存**: 修改配置后及时调用 SaveTo ## 注意事项 * 节点名和键名区分大小写 * 值中的前导/尾随空格会被去除 * 支持 `;` 开头的注释行（读取时自动忽略） * 空行会被忽略 --- --- url: /en/vbman/global/ini.md --- # VBMAN.Ini - INI Configuration File Object ## Overview `VBMAN.Ini` provides convenient INI configuration file read/write functionality, supporting multi-level sections, multi-line text, and automatic path handling. ## Core Features * **Multi-level Sections**: Supports `[Section]` and `Key=Value` structure * **Multi-line Text**: Supports configuration values containing line breaks * **Chain Calling**: Fluent API design * **Automatic Encoding**: Supports UTF-8 and other encoding formats * **Path Memory**: Can omit path in SaveTo after LoadFrom ## Properties | Property | Type | Description | | ----------- | ---------- | --------------------------------------- | | `Root` | Dictionary | Root dictionary object (default member) | | `LastError` | String | Last error message | ## Methods ### Section Get or create section (returns dictionary) ```vb Public Property Get Section(ByVal key As String) As Dictionary ``` **Example**: ```vb ' Read section Dim serverIP As String serverIP = VBMAN.Ini.Section("Server")("IP") ' Write section VBMAN.Ini.Section("Server")("IP") = "192.168.1.1" VBMAN.Ini.Section("Server")("Port") = "8080" ' Chain setting With VBMAN.Ini.Section("Database") .Item("Host") = "localhost" .Item("Name") = "mydb" .Item("User") = "admin" End With ``` ### MultiLineText Read/write multi-line text (automatically handles newline escaping) ```vb Public Property Get MultiLineText(ByVal SectionName As String, ByVal KeyName As String) As String Public Property Let MultiLineText(ByVal SectionName As String, ByVal KeyName As String, ByVal Text As String) ``` **Description**: Automatically converts `\r\n` with actual newline `vbCrLf` **Example**: ```vb ' Write multi-line text Dim notice As String notice = "System Maintenance Notice" & vbCrLf & _ "Time: 2024-01-01 00:00" & vbCrLf & _ "Content: Server Upgrade" VBMAN.Ini.MultiLineText("Notify", "Content") = notice ' Read multi-line text Dim content As String content = VBMAN.Ini.MultiLineText("Notify", "Content") TextBox1.Text = content ``` ### LoadFrom Load INI from file ```vb Public Function LoadFrom(ByVal Path As String, Optional CharSet As String = "UTF-8") As cIni ``` **Parameters**: * `Path` - File path * `CharSet` - Character encoding (default UTF-8) **Example**: ```vb ' Basic loading VBMAN.Ini.LoadFrom App.Path & "\\config.ini" ' Chain calling With VBMAN.Ini .LoadFrom App.Path & "\\config.ini" Debug.Print .Section("Server")("IP") End With ``` ### SaveTo Save to file ```vb Public Function SaveTo(Optional ByVal Path As String, Optional CharSet As String = "UTF-8") As Boolean ``` **Description**: If Path is omitted, uses the last LoadFrom path **Example**: ```vb ' Save to specified path VBMAN.Ini.SaveTo "C:\\config.ini" ' Save to last loaded path (recommended) VBMAN.Ini.SaveTo ' Complete example With VBMAN.Ini .LoadFrom App.Path & "\\config.ini" .Section("Settings")("Theme") = "Dark" .SaveTo ' Automatically save to original path End With ``` ### Password Set encryption password (chain call) ```vb Public Function Password(ByVal Pwd As String) As cIni ``` **Example**: ```vb ' Set password (reserved functionality) VBMAN.Ini.Password("mysecret").LoadFrom "config.ini" ``` ## Comprehensive Examples ### Example 1: Read/Write Server Configuration ```vb Private Sub SaveServerConfig() With VBMAN.Ini ' Load or create configuration .LoadFrom App.Path & "\\server.ini" ' Write server configuration With .Section("Server") .Item("IP") = TextIP.Text .Item("Port") = TextPort.Text .Item("Timeout") = "30" End With ' Write database configuration With .Section("Database") .Item("Host") = "localhost" .Item("Port") = "3306" .Item("Name") = "production" End With ' Save If .SaveTo Then MsgBox "Configuration saved successfully!" Else MsgBox "Save failed: " & .LastError End If End With End Sub Private Sub LoadServerConfig() With VBMAN.Ini .LoadFrom App.Path & "\\server.ini" TextIP.Text = .Section("Server")("IP") TextPort.Text = .Section("Server")("Port") End With End Sub ``` ### Example 2: Read Announcement Info ```vb ' Usage example from actual project (from cs-auther case) Private Sub LoadNotice() VBMAN.Ini.LoadFrom App.Path & "\\config.ini" ' Check if announcement exists If VBMAN.Ini.Root.Exists("Notify") Then TextTitle.Text = VBMAN.Ini("Notify")("Title") TextContent.Text = VBMAN.Ini.MultiLineText("Notify", "Content") LabelTime.Caption = VBMAN.Ini("Notify")("Time") End If End Sub Private Sub SaveNotice() VBMAN.Ini.Section("Notify")("Title") = TextTitle.Text VBMAN.Ini.MultiLineText("Notify", "Content") = TextContent.Text VBMAN.Ini.Section("Notify")("Time") = Format(Now, "yyyy-MM-dd hh:mm:ss") VBMAN.Ini.SaveTo End Sub ``` ### Example 3: Delete Section ```vb Private Sub ClearNotice() VBMAN.Ini.LoadFrom App.Path & "\\config.ini" ' Delete entire Notify section If VBMAN.Ini.Root.Exists("Notify") Then VBMAN.Ini.Root.Remove "Notify" End If VBMAN.Ini.SaveTo End Sub ``` ### Example 4: Iterate All Configurations ```vb Private Sub ShowAllConfig() VBMAN.Ini.LoadFrom App.Path & "\\config.ini" Dim sectionKey As Variant Dim key As Variant ' Iterate all sections For Each sectionKey In VBMAN.Ini.Root.Keys Debug.Print "[" & sectionKey & "]" ' Iterate all key-value pairs in section For Each key In VBMAN.Ini.Root(sectionKey).Keys Debug.Print " " & key & " = " & VBMAN.Ini.Root(sectionKey)(key) Next key Next sectionKey End Sub ``` ## INI File Format Example ```ini [Server] IP=192.168.1.100 Port=8080 Timeout=30 [Database] Host=localhost Port=3306 Name=mydb User=admin Password=secret [Notify] Title=System Announcement Time=2024-01-15 10:30:00 Content=System will be maintained tonight Estimated time: 2 hours Please save your work in advance ``` ## Best Practices 1. **Use App.Path**: Configuration files recommended to be placed in program directory 2. **Check Section Existence**: Check if section exists before reading to avoid errors 3. **Use MultiLineText**: Use dedicated method to handle newlines for multi-line content 4. **Error Handling**: File operations may fail, recommend adding error handling 5. **Save Regularly**: Call SaveTo promptly after modifying configuration ## Notes * Section names and key names are case-sensitive * Leading/trailing spaces in values will be trimmed * Supports comment lines starting with `;` (automatically ignored when reading) * Empty lines are ignored --- --- url: /zh/vbman/global/json.md --- # VBMAN.Json - JSON 操作对象 ## 概述 `VBMAN.Json` 提供了 JSON 数据的解析和生成功能，支持嵌套对象、数组，是 VB6 中处理 JSON 数据的首选方案。 ## 核心特性 * **双向转换**: 支持 JSON 字符串解析和对象编码 * **嵌套支持**: 无限层级的嵌套对象和数组 * **类型安全**: 自动处理数据类型转换 * **格式化输出**: 支持缩进美化输出 * **链式构建**: 流畅的 JSON 构建 API ## 属性 | 属性 | 类型 | 说明 | |------|------|------| | `Root` | cJson | 根节点对象 | | `Item(key)` | Variant | 访问指定键的值（默认成员） | ## 方法 ### Encode 将对象编码为 JSON 字符串 ```vb Public Function Encode(Optional obj As Object, Optional Indent As Integer = 0, Optional UseDoubleQuotes As Boolean = True) As String ``` **参数**: * `obj` - 要编码的对象（默认使用 Root） * `Indent` - 缩进空格数（0=不换行） * `UseDoubleQuotes` - 使用双引号（默认 True） **示例**: ```vb ' 简单编码 Dim json As New cJson json("name") = "张三" json("age") = 25 Dim jsonStr As String jsonStr = json.Encode() ' 结果: {"name":"张三","age":25} ' 格式化输出 Dim prettyJson As String prettyJson = json.Encode(, 2, True) ' 结果: ' { ' "name": "张三", ' "age": 25 ' } ``` ### Decode 解析 JSON 字符串 ```vb Public Function Decode(jsonString As String) As cJson ``` **示例**: ```vb ' 解析 JSON Dim jsonStr As String jsonStr = "{\"name\":\"张三\",\"age\":25}" Dim json As cJson Set json = VBMAN.Json.Decode(jsonStr) Debug.Print json("name") ' 张三 Debug.Print json("age") ' 25 ``` ### Item 访问或设置值 ```vb ' 读取 Dim value As Variant value = json("key") ' 写入 json("key") = "value" json("number") = 123 json("bool") = True ``` ### NewItem / NewItems 创建嵌套对象/数组 ```vb Public Function NewItem() As cJson Public Function NewItems(key As String) As cJson ``` **示例**: ```vb ' 创建嵌套对象 Dim user As New cJson user("id") = 1 user("name") = "张三" With user.NewItem("address") .Item("city") = "北京" .Item("zip") = "100000" End With ' 创建数组 Dim users As New cJson With users.NewItems("data") With .NewItem() .Item("name") = "张三" .Item("age") = 25 End With With .NewItem() .Item("name") = "李四" .Item("age") = 30 End With End With Debug.Print users.Encode(, 2) ' 结果: ' { ' "data": [ ' {"name":"张三","age":25}, ' {"name":"李四","age":30} ' ] ' } ``` ### Exists 检查键是否存在 ```vb Public Function Exists(key As String) As Boolean ``` **示例**: ```vb If json.Exists("email") Then Debug.Print json("email") Else Debug.Print "email 不存在" End If ``` ### Remove 删除键 ```vb Public Sub Remove(key As String) ``` ## 综合示例 ### 示例1: 构建复杂 JSON ```vb Private Sub BuildComplexJson() Dim root As New cJson ' 基本信息 root("status") = "success" root("message") = "操作成功" root("timestamp") = Format(Now, "yyyy-MM-ddThh:mm:ss") ' 用户数据数组 With root.NewItems("users") ' 第一个用户 With .NewItem() .Item("id") = 1 .Item("name") = "张三" .Item("email") = "zhangsan@example.com" ' 嵌套地址 With .NewItem("address") .Item("province") = "北京" .Item("city") = "北京市" .Item("detail") = "朝阳区xxx街道" End With ' 嵌套订单数组 With .NewItems("orders") With .NewItem() .Item("order_id") = "ORD001" .Item("amount") = 199.99 End With With .NewItem() .Item("order_id") = "ORD002" .Item("amount") = 299.99 End With End With End With ' 第二个用户 With .NewItem() .Item("id") = 2 .Item("name") = "李四" .Item("email") = "lisi@example.com" End With End With ' 分页信息 With root.NewItem("pagination") .Item("page") = 1 .Item("page_size") = 20 .Item("total") = 100 End With ' 输出 JSON Dim jsonStr As String jsonStr = root.Encode(, 2, True) Debug.Print jsonStr End Sub ``` ### 示例2: 解析 API 响应 ```vb Private Sub ParseApiResponse(response As String) Dim json As cJson Set json = VBMAN.Json.Decode(response) ' 检查状态 If json("status") = "success" Then ' 获取用户数组 Dim users As cJson Set users = json("data")("users") ' 遍历用户 Dim i As Integer For i = 0 To users.Count - 1 Dim user As cJson Set user = users(i) Debug.Print "ID: " & user("id") Debug.Print "Name: " & user("name") Debug.Print "Email: " & user("email") ' 检查是否有地址 If user.Exists("address") Then Debug.Print "City: " & user("address")("city") End If Debug.Print "---" Next i ' 获取分页信息 Debug.Print "Total: " & json("data")("pagination")("total") Else Debug.Print "Error: " & json("message") End If End Sub ``` ### 示例3: 在实际项目中使用（来自 demos） ```vb ' 构建 JSON 响应 Public Sub Json(ctx As cHttpServerContext) Dim ID As Long: ID = ctx.Request.QueryString("id") With New cJson .Item("id") = ID .Item("face") = ChrW(&H263A) .Item("timestamp") = Now .Item("status") = "success" ctx.Response.Json .Root End With End Sub ' 解析请求数据 Public Sub HandleRequest(ctx As cHttpServerContext) Dim requestData As String requestData = ctx.Request.Body Dim json As cJson Set json = VBMAN.Json.Decode(requestData) Dim username As String Dim password As String username = json("username") password = json("password") ' 处理登录... End Sub ``` ### 示例4: 数据库记录转 JSON ```vb Private Sub RecordsetToJson(rs As ADODB.Recordset) Dim root As New cJson ' 添加元数据 root("count") = rs.RecordCount root("timestamp") = Now ' 添加数据数组 With root.NewItems("data") Do While Not rs.EOF With .NewItem() Dim i As Integer For i = 0 To rs.Fields.Count - 1 .Item(rs.Fields(i).Name) = rs.Fields(i).Value Next i End With rs.MoveNext Loop End With ' 输出 Debug.Print root.Encode(, 2) End Sub ``` ### 示例5: INI 配置转 JSON ```vb Private Sub IniToJson() VBMAN.Ini.LoadFrom App.Path & "\\config.ini" Dim json As New cJson ' 转换所有 Section Dim sectionKey As Variant For Each sectionKey In VBMAN.Ini.Root.Keys With json.NewItem(CStr(sectionKey)) Dim key As Variant For Each key In VBMAN.Ini.Root(sectionKey).Keys .Item(key) = VBMAN.Ini.Root(sectionKey)(key) Next key End With Next sectionKey ' 保存为 JSON 文件 VBMAN.FileEx.SetBufferText(json.Encode(, 2), "UTF-8").SaveData App.Path & "\\config.json" End Sub ``` ## 最佳实践 1. **使用参数**: 构建 JSON 时尽量使用 NewItem/NewItems 2. **检查存在性**: 读取前使用 Exists 检查键是否存在 3. **错误处理**: 解析 JSON 时添加错误处理 4. **类型注意**: VB6 是弱类型，注意数值和字符串的区别 5. **格式化输出**: 调试时使用缩进格式化便于阅读 --- --- url: /en/vbman/global/json.md --- # VBMAN.Json - JSON Operation Object ## Overview `VBMAN.Json` provides JSON data parsing and generation functionality, supporting nested objects, arrays, and is the preferred solution for handling JSON data in VB6. ## Core Features * **Bidirectional Conversion**: Supports JSON string parsing and object encoding * **Nested Support**: Unlimited level nested objects and arrays * **Type Safety**: Automatic data type conversion handling * **Formatted Output**: Supports indentation beautification output * **Chain Building**: Fluent JSON building API ## Properties | Property | Type | Description | |----------|------|-------------| | `Root` | cJson | Root node object | | `Item(key)` | Variant | Access value of specified key (default member) | ## Methods ### Encode Encode object to JSON string ```vb Public Function Encode(Optional obj As Object, Optional Indent As Integer = 0, Optional UseDoubleQuotes As Boolean = True) As String ``` **Parameters**: * `obj` - Object to encode (default uses Root) * `Indent` - Indentation spaces (0=no line breaks) * `UseDoubleQuotes` - Use double quotes (default True) **Example**: ```vb ' Simple encoding Dim json As New cJson json("name") = "Zhang San" json("age") = 25 Dim jsonStr As String jsonStr = json.Encode() ' Result: {"name":"Zhang San","age":25} ' Formatted output Dim prettyJson As String prettyJson = json.Encode(, 2, True) ' Result: ' { ' "name": "Zhang San", ' "age": 25 ' } ``` ### Decode Parse JSON string ```vb Public Function Decode(jsonString As String) As cJson ``` **Example**: ```vb ' Parse JSON Dim jsonStr As String jsonStr = "{""name"":""Zhang San"",""age"":25}" Dim json As cJson Set json = VBMAN.Json.Decode(jsonStr) Debug.Print json("name") ' Zhang San Debug.Print json("age") ' 25 ``` ### Item Access or set value ```vb ' Read Dim value As Variant value = json("key") ' Write json("key") = "value" json("number") = 123 json("bool") = True ``` ### NewItem / NewItems Create nested object/array ```vb Public Function NewItem() As cJson Public Function NewItems(key As String) As cJson ``` **Example**: ```vb ' Create nested object Dim user As New cJson user("id") = 1 user("name") = "Zhang San" With user.NewItem("address") .Item("city") = "Beijing" .Item("zip") = "100000" End With ' Create array Dim users As New cJson With users.NewItems("data") With .NewItem() .Item("name") = "Zhang San" .Item("age") = 25 End With With .NewItem() .Item("name") = "Li Si" .Item("age") = 30 End With End With Debug.Print users.Encode(, 2) ' Result: ' { ' "data": [ ' {"name":"Zhang San","age":25}, ' {"name":"Li Si","age":30} ' ] ' } ``` ### Exists Check if key exists ```vb Public Function Exists(key As String) As Boolean ``` **Example**: ```vb If json.Exists("email") Then Debug.Print json("email") Else Debug.Print "email does not exist" End If ``` ### Remove Delete key ```vb Public Sub Remove(key As String) ``` ## Comprehensive Examples ### Example 1: Build Complex JSON ```vb Private Sub BuildComplexJson() Dim root As New cJson ' Basic info root("status") = "success" root("message") = "Operation successful" root("timestamp") = Format(Now, "yyyy-MM-ddThh:mm:ss") ' User data array With root.NewItems("users") ' First user With .NewItem() .Item("id") = 1 .Item("name") = "Zhang San" .Item("email") = "zhangsan@example.com" ' Nested address With .NewItem("address") .Item("province") = "Beijing" .Item("city") = "Beijing City" .Item("detail") = "Chaoyang District xxx Street" End With ' Nested orders array With .NewItems("orders") With .NewItem() .Item("order_id") = "ORD001" .Item("amount") = 199.99 End With With .NewItem() .Item("order_id") = "ORD002" .Item("amount") = 299.99 End With End With End With ' Second user With .NewItem() .Item("id") = 2 .Item("name") = "Li Si" .Item("email") = "lisi@example.com" End With End With ' Pagination info With root.NewItem("pagination") .Item("page") = 1 .Item("page_size") = 20 .Item("total") = 100 End With ' Output JSON Dim jsonStr As String jsonStr = root.Encode(, 2, True) Debug.Print jsonStr End Sub ``` ### Example 2: Parse API Response ```vb Private Sub ParseApiResponse(response As String) Dim json As cJson Set json = VBMAN.Json.Decode(response) ' Check status If json("status") = "success" Then ' Get user array Dim users As cJson Set users = json("data")("users") ' Iterate users Dim i As Integer For i = 0 To users.Count - 1 Dim user As cJson Set user = users(i) Debug.Print "ID: " & user("id") Debug.Print "Name: " & user("name") Debug.Print "Email: " & user("email") ' Check if address exists If user.Exists("address") Then Debug.Print "City: " & user("address")("city") End If Debug.Print "---" Next i ' Get pagination info Debug.Print "Total: " & json("data")("pagination")("total") Else Debug.Print "Error: " & json("message") End If End Sub ``` ### Example 3: Usage in Real Projects (from demos) ```vb ' Build JSON response Public Sub Json(ctx As cHttpServerContext) Dim ID As Long: ID = ctx.Request.QueryString("id") With New cJson .Item("id") = ID .Item("face") = ChrW(&H263A) .Item("timestamp") = Now .Item("status") = "success" ctx.Response.Json .Root End With End Sub ' Parse request data Public Sub HandleRequest(ctx As cHttpServerContext) Dim requestData As String requestData = ctx.Request.Body Dim json As cJson Set json = VBMAN.Json.Decode(requestData) Dim username As String Dim password As String username = json("username") password = json("password") ' Process login... End Sub ``` ### Example 4: Database Record to JSON ```vb Private Sub RecordsetToJson(rs As ADODB.Recordset) Dim root As New cJson ' Add metadata root("count") = rs.RecordCount root("timestamp") = Now ' Add data array With root.NewItems("data") Do While Not rs.EOF With .NewItem() Dim i As Integer For i = 0 To rs.Fields.Count - 1 .Item(rs.Fields(i).Name) = rs.Fields(i).Value Next i End With rs.MoveNext Loop End With ' Output Debug.Print root.Encode(, 2) End Sub ``` ### Example 5: INI Config to JSON ```vb Private Sub IniToJson() VBMAN.Ini.LoadFrom App.Path & "\\config.ini" Dim json As New cJson ' Convert all Sections Dim sectionKey As Variant For Each sectionKey In VBMAN.Ini.Root.Keys With json.NewItem(CStr(sectionKey)) Dim key As Variant For Each key In VBMAN.Ini.Root(sectionKey).Keys .Item(key) = VBMAN.Ini.Root(sectionKey)(key) Next key End With Next sectionKey ' Save as JSON file VBMAN.FileEx.SetBufferText(json.Encode(, 2), "UTF-8").SaveData App.Path & "\\config.json" End Sub ``` ## Best Practices 1. **Use Parameters**: When building JSON, try to use NewItem/NewItems 2. **Check Existence**: Use Exists to check if key exists before reading 3. **Error Handling**: Add error handling when parsing JSON 4. **Type Attention**: VB6 is weakly typed, note the difference between numbers and strings 5. **Formatted Output**: Use indentation formatting for easier reading during debugging --- --- url: /zh/vbman/global/logs.md --- # VBMAN.Logs - 日志记录对象 ## 概述 `VBMAN.Logs` 提供了多通道日志记录功能，支持文件日志、窗体显示、网页远程调试等输出方式。 ## 核心特性 * **多通道输出**: 文件、窗体、DbgView、网页远程调试 * **日志级别**: 支持多种日志级别控制 * **异步提交**: 网络日志采用异步方式，不阻塞程序 * **日志查看器**: 内置日志查看窗体 ## 日志级别枚举 ```vb Public Enum EnumLogLevel LvInfo = 0 ' 信息 LvWarn = 1 ' 警告 LvDanger = 2 ' 危险 LvError = 3 ' 错误 LvDebugger = 4 ' 调试 LvCustom = 5 ' 自定义 End Enum ``` ## 日志文件名规则枚举 ```vb Public Enum EnumLogFileNameRule None = 0 ' 无规则 ByMonth = 1 ' 按月份 ByDay = 2 ' 按天 byUser = 3 ' 用户自定义 End Enum ``` ## 属性 | 属性 | 类型 | 说明 | |------|------|------| | `LogLevelControl` | EnumLogLevel | 当前日志控制级别 | | `SendToFormView` | Boolean | 是否输出到窗体 | | `SendToDbgView` | Boolean | 是否输出到 DbgView | | `SendToWebView` | Boolean | 是否输出到网页 | | `FormListBox` | VB.ListBox | 输出到的列表框控件 | | `FormListBoxMaxItem` | Long | 列表框最大条目数 | | `LogDir` | String | 日志文件根目录 | | `LogSubDir` | String | 日志子目录 | | `LogFileNameRule` | EnumLogFileNameRule | 日志文件名规则 | | `LogFileNameByUer` | String | 用户自定义文件名 | | `WebUserCode` | String | 网页调试用户识别码 | | `ShowLogsViewer` | Boolean | 日志查看器是否显示（可读写） | | `LastError` | String | 最后错误信息 | ## 方法 ### HostApp 设置宿主应用程序（链式调用） ```vb Public Function HostApp(o As Object) As cLogs ``` ### View 设置日志查看器显示状态（链式调用） ```vb Public Function View(Value As Boolean) As cLogs ``` ### Data 添加日志数据（链式调用） ```vb Public Function Data(ByVal LogContent As String, Optional ByVal LogTitle As String, Optional LogLevel As EnumLogLevel = LvInfo) As cLogs ``` **示例**: ```vb VBMAN.Logs.Data("用户登录成功", "登录模块", LvInfo) ``` ### DataLine 添加带换行的日志数据（链式调用） ```vb Public Function DataLine(ByVal LogContent As String, Optional ByVal LogTitle As String, Optional LogLevel As EnumLogLevel = LvInfo) As cLogs ``` **示例**: ```vb VBMAN.Logs.DataLine "操作完成" & vbCrLf & "结果: 成功", "业务模块", LvInfo ``` ### ToFormView 输出到窗体列表框 ```vb Public Function ToFormView(LogStr As String, Optional LogLevel As EnumLogLevel) As String ``` ### ToWebView 输出到网页远程调试 ```vb Public Function ToWebView(LogStr As String, Optional LogLevel As EnumLogLevel) As String ``` ## 综合示例 ### 示例1: 基本日志记录 ```vb Private Sub TestLog() ' 简单日志 VBMAN.Logs.Data "程序启动", "系统", LvInfo ' 带标题和级别的日志 VBMAN.Logs.Data "磁盘空间不足", "监控", LvWarn ' 多行日志 VBMAN.Logs.DataLine "发生错误" & vbCrLf & Err.Description, "错误处理", LvError End Sub ``` ### 示例2: 链式调用 ```vb Private Sub ChainLog() VBMAN.Logs _ .HostApp(Me) _ .View(True) _ .Data("初始化完成", "启动", LvInfo) _ .Data("加载配置", "配置", LvInfo) _ .DataLine "配置加载完成", "配置", LvInfo End Sub ``` ### 示例3: 输出到窗体控件 ```vb Private Sub Form_Load() ' 设置输出到 List1 控件 Set VBMAN.Logs.FormListBox = List1 VBMAN.Logs.FormListBoxMaxItem = 500 VBMAN.Logs.SendToFormView = True End Sub Private Sub DoSomething() VBMAN.Logs.Data "正在处理...", "业务", LvInfo ' ... 处理逻辑 VBMAN.Logs.Data "处理完成", "业务", LvInfo End Sub ``` ### 示例4: 网页远程调试 ```vb Private Sub SetupWebLog() ' 设置网页调试用户码（在 http://log.vb6.pro 注册） VBMAN.Logs.WebUserCode = "myapp123" VBMAN.Logs.SendToWebView = True End Sub Private Sub RemoteLog() VBMAN.Logs.ToWebView "远程调试信息", LvInfo End Sub ``` ### 示例5: 打开日志查看器 ```vb Private Sub ShowLogViewer() VBMAN.Logs.ShowLogsViewer = True ' 或 VBMAN.Logs.View(True) End Sub ``` ## 最佳实践 1. **日志级别控制**: 根据环境设置合适的 LogLevelControl 2. **异步网络日志**: 网页调试使用异步提交，不影响性能 3. **日志清理**: 定期清理旧日志文件 4. **敏感信息**: 不要在日志中记录密码等敏感信息 5. **错误处理**: 日志记录失败不应影响主程序运行 --- --- url: /en/vbman/global/logs.md --- # VBMAN.Logs - Log Recording Object ## Overview `VBMAN.Logs` provides multi-channel log recording functionality, supporting file logs, form display, web remote debugging and other output methods. ## Core Features * **Multi-channel Output**: File, form, DbgView, web remote debugging * **Log Levels**: Supports multiple log level controls * **Async Submission**: Network logs use async method, non-blocking * **Log Viewer**: Built-in log viewer form ## Log Level Enum ```vb Public Enum EnumLogLevel LvInfo = 0 ' Information LvWarn = 1 ' Warning LvDanger = 2 ' Danger LvError = 3 ' Error LvDebugger = 4 ' Debug LvCustom = 5 ' Custom End Enum ``` ## Log Filename Rule Enum ```vb Public Enum EnumLogFileNameRule None = 0 ' No rule ByMonth = 1 ' By month ByDay = 2 ' By day byUser = 3 ' User custom End Enum ``` ## Properties | Property | Type | Description | |----------|------|-------------| | `LogLevelControl` | EnumLogLevel | Current log control level | | `SendToFormView` | Boolean | Whether to output to form | | `SendToDbgView` | Boolean | Whether to output to DbgView | | `SendToWebView` | Boolean | Whether to output to web | | `FormListBox` | VB.ListBox | ListBox control to output to | | `FormListBoxMaxItem` | Long | Maximum number of items in ListBox | | `LogDir` | String | Log file root directory | | `LogSubDir` | String | Log subdirectory | | `LogFileNameRule` | EnumLogFileNameRule | Log filename rule | | `LogFileNameByUer` | String | User custom filename | | `WebUserCode` | String | Web debug user identification code | | `ShowLogsViewer` | Boolean | Whether log viewer is shown (read/write) | | `LastError` | String | Last error message | ## Methods ### HostApp Set host application (chain calling) ```vb Public Function HostApp(o As Object) As cLogs ``` ### View Set log viewer display state (chain calling) ```vb Public Function View(Value As Boolean) As cLogs ``` ### Data Add log data (chain calling) ```vb Public Function Data(ByVal LogContent As String, Optional ByVal LogTitle As String, Optional LogLevel As EnumLogLevel = LvInfo) As cLogs ``` **Example**: ```vb VBMAN.Logs.Data("User login successful", "Login Module", LvInfo) ``` ### DataLine Add log data with newline (chain calling) ```vb Public Function DataLine(ByVal LogContent As String, Optional ByVal LogTitle As String, Optional LogLevel As EnumLogLevel = LvInfo) As cLogs ``` **Example**: ```vb VBMAN.Logs.DataLine "Operation completed" & vbCrLf & "Result: Success", "Business Module", LvInfo ``` ### ToFormView Output to form ListBox ```vb Public Function ToFormView(LogStr As String, Optional LogLevel As EnumLogLevel) As String ``` ### ToWebView Output to web remote debugging ```vb Public Function ToWebView(LogStr As String, Optional LogLevel As EnumLogLevel) As String ``` ## Comprehensive Examples ### Example 1: Basic Log Recording ```vb Private Sub TestLog() ' Simple log VBMAN.Logs.Data "Program started", "System", LvInfo ' Log with title and level VBMAN.Logs.Data "Disk space insufficient", "Monitor", LvWarn ' Multi-line log VBMAN.Logs.DataLine "Error occurred" & vbCrLf & Err.Description, "Error Handling", LvError End Sub ``` ### Example 2: Chain Calling ```vb Private Sub ChainLog() VBMAN.Logs _ .HostApp(Me) _ .View(True) _ .Data("Initialization completed", "Startup", LvInfo) _ .Data("Loading configuration", "Config", LvInfo) _ .DataLine "Configuration loading completed", "Config", LvInfo End Sub ``` ### Example 3: Output to Form Control ```vb Private Sub Form_Load() ' Set output to List1 control Set VBMAN.Logs.FormListBox = List1 VBMAN.Logs.FormListBoxMaxItem = 500 VBMAN.Logs.SendToFormView = True End Sub Private Sub DoSomething() VBMAN.Logs.Data "Processing...", "Business", LvInfo ' ... processing logic VBMAN.Logs.Data "Processing completed", "Business", LvInfo End Sub ``` ### Example 4: Web Remote Debugging ```vb Private Sub SetupWebLog() ' Set web debug user code (register at http://log.vb6.pro) VBMAN.Logs.WebUserCode = "myapp123" VBMAN.Logs.SendToWebView = True End Sub Private Sub RemoteLog() VBMAN.Logs.ToWebView "Remote debug info", LvInfo End Sub ``` ### Example 5: Open Log Viewer ```vb Private Sub ShowLogViewer() VBMAN.Logs.ShowLogsViewer = True ' Or VBMAN.Logs.View(True) End Sub ``` ## Best Practices 1. **Log Level Control**: Set appropriate LogLevelControl based on environment 2. **Async Network Logs**: Web debugging uses async submission, does not affect performance 3. **Log Cleanup**: Regularly clean up old log files 4. **Sensitive Information**: Don't record passwords and other sensitive information in logs 5. **Error Handling**: Log recording failure should not affect main program operation --- --- url: /zh/vbman/global/password.md --- # VBMAN.Password - 密码处理对象 ## 概述 `VBMAN.Password` 提供了密码哈希创建和验证功能，使用 MD5 等哈希算法，支持自定义盐值。 ## 核心特性 * **密码哈希**: 使用 MD5 算法生成密码哈希 * **盐值支持**: 支持自定义盐值增强安全性 * **算法选择**: 支持多种哈希算法（通过 Algorithm 属性） * **编码选择**: 支持不同字符编码 ## 属性 | 属性 | 类型 | 说明 | |------|------|------| | `LastError` | String | 最后错误信息（只读） | | `Algorithm` | CryptoHashAlgorithm | 哈希算法（默认 MD5） | | `Salt` | String | 盐值（默认空字符串） | | `Encoding` | CryptoStringEncoding | 字符编码（默认 UTF-8） | ## 方法 ### Create 创建密码哈希 ```vb Public Function Create(ByVal Password As String, Optional ByRef Salt As Variant) As String ``` **参数**: * `Password` - 明文密码 * `Salt` - 盐值（可选，默认使用 Salt 属性） **返回**: 十六进制哈希字符串，失败返回空字符串 **示例**: ```vb ' 基本使用 Dim hash As String hash = VBMAN.Password.Create("mypassword") Debug.Print hash ' MD5 哈希值 ' 使用属性设置盐值 VBMAN.Password.Salt = "mysalt" hash = VBMAN.Password.Create("mypassword") ' 通过参数传递盐值 hash = VBMAN.Password.Create("mypassword", "mysalt") ``` ### Verify 验证密码 ```vb Public Function Verify(ByVal Password As String, ByVal Hash As String) As Boolean ``` **参数**: * `Password` - 明文密码 * `Hash` - 存储的哈希值 **返回**: True=验证通过, False=验证失败 **示例**: ```vb ' 验证密码 Dim isValid As Boolean isValid = VBMAN.Password.Verify("mypassword", storedHash) If isValid Then MsgBox "密码正确" Else MsgBox "密码错误: " & VBMAN.Password.LastError End If ``` ## 综合示例 ### 示例1: 用户注册（创建密码） ```vb Private Sub RegisterUser(username As String, password As String) ' 生成随机盐值（可选） Dim salt As String salt = VBMAN.ToolsStr.GetGUID() ' 使用 GUID 作为盐值 VBMAN.Password.Salt = salt ' 创建密码哈希 Dim passwordHash As String passwordHash = VBMAN.Password.Create(password) If passwordHash = "" Then MsgBox "密码处理失败: " & VBMAN.Password.LastError Exit Sub End If ' 存储到数据库（同时存储哈希和盐值） VBMAN.Db.Sql("INSERT INTO users (username, password_hash, salt) VALUES (?, ?, ?)"). _ Param("username", username). _ Param("password_hash", passwordHash). _ Param("salt", salt). _ ExecParam MsgBox "注册成功！" End Sub ``` ### 示例2: 用户登录（验证密码） ```vb Private Sub LoginUser(username As String, password As String) ' 查询用户信息 VBMAN.Db.Sql("SELECT * FROM users WHERE username=?").Param("username", username).FetchParam If VBMAN.Db.Row.Count = 0 Then MsgBox "用户不存在" Exit Sub End If ' 获取存储的哈希和盐值 Dim storedHash As String Dim salt As String storedHash = VBMAN.Db.Row("password_hash") salt = VBMAN.Db.Row("salt") ' 设置盐值并验证 VBMAN.Password.Salt = salt Dim isValid As Boolean isValid = VBMAN.Password.Verify(password, storedHash) If isValid Then MsgBox "登录成功！" ' 执行登录后的操作... Else MsgBox "密码错误" End If End Sub ``` ### 示例3: 修改密码 ```vb Private Sub ChangePassword(userId As Long, oldPassword As String, newPassword As String) ' 验证旧密码 VBMAN.Db.Sql("SELECT password_hash, salt FROM users WHERE id=?").Param("id", userId).FetchParam VBMAN.Password.Salt = VBMAN.Db.Row("salt") If Not VBMAN.Password.Verify(oldPassword, VBMAN.Db.Row("password_hash")) Then MsgBox "原密码错误" Exit Sub End If ' 生成新盐值和新哈希 Dim newSalt As String newSalt = VBMAN.ToolsStr.GetGUID() VBMAN.Password.Salt = newSalt Dim newHash As String newHash = VBMAN.Password.Create(newPassword) ' 更新数据库 VBMAN.Db.Sql("UPDATE users SET password_hash=?, salt=? WHERE id=?"). _ Param("password_hash", newHash). _ Param("salt", newSalt). _ Param("id", userId). _ ExecParam MsgBox "密码修改成功！" End Sub ``` ## 最佳实践 1. **使用盐值**: 始终使用盐值增强安全性，每个用户使用不同的盐值 2. **存储盐值**: 盐值需要与哈希一起存储，用于验证时 3. **密码复杂度**: 建议在前端验证密码复杂度（长度、字符类型等） 4. **算法选择**: 根据安全需求选择合适的哈希算法 5. **错误处理**: 检查 LastError 获取详细的错误信息 ## 注意事项 * 默认使用 MD5 算法，如有更高安全需求可更换其他算法 * 盐值是重要的安全措施，不要固定使用同一个盐值 * 密码哈希是单向的，无法从哈希还原原始密码 --- --- url: /en/vbman/global/password.md --- # VBMAN.Password - Password Processing Object ## Overview `VBMAN.Password` provides password hash creation and verification functionality, using MD5 and other hash algorithms, supporting custom salt values. ## Core Features * **Password Hash**: Generate password hash using MD5 algorithm * **Salt Support**: Support custom salt values to enhance security * **Algorithm Selection**: Support multiple hash algorithms (via Algorithm property) * **Encoding Selection**: Support different character encodings ## Properties | Property | Type | Description | |----------|------|-------------| | `LastError` | String | Last error message (read-only) | | `Algorithm` | CryptoHashAlgorithm | Hash algorithm (default MD5) | | `Salt` | String | Salt value (default empty string) | | `Encoding` | CryptoStringEncoding | Character encoding (default UTF-8) | ## Methods ### Create Create password hash ```vb Public Function Create(ByVal Password As String, Optional ByRef Salt As Variant) As String ``` **Parameters**: * `Password` - Plain text password * `Salt` - Salt value (optional, default uses Salt property) **Returns**: Hexadecimal hash string, returns empty string on failure **Example**: ```vb ' Basic usage Dim hash As String hash = VBMAN.Password.Create("mypassword") Debug.Print hash ' MD5 hash value ' Set salt via property VBMAN.Password.Salt = "mysalt" hash = VBMAN.Password.Create("mypassword") ' Pass salt via parameter hash = VBMAN.Password.Create("mypassword", "mysalt") ``` ### Verify Verify password ```vb Public Function Verify(ByVal Password As String, ByVal Hash As String) As Boolean ``` **Parameters**: * `Password` - Plain text password * `Hash` - Stored hash value **Returns**: True=verification passed, False=verification failed **Example**: ```vb ' Verify password Dim isValid As Boolean isValid = VBMAN.Password.Verify("mypassword", storedHash) If isValid Then MsgBox "Password correct" Else MsgBox "Password error: " & VBMAN.Password.LastError End If ``` ## Comprehensive Examples ### Example 1: User Registration (Create Password) ```vb Private Sub RegisterUser(username As String, password As String) ' Generate random salt (optional) Dim salt As String salt = VBMAN.ToolsStr.GetGUID() ' Use GUID as salt VBMAN.Password.Salt = salt ' Create password hash Dim passwordHash As String passwordHash = VBMAN.Password.Create(password) If passwordHash = "" Then MsgBox "Password processing failed: " & VBMAN.Password.LastError Exit Sub End If ' Store to database (store hash and salt together) VBMAN.Db.Sql("INSERT INTO users (username, password_hash, salt) VALUES (?, ?, ?)"). _ Param("username", username). _ Param("password_hash", passwordHash). _ Param("salt", salt). _ ExecParam MsgBox "Registration successful!" End Sub ``` ### Example 2: User Login (Verify Password) ```vb Private Sub LoginUser(username As String, password As String) ' Query user info VBMAN.Db.Sql("SELECT * FROM users WHERE username=?").Param("username", username).FetchParam If VBMAN.Db.Row.Count = 0 Then MsgBox "User does not exist" Exit Sub End If ' Get stored hash and salt Dim storedHash As String Dim salt As String storedHash = VBMAN.Db.Row("password_hash") salt = VBMAN.Db.Row("salt") ' Set salt and verify VBMAN.Password.Salt = salt Dim isValid As Boolean isValid = VBMAN.Password.Verify(password, storedHash) If isValid Then MsgBox "Login successful!" ' Execute post-login operations... Else MsgBox "Password error" End If End Sub ``` ### Example 3: Change Password ```vb Private Sub ChangePassword(userId As Long, oldPassword As String, newPassword As String) ' Verify old password VBMAN.Db.Sql("SELECT password_hash, salt FROM users WHERE id=?").Param("id", userId).FetchParam VBMAN.Password.Salt = VBMAN.Db.Row("salt") If Not VBMAN.Password.Verify(oldPassword, VBMAN.Db.Row("password_hash")) Then MsgBox "Old password error" Exit Sub End If ' Generate new salt and new hash Dim newSalt As String newSalt = VBMAN.ToolsStr.GetGUID() VBMAN.Password.Salt = newSalt Dim newHash As String newHash = VBMAN.Password.Create(newPassword) ' Update database VBMAN.Db.Sql("UPDATE users SET password_hash=?, salt=? WHERE id=?"). _ Param("password_hash", newHash). _ Param("salt", newSalt). _ Param("id", userId). _ ExecParam MsgBox "Password changed successfully!" End Sub ``` ## Best Practices 1. **Use Salt**: Always use salt to enhance security, each user uses different salt 2. **Store Salt**: Salt needs to be stored together with hash for verification 3. **Password Complexity**: Recommend verifying password complexity on frontend (length, character types, etc.) 4. **Algorithm Selection**: Choose appropriate hash algorithm based on security requirements 5. **Error Handling**: Check LastError for detailed error information ## Notes * Default uses MD5 algorithm, can switch to other algorithms for higher security requirements * Salt is an important security measure, don't use the same fixed salt * Password hash is one-way, cannot restore original password from hash --- --- url: /zh/vbman/global/pli.md --- # VBMAN.PLI - 插件接口对象 ## 概述 `VBMAN.PLI` 提供了与外部插件程序通信的功能，通过执行外部程序并传递参数来实现扩展功能。 ## 核心特性 * **插件执行**: 调用外部插件程序 * **参数传递**: 支持 Base64 编码的参数传递 * **超时控制**: 可设置执行超时时间 * **结果获取**: 支持从文件获取返回结果 ## 属性 | 属性 | 类型 | 说明 | |------|------|------| | `TimeOut` | Long | 执行超时时间（毫秒，默认 30 秒） | ## 方法 ### Request 发送请求到插件 ```vb Public Function Request(ParamArray Data() As Variant) As String ``` **参数**: * `Data` - 可变参数数组，参数会自动进行 Base64 编码 **返回**: 插件返回的结果字符串 **说明**: * 插件程序会按顺序查找: `App.Path\VBMAN.PLI`、`App.Path\bin\VBMAN.PLI`、`App.Path\..\bin\VBMAN.PLI` * 参数通过 Base64 编码后用 `|` 分隔传递 * 如果返回值为 `VBMAN.DAT`，则从 `VBMAN.DAT` 文件中读取实际结果 **示例**: ```vb ' 发送简单请求 Dim result As String result = VBMAN.PLI.Request("command", "param1", "param2") ' 处理结果 If result <> "" Then Debug.Print "插件返回: " & result End If ``` ## 综合示例 ### 示例1: 基本使用 ```vb Private Sub CallPlugin() ' 设置超时时间（可选，默认 30 秒） VBMAN.PLI.TimeOut = 60000 ' 60 秒 ' 调用插件 Dim result As String result = VBMAN.PLI.Request("process", "data1", "data2") If result <> "" Then MsgBox "处理结果: " & result Else MsgBox "调用失败或无返回" End If End Sub ``` ### 示例2: 处理文件结果 ```vb Private Sub CallPluginWithFileResult() Dim result As String result = VBMAN.PLI.Request("generate_report", "2024-01-01", "2024-12-31") ' 如果插件返回 VBMAN.DAT，表示结果在文件中 If result = "VBMAN.DAT" Then Dim fileContent As String fileContent = VBMAN.ToolsStream.LoadFileAsText(App.Path & "\VBMAN.DAT") Debug.Print fileContent End If End Sub ``` ## 插件规范 插件程序需要遵循以下规范： 1. 可执行文件命名为 `VBMAN.PLI` 2. 接收 Base64 编码的参数（用 `|` 分隔） 3. 支持 `VBMAN.PSC` 作为脚本文件参数 4. 可通过输出或 `VBMAN.DAT` 文件返回结果 ## 注意事项 * 插件程序必须存在于指定搜索路径中 * 参数会自动进行 Base64 编码 * 超时后会强制终止插件进程 --- --- url: /en/vbman/global/pli.md --- # VBMAN.PLI - Plugin Interface Object ## Overview `VBMAN.PLI` provides functionality for communicating with external plugin programs, implementing extended functionality by executing external programs and passing parameters. ## Core Features * **Plugin Execution**: Call external plugin programs * **Parameter Passing**: Support Base64 encoded parameter passing * **Timeout Control**: Configurable execution timeout * **Result Retrieval**: Support getting return results from file ## Properties | Property | Type | Description | |----------|------|-------------| | `TimeOut` | Long | Execution timeout (milliseconds, default 30 seconds) | ## Methods ### Request Send request to plugin ```vb Public Function Request(ParamArray Data() As Variant) As String ``` **Parameters**: * `Data` - Variable parameter array, parameters are automatically Base64 encoded **Returns**: Result string returned by plugin **Description**: * Plugin program will be searched in order: `App.Path\VBMAN.PLI`, `App.Path\bin\VBMAN.PLI`, `App.Path\..\bin\VBMAN.PLI` * Parameters are passed separated by `|` after Base64 encoding * If return value is `VBMAN.DAT`, actual result is read from `VBMAN.DAT` file **Example**: ```vb ' Send simple request Dim result As String result = VBMAN.PLI.Request("command", "param1", "param2") ' Process result If result <> "" Then Debug.Print "Plugin returned: " & result End If ``` ## Comprehensive Examples ### Example 1: Basic Usage ```vb Private Sub CallPlugin() ' Set timeout (optional, default 30 seconds) VBMAN.PLI.TimeOut = 60000 ' 60 seconds ' Call plugin Dim result As String result = VBMAN.PLI.Request("process", "data1", "data2") If result <> "" Then MsgBox "Processing result: " & result Else MsgBox "Call failed or no return" End If End Sub ``` ### Example 2: Process File Result ```vb Private Sub CallPluginWithFileResult() Dim result As String result = VBMAN.PLI.Request("generate_report", "2024-01-01", "2024-12-31") ' If plugin returns VBMAN.DAT, result is in file If result = "VBMAN.DAT" Then Dim fileContent As String fileContent = VBMAN.ToolsStream.LoadFileAsText(App.Path & "\VBMAN.DAT") Debug.Print fileContent End If End Sub ``` ## Plugin Specification Plugin programs need to follow these specifications: 1. Executable file named `VBMAN.PLI` 2. Receive Base64 encoded parameters (separated by `|`) 3. Support `VBMAN.PSC` as script file parameter 4. Can return results via output or `VBMAN.DAT` file ## Notes * Plugin program must exist in specified search path * Parameters are automatically Base64 encoded * Process will be forcibly terminated after timeout --- --- url: /zh/vbman/global/qrcode.md --- # VBMAN.QRcode - 二维码生成对象 ## 概述 `VBMAN.QRcode` 提供了二维码生成功能，使用链式调用方式设置参数并生成二维码图片。 ## 核心特性 * **链式调用**: 流畅的 API 设计 * **自定义内容**: 支持任意文本内容 * **自定义大小**: 可设置二维码尺寸 * **自定义颜色**: 可设置前景色 * **剪贴板支持**: 可直接复制到剪贴板 ## 方法 ### SetText 设置二维码内容（链式调用） ```vb Public Function SetText(ByVal Content As Variant) As cQRcode ``` **参数**: * `Content` - 二维码内容（文本） **示例**: ```vb VBMAN.QRcode.SetText("https://www.vb6.pro") ``` ### SetSize 设置二维码大小（链式调用） ```vb Public Function SetSize(ByVal Size As Long) As cQRcode ``` **参数**: * `Size` - 二维码尺寸（像素） **示例**: ```vb VBMAN.QRcode.SetSize(200) ``` ### SetForeColor 设置前景色（链式调用） ```vb Public Function SetForeColor(ByVal ForeColor As OLE_COLOR) As cQRcode ``` **参数**: * `ForeColor` - 前景色（VB 颜色常量或 RGB 值） **示例**: ```vb VBMAN.QRcode.SetForeColor(vbBlue) VBMAN.QRcode.SetForeColor(RGB(255, 0, 0)) ``` ### Generate 生成二维码图片 ```vb Public Function Generate(Optional ByVal IsCopyToClipboard As Boolean) As StdPicture ``` **参数**: * `IsCopyToClipboard` - 是否同时复制到剪贴板（默认 False） **返回**: StdPicture 对象 **示例**: ```vb ' 生成二维码 Dim qrPic As StdPicture Set qrPic = VBMAN.QRcode.Generate ' 显示到图片框 Set Picture1.Picture = qrPic ' 生成并复制到剪贴板 Set qrPic = VBMAN.QRcode.Generate(True) ``` ## 综合示例 ### 示例1: 基本使用 ```vb Private Sub GenerateQR() ' 设置内容、大小、颜色 With VBMAN.QRcode .SetText("Hello VB6!") .SetSize(150) .SetForeColor(vbBlack) ' 生成并显示 Set Picture1.Picture = .Generate End With End Sub ``` ### 示例2: 网址二维码 ```vb Private Sub GenerateUrlQR() Dim url As String url = "https://github.com/vb6pro/vbman" Set Picture1.Picture = VBMAN.QRcode _ .SetText(url) _ .SetSize(200) _ .SetForeColor(RGB(0, 102, 204)) _ .Generate(True) ' 同时复制到剪贴板 MsgBox "二维码已生成并复制到剪贴板！" End Sub ``` ### 示例3: 保存为图片文件 ```vb Private Sub SaveQRCode() ' 生成二维码 Dim qrPic As StdPicture Set qrPic = VBMAN.QRcode _ .SetText(TextContent.Text) _ .SetSize(300) _ .Generate ' 显示 Set Picture1.Picture = qrPic ' 保存为图片（需要引用 GDI+ 或使用 SavePicture） SavePicture qrPic, App.Path & "\\qrcode.bmp" MsgBox "已保存到: " & App.Path & "\\qrcode.bmp" End Sub ``` ## 默认值 * **默认内容**: `"hello vbman form www.vb6.pro"` * **默认大小**: `50` 像素 * **默认颜色**: `vbBlack`（黑色） ## 最佳实践 1. **尺寸选择**: 根据显示需求和扫描距离选择合适的大小 2. **颜色对比**: 确保前景色与背景色有足够对比度 3. **内容长度**: 内容过长会导致二维码密集，建议缩短 URL 或使用短链接 4. **错误处理**: 生成失败时返回 Nothing，需进行检查 --- --- url: /en/vbman/global/qrcode.md --- # VBMAN.QRcode - QR Code Generation Object ## Overview `VBMAN.QRcode` provides QR code generation functionality, using chain calling to set parameters and generate QR code images. ## Core Features * **Chain Calling**: Fluent API design * **Custom Content**: Support any text content * **Custom Size**: Configurable QR code size * **Custom Color**: Configurable foreground color * **Clipboard Support**: Can copy directly to clipboard ## Methods ### SetText Set QR code content (chain calling) ```vb Public Function SetText(ByVal Content As Variant) As cQRcode ``` **Parameters**: * `Content` - QR code content (text) **Example**: ```vb VBMAN.QRcode.SetText("https://www.vb6.pro") ``` ### SetSize Set QR code size (chain calling) ```vb Public Function SetSize(ByVal Size As Long) As cQRcode ``` **Parameters**: * `Size` - QR code size (pixels) **Example**: ```vb VBMAN.QRcode.SetSize(200) ``` ### SetForeColor Set foreground color (chain calling) ```vb Public Function SetForeColor(ByVal ForeColor As OLE_COLOR) As cQRcode ``` **Parameters**: * `ForeColor` - Foreground color (VB color constant or RGB value) **Example**: ```vb VBMAN.QRcode.SetForeColor(vbBlue) VBMAN.QRcode.SetForeColor(RGB(255, 0, 0)) ``` ### Generate Generate QR code image ```vb Public Function Generate(Optional ByVal IsCopyToClipboard As Boolean) As StdPicture ``` **Parameters**: * `IsCopyToClipboard` - Whether to also copy to clipboard (default False) **Returns**: StdPicture object **Example**: ```vb ' Generate QR code Dim qrPic As StdPicture Set qrPic = VBMAN.QRcode.Generate ' Display in picture box Set Picture1.Picture = qrPic ' Generate and copy to clipboard Set qrPic = VBMAN.QRcode.Generate(True) ``` ## Comprehensive Examples ### Example 1: Basic Usage ```vb Private Sub GenerateQR() ' Set content, size, color With VBMAN.QRcode .SetText("Hello VB6!") .SetSize(150) .SetForeColor(vbBlack) ' Generate and display Set Picture1.Picture = .Generate End With End Sub ``` ### Example 2: URL QR Code ```vb Private Sub GenerateUrlQR() Dim url As String url = "https://github.com/vb6pro/vbman" Set Picture1.Picture = VBMAN.QRcode _ .SetText(url) _ .SetSize(200) _ .SetForeColor(RGB(0, 102, 204)) _ .Generate(True) ' Also copy to clipboard MsgBox "QR code generated and copied to clipboard!" End Sub ``` ### Example 3: Save as Image File ```vb Private Sub SaveQRCode() ' Generate QR code Dim qrPic As StdPicture Set qrPic = VBMAN.QRcode _ .SetText(TextContent.Text) _ .SetSize(300) _ .Generate ' Display Set Picture1.Picture = qrPic ' Save as image (requires GDI+ reference or use SavePicture) SavePicture qrPic, App.Path & "\\qrcode.bmp" MsgBox "Saved to: " & App.Path & "\\qrcode.bmp" End Sub ``` ## Default Values * **Default Content**: `"hello vbman from www.vb6.pro"` * **Default Size**: `50` pixels * **Default Color**: `vbBlack` (black) ## Best Practices 1. **Size Selection**: Choose appropriate size based on display needs and scanning distance 2. **Color Contrast**: Ensure sufficient contrast between foreground and background colors 3. **Content Length**: Too long content will make QR code dense, recommend shortening URL or using short links 4. **Error Handling**: Returns Nothing when generation fails, needs to be checked --- --- url: /zh/vbman/global/regedit.md --- # VBMAN.Regedit - 注册表操作对象 ## 概述 `VBMAN.Regedit` 提供了 Windows 注册表的读写操作功能，通过调用 `reg` 命令行工具实现。 ## 核心特性 * **查询注册表项**: 支持查询指定路径下的键值 * **添加/修改键值**: 支持创建或更新注册表项 * **删除键值**: 支持删除指定的注册表项 * **类型安全**: 使用 TypeRegData 类型封装返回值 ## 数据结构 ### TypeRegData 注册表项数据结构 ```vb Public Type TypeRegData HasName As Boolean ' 是否有名称 RegName As String ' 键名 RegType As String ' 类型 (REG_SZ, REG_DWORD 等) RegValue As String ' 键值 End Type ``` ## 属性 | 属性 | 类型 | 说明 | |------|------|------| | `LastError` | String | 最后错误信息 | ## 方法 ### FindItem 查询注册表项，返回数组 ```vb Public Function FindItem(ByVal Path As String, Optional ByVal Name As String) As TypeRegData() ``` **参数**: * `Path` - 注册表路径，如 `"HKCU\Software\Microsoft\Windows\CurrentVersion\Run"` * `Name` - 键名（可选，为空则返回所有键） **返回**: TypeRegData 数组 **示例**: ```vb Dim items() As TypeRegData items = VBMAN.Regedit.FindItem("HKCU\Software\Microsoft\Windows\CurrentVersion\Run") Dim i As Long For i = LBound(items) To UBound(items) If items(i).HasName Then Debug.Print items(i).RegName & " = " & items(i).RegValue End If Next i ``` ### FindFirst 查询第一个匹配的注册表值 ```vb Public Function FindFirst(ByVal Path As String, Optional ByVal Name As String) As Variant ``` **返回**: 键值（字符串），未找到返回空字符串 **示例**: ```vb Dim value As Variant value = VBMAN.Regedit.FindFirst("HKCU\Software\Microsoft\Windows\CurrentVersion\Run", "Notepad") If value <> vbNullString Then Debug.Print "找到值: " & value End If ``` ### FindLast 查询最后一个匹配的注册表值 ```vb Public Function FindLast(ByVal Path As String, Optional ByVal Name As String) As Variant ``` ### SaveItem 添加或修改注册表项 ```vb Public Function SaveItem(ByVal Path As String, ByVal Name As String, ByVal Data As Variant, Optional StartArgs As Variant, Optional IsOverWrite As Boolean = True) As Boolean ``` **参数**: * `Path` - 注册表路径 * `Name` - 键名 * `Data` - 键值 * `StartArgs` - 启动参数（可选） * `IsOverWrite` - 是否覆盖（默认 True） **返回**: True=成功, False=失败 **示例**: ```vb ' 添加开机启动项 Dim success As Boolean success = VBMAN.Regedit.SaveItem( _ "HKCU\Software\Microsoft\Windows\CurrentVersion\Run", _ "MyApp", _ "C:\MyApp\app.exe" _ ) If success Then MsgBox "添加成功" Else MsgBox "添加失败: " & VBMAN.Regedit.LastError End If ``` ### DeleteItem 删除注册表项 ```vb Public Function DeleteItem(ByVal Path As String, ByVal Name As String) As Boolean ``` **示例**: ```vb ' 删除开机启动项 Dim success As Boolean success = VBMAN.Regedit.DeleteItem("HKCU\Software\Microsoft\Windows\CurrentVersion\Run", "MyApp") ``` ## 综合示例 ### 示例1: 管理开机启动项 ```vb Private Sub ManageStartup() Const RUN_PATH As String = "HKCU\Software\Microsoft\Windows\CurrentVersion\Run" ' 添加启动项 VBMAN.Regedit.SaveItem RUN_PATH, "MyApplication", App.Path & "\" & App.EXEName & ".exe" ' 查询所有启动项 Dim items() As TypeRegData items = VBMAN.Regedit.FindItem(RUN_PATH) Dim i As Long For i = LBound(items) To UBound(items) If items(i).HasName Then List1.AddItem items(i).RegName & " = " & items(i).RegValue End If Next i ' 删除启动项 ' VBMAN.Regedit.DeleteItem RUN_PATH, "MyApplication" End Sub ``` ### 示例2: 读取系统信息 ```vb Private Sub ReadSystemInfo() ' 读取 Windows 版本 Dim version As Variant version = VBMAN.Regedit.FindFirst("HKLM\SOFTWARE\Microsoft\Windows NT\CurrentVersion", "DisplayVersion") Debug.Print "Windows 版本: " & version ' 读取计算机名 Dim computerName As Variant computerName = VBMAN.Regedit.FindFirst("HKLM\SYSTEM\CurrentControlSet\Control\ComputerName\ComputerName", "ComputerName") Debug.Print "计算机名: " & computerName End Sub ``` ## 最佳实践 1. **错误检查**: 操作后检查 `LastError` 或使用返回值判断 2. **权限注意**: 修改 HKLM 需要管理员权限 3. **备份注册表**: 大规模修改前建议备份 4. **使用常量**: 将常用路径定义为常量 ## 注意事项 * 注册表操作需要谨慎，错误修改可能导致系统问题 * 部分操作可能需要管理员权限 * 通过 `reg` 命令执行，依赖系统命令行工具 --- --- url: /en/vbman/global/regedit.md --- # VBMAN.Regedit - Registry Operation Object ## Overview `VBMAN.Regedit` provides Windows registry read/write functionality, implemented by calling the `reg` command line tool. ## Core Features * **Query Registry Items**: Support querying keys under specified path * **Add/Modify Key Values**: Support creating or updating registry items * **Delete Key Values**: Support deleting specified registry items * **Type Safety**: Use TypeRegData type to encapsulate return values ## Data Structure ### TypeRegData Registry item data structure ```vb Public Type TypeRegData HasName As Boolean ' Whether has name RegName As String ' Key name RegType As String ' Type (REG_SZ, REG_DWORD, etc.) RegValue As String ' Key value End Type ``` ## Properties | Property | Type | Description | |----------|------|-------------| | `LastError` | String | Last error message | ## Methods ### FindItem Query registry items, return array ```vb Public Function FindItem(ByVal Path As String, Optional ByVal Name As String) As TypeRegData() ``` **Parameters**: * `Path` - Registry path, e.g., `"HKCU\Software\Microsoft\Windows\CurrentVersion\Run"` * `Name` - Key name (optional, if empty returns all keys) **Returns**: TypeRegData array **Example**: ```vb Dim items() As TypeRegData items = VBMAN.Regedit.FindItem("HKCU\Software\Microsoft\Windows\CurrentVersion\Run") Dim i As Long For i = LBound(items) To UBound(items) If items(i).HasName Then Debug.Print items(i).RegName & " = " & items(i).RegValue End If Next i ``` ### FindFirst Query first matching registry value ```vb Public Function FindFirst(ByVal Path As String, Optional ByVal Name As String) As Variant ``` **Returns**: Key value (string), returns empty string if not found **Example**: ```vb Dim value As Variant value = VBMAN.Regedit.FindFirst("HKCU\Software\Microsoft\Windows\CurrentVersion\Run", "Notepad") If value <> vbNullString Then Debug.Print "Found value: " & value End If ``` ### FindLast Query last matching registry value ```vb Public Function FindLast(ByVal Path As String, Optional ByVal Name As String) As Variant ``` ### SaveItem Add or modify registry item ```vb Public Function SaveItem(ByVal Path As String, ByVal Name As String, ByVal Data As Variant, Optional StartArgs As Variant, Optional IsOverWrite As Boolean = True) As Boolean ``` **Parameters**: * `Path` - Registry path * `Name` - Key name * `Data` - Key value * `StartArgs` - Startup parameters (optional) * `IsOverWrite` - Whether to overwrite (default True) **Returns**: True=success, False=failure **Example**: ```vb ' Add startup item Dim success As Boolean success = VBMAN.Regedit.SaveItem( _ "HKCU\Software\Microsoft\Windows\CurrentVersion\Run", _ "MyApp", _ "C:\MyApp\app.exe" _ ) If success Then MsgBox "Add successful" Else MsgBox "Add failed: " & VBMAN.Regedit.LastError End If ``` ### DeleteItem Delete registry item ```vb Public Function DeleteItem(ByVal Path As String, ByVal Name As String) As Boolean ``` **Example**: ```vb ' Delete startup item Dim success As Boolean success = VBMAN.Regedit.DeleteItem("HKCU\Software\Microsoft\Windows\CurrentVersion\Run", "MyApp") ``` ## Comprehensive Examples ### Example 1: Manage Startup Items ```vb Private Sub ManageStartup() Const RUN_PATH As String = "HKCU\Software\Microsoft\Windows\CurrentVersion\Run" ' Add startup item VBMAN.Regedit.SaveItem RUN_PATH, "MyApplication", App.Path & "\" & App.EXEName & ".exe" ' Query all startup items Dim items() As TypeRegData items = VBMAN.Regedit.FindItem(RUN_PATH) Dim i As Long For i = LBound(items) To UBound(items) If items(i).HasName Then List1.AddItem items(i).RegName & " = " & items(i).RegValue End If Next i ' Delete startup item ' VBMAN.Regedit.DeleteItem RUN_PATH, "MyApplication" End Sub ``` ### Example 2: Read System Information ```vb Private Sub ReadSystemInfo() ' Read Windows version Dim version As Variant version = VBMAN.Regedit.FindFirst("HKLM\SOFTWARE\Microsoft\Windows NT\CurrentVersion", "DisplayVersion") Debug.Print "Windows version: " & version ' Read computer name Dim computerName As Variant computerName = VBMAN.Regedit.FindFirst("HKLM\SYSTEM\CurrentControlSet\Control\ComputerName\ComputerName", "ComputerName") Debug.Print "Computer name: " & computerName End Sub ``` ## Best Practices 1. **Error Checking**: Check `LastError` or use return value to determine result after operation 2. **Permission Note**: Modifying HKLM requires administrator privileges 3. **Backup Registry**: Recommend backing up before large-scale modifications 4. **Use Constants**: Define commonly used paths as constants ## Notes * Registry operations need to be cautious, incorrect modifications may cause system issues * Some operations may require administrator privileges * Executed through `reg` command, depends on system command line tools --- --- url: /zh/vbman/global/startup.md --- # VBMAN.StartUp - 开机启动管理对象 ## 概述 `VBMAN.StartUp` 提供了管理 Windows 开机启动项的功能，通过操作注册表实现。 ## 核心特性 * **添加/删除启动项**: 一键切换开机启动状态 * **状态检查**: 检查指定程序是否已设置为开机启动 * **灵活路径**: 支持字符串路径或 App 对象 ## 属性 | 属性 | 类型 | 说明 | |------|------|------| | `LastError` | String | 最后错误信息 | ## 方法 ### Has 检查是否已设置为开机启动 ```vb Public Function Has(ByVal Name As String) As Boolean ``` **参数**: * `Name` - 启动项名称 **返回**: True=已存在, False=不存在 **示例**: ```vb If VBMAN.StartUp.Has("MyApplication") Then CheckBoxStartup.Value = vbChecked Else CheckBoxStartup.Value = vbUnchecked End If ``` ### Toggle 切换开机启动状态 ```vb Public Function Toggle(ByVal Name As String, ByRef Path As Variant, ParamArray StartArgs() As Variant) As Boolean ``` **参数**: * `Name` - 启动项名称 * `Path` - 程序路径（可以是字符串或 App 对象） * `StartArgs` - 启动参数（可选，可变参数） **返回**: True=操作成功, False=失败 **说明**: 如果启动项已存在则删除，不存在则添加 **示例**: ```vb ' 使用字符串路径 VBMAN.StartUp.Toggle "MyApp", "C:\Program Files\MyApp\app.exe" ' 使用 App 对象（推荐） VBMAN.StartUp.Toggle "MyApplication", App ' 带启动参数 VBMAN.StartUp.Toggle "MyApp", App, "--minimized", "--auto-start" ``` ## 综合示例 ### 示例1: 开机启动开关 ```vb Private Sub CheckBoxStartup_Click() Dim success As Boolean If CheckBoxStartup.Value = vbChecked Then ' 添加到开机启动 success = VBMAN.StartUp.Toggle("MyApplication", App) If Not success Then MsgBox "设置开机启动失败: " & VBMAN.StartUp.LastError CheckBoxStartup.Value = vbUnchecked End If Else ' 从开机启动移除 success = VBMAN.StartUp.Toggle("MyApplication", App) If Not success Then MsgBox "取消开机启动失败: " & VBMAN.StartUp.LastError CheckBoxStartup.Value = vbChecked End If End If End Sub Private Sub Form_Load() ' 检查当前启动状态 CheckBoxStartup.Value = IIf(VBMAN.StartUp.Has("MyApplication"), vbChecked, vbUnchecked) End Sub ``` ### 示例2: 带参数的开机启动 ```vb Private Sub SetAutoStartWithParams() ' 设置开机启动，并传递参数 Dim success As Boolean success = VBMAN.StartUp.Toggle("MyApp", App, "--silent", "--tray") If success Then MsgBox "开机启动设置成功！" Else MsgBox "设置失败: " & VBMAN.StartUp.LastError End If End Sub ``` ## 最佳实践 1. **使用 App 对象**: 推荐使用 App 对象而不是硬编码路径 2. **名称规范**: 使用有意义的名称，建议使用应用程序名称 3. **用户确认**: 修改开机启动前最好获得用户确认 4. **权限注意**: 某些环境可能需要管理员权限才能修改启动项 --- --- url: /en/vbman/global/startup.md --- # VBMAN.StartUp - Startup Management Object ## Overview `VBMAN.StartUp` provides Windows startup item management functionality, implemented through registry operations. ## Core Features * **Add/Remove Startup Items**: One-click toggle startup status * **Status Check**: Check if specified program is set to startup * **Flexible Path**: Support string path or App object ## Properties | Property | Type | Description | |----------|------|-------------| | `LastError` | String | Last error message | ## Methods ### Has Check if already set to startup ```vb Public Function Has(ByVal Name As String) As Boolean ``` **Parameters**: * `Name` - Startup item name **Returns**: True=exists, False=does not exist **Example**: ```vb If VBMAN.StartUp.Has("MyApplication") Then CheckBoxStartup.Value = vbChecked Else CheckBoxStartup.Value = vbUnchecked End If ``` ### Toggle Toggle startup status ```vb Public Function Toggle(ByVal Name As String, ByRef Path As Variant, ParamArray StartArgs() As Variant) As Boolean ``` **Parameters**: * `Name` - Startup item name * `Path` - Program path (can be string or App object) * `StartArgs` - Startup parameters (optional, variable parameters) **Returns**: True=operation successful, False=failure **Description**: If startup item exists, delete it; if not exists, add it **Example**: ```vb ' Use string path VBMAN.StartUp.Toggle "MyApp", "C:\Program Files\MyApp\app.exe" ' Use App object (recommended) VBMAN.StartUp.Toggle "MyApplication", App ' With startup parameters VBMAN.StartUp.Toggle "MyApp", App, "--minimized", "--auto-start" ``` ## Comprehensive Examples ### Example 1: Startup Toggle Switch ```vb Private Sub CheckBoxStartup_Click() Dim success As Boolean If CheckBoxStartup.Value = vbChecked Then ' Add to startup success = VBMAN.StartUp.Toggle("MyApplication", App) If Not success Then MsgBox "Failed to set startup: " & VBMAN.StartUp.LastError CheckBoxStartup.Value = vbUnchecked End If Else ' Remove from startup success = VBMAN.StartUp.Toggle("MyApplication", App) If Not success Then MsgBox "Failed to cancel startup: " & VBMAN.StartUp.LastError CheckBoxStartup.Value = vbChecked End If End If End Sub Private Sub Form_Load() ' Check current startup status CheckBoxStartup.Value = IIf(VBMAN.StartUp.Has("MyApplication"), vbChecked, vbUnchecked) End Sub ``` ### Example 2: Startup with Parameters ```vb Private Sub SetAutoStartWithParams() ' Set startup and pass parameters Dim success As Boolean success = VBMAN.StartUp.Toggle("MyApp", App, "--silent", "--tray") If success Then MsgBox "Startup set successfully!" Else MsgBox "Setup failed: " & VBMAN.StartUp.LastError End If End Sub ``` ## Best Practices 1. **Use App Object**: Recommend using App object instead of hardcoding path 2. **Name Convention**: Use meaningful names, recommend using application name 3. **User Confirmation**: Best to get user confirmation before modifying startup 4. **Permission Note**: Some environments may require administrator privileges to modify startup items --- --- url: /zh/vbman/global/timeuse.md --- # VBMAN.TimeUse - 计时器对象 ## 概述 `VBMAN.TimeUse` 提供了简单的代码执行时间测量功能，使用 `GetTickCount` API 实现。 ## 核心特性 * **简单易用**: 开始计时和显示耗时 * **自定义输出格式**: 支持自定义输出文本模板 ## 方法 ### Start 开始计时 ```vb Public Sub Start() ``` **示例**: ```vb VBMAN.TimeUse.Start ``` ### Show 显示耗时 ```vb Public Function Show(Optional Txt As String = "耗时：{*} 毫秒") As Variant ``` **参数**: * `Txt` - 输出文本模板，使用 `{*}` 作为耗时占位符 **返回**: 格式化后的字符串 **示例**: ```vb ' 默认格式 Debug.Print VBMAN.TimeUse.Show ' 输出: 耗时：123 毫秒 ' 自定义格式 Debug.Print VBMAN.TimeUse.Show("执行时间: {*} ms") ' 输出: 执行时间: 123 ms ``` ## 综合示例 ### 示例1: 测量代码执行时间 ```vb Private Sub TestPerformance() ' 开始计时 VBMAN.TimeUse.Start ' 要测量的代码 Dim i As Long Dim sum As Long For i = 1 To 1000000 sum = sum + i Next i ' 显示耗时 Debug.Print VBMAN.TimeUse.Show("循环计算耗时: {*} 毫秒") End Sub ``` ### 示例2: 函数执行时间记录 ```vb Private Sub ProcessData() VBMAN.TimeUse.Start ' 数据处理逻辑 Call LoadDataFromDatabase Call ProcessRecords Call SaveResults ' 记录到日志 VBMAN.Logs.DataLine VBMAN.TimeUse.Show("数据处理完成，耗时: {*} 毫秒"), "性能统计" End Sub ``` ## 注意事项 * 使用 `GetTickCount` API，精度为毫秒级 * 计时器在调用 `Start` 后重新开始计时 * 如果需要更高精度，建议使用 `QueryPerformanceCounter` API --- --- url: /en/vbman/global/timeuse.md --- # VBMAN.TimeUse - Timer Object ## Overview `VBMAN.TimeUse` provides simple code execution time measurement functionality, implemented using the `GetTickCount` API. ## Core Features * **Easy to Use**: Start timing and display elapsed time * **Custom Output Format**: Support custom output text template ## Methods ### Start Start timing ```vb Public Sub Start() ``` **Example**: ```vb VBMAN.TimeUse.Start ``` ### Show Display elapsed time ```vb Public Function Show(Optional Txt As String = "Elapsed: {*} ms") As Variant ``` **Parameters**: * `Txt` - Output text template, use `{*}` as elapsed time placeholder **Returns**: Formatted string **Example**: ```vb ' Default format Debug.Print VBMAN.TimeUse.Show ' Output: Elapsed: 123 ms ' Custom format Debug.Print VBMAN.TimeUse.Show("Execution time: {*} ms") ' Output: Execution time: 123 ms ``` ## Comprehensive Examples ### Example 1: Measure Code Execution Time ```vb Private Sub TestPerformance() ' Start timing VBMAN.TimeUse.Start ' Code to measure Dim i As Long Dim sum As Long For i = 1 To 1000000 sum = sum + i Next i ' Display elapsed time Debug.Print VBMAN.TimeUse.Show("Loop calculation time: {*} ms") End Sub ``` ### Example 2: Function Execution Time Recording ```vb Private Sub ProcessData() VBMAN.TimeUse.Start ' Data processing logic Call LoadDataFromDatabase Call ProcessRecords Call SaveResults ' Record to log VBMAN.Logs.DataLine VBMAN.TimeUse.Show("Data processing completed, time: {*} ms"), "Performance Stats" End Sub ``` ## Notes * Uses `GetTickCount` API, precision is millisecond level * Timer restarts timing after calling `Start` * For higher precision, recommend using `QueryPerformanceCounter` API --- --- url: /zh/vbman/global/toast.md --- # VBMAN.Toast - 通知消息对象 ## 概述 `VBMAN.Toast` 提供了非阻塞的通知消息显示功能，类似于现代操作系统中的 Toast 通知。支持 **9种显示方位**、**4种状态样式**、**2种主题**，适用于需要提示用户但不希望打断操作的场景。 ## 核心特性 * **9种显示方位**: 左上、左中、左下、中上、居中、中下、右上、右中、右下 * **链式调用**: 支持流畅的链式 API 设计 * **自动堆叠**: 非居中位置支持自动堆叠显示 * **状态样式**: 信息、成功、警告、错误四种视觉状态 * **主题切换**: 支持亮色/暗色主题 * **标签管理**: 支持通过标签名控制特定 Toast * **事件通知**: 提供数量变化和全部关闭事件 ## 枚举类型 ### EnumPos - 显示方位 | 常量 | 值 | 说明 | |------|-----|------| | `LeftTop` | 10 | 左上角 | | `LeftCenter` | 12 | 左中（居中，不支持堆叠）| | `LeftBottom` | 14 | 左下角 | | `CenterTop` | 20 | 中上方 | | `Center` | 22 | 正中央（居中，不支持堆叠）| | `CenterBottom` | 24 | 中下方 | | `RightTop` | 30 | 右上角 | | `RightCenter` | 32 | 右中（居中，不支持堆叠）| | `RightBottom` | 34 | 右下角 | ### EnumState - 消息状态 | 常量 | 值 | 说明 | |------|-----|------| | `Info` | 1 | 信息（蓝色）| | `Success` | 2 | 成功（绿色）| | `Warning` | 3 | 警告（黄色）| | `Danger` | 4 | 错误（红色）| ### EnumTheme - 主题 | 常量 | 值 | 说明 | |------|-----|------| | `Light` | 1 | 亮色主题 | | `Dark` | 2 | 暗色主题 | ## 链式调用方法 ### Pos 设置显示方位，支持链式调用。 ```vb Public Function Pos(p As EnumPos) As cToast ``` **示例**: ```vb ' 在右上角显示 VBMAN.Toast.Pos(RightTop).Show "操作成功" ' 在左下角显示 VBMAN.Toast.Pos(LeftBottom).Show "下载完成" ``` ### State 设置消息状态，影响视觉样式。 ```vb Public Function State(s As EnumState) As cToast ``` **示例**: ```vb ' 成功提示 VBMAN.Toast.State(Success).Show "保存成功" ' 错误提示 VBMAN.Toast.State(Danger).Show "操作失败" ' 警告提示 VBMAN.Toast.State(Warning).Show "请注意检查" ``` ### Theme 设置主题。 ```vb Public Function Theme(t As EnumTheme) As cToast ``` **示例**: ```vb ' 暗色主题 VBMAN.Toast.Theme(Dark).Show "夜间模式提示" ' 亮色主题（默认） VBMAN.Toast.Theme(Light).Show "普通提示" ``` ### InstIndex 手动设置堆叠索引（仅支持非居中位置）。 ```vb Public Function InstIndex(ByVal i As Long) As cToast ``` **说明**: * 居中位置（Center、LeftCenter、RightCenter）不支持堆叠 * 如果不调用此方法，系统会自动管理堆叠顺序 **示例**: ```vb ' 指定堆叠在第2个位置 VBMAN.Toast.Pos(RightTop).InstIndex(1).Show "第一条" VBMAN.Toast.Pos(RightTop).InstIndex(2).Show "第二条" ``` ### Tag 设置 Toast 的标签名，用于后续管理。 ```vb Public Function Tag(ByVal Name As String) As cToast ``` **说明**: * 如果不设置标签，系统会自动生成随机标签 * 相同标签的 Toast 不会重复创建 **示例**: ```vb ' 设置标签以便后续关闭 VBMAN.Toast.Tag("upload_status").Show "正在上传..." ' 关闭指定标签的 Toast VBMAN.Toast.CloseMe "upload_status" ``` ### Show 显示 Toast 通知，链式调用的终点。 ```vb Public Function Show(ByVal Content As String, Optional ByVal Delay As Long = 3000, Optional ByVal Title As String) As cToast ``` **参数**: * `Content` - 消息内容 * `Delay` - 显示时长（毫秒，默认3000） * `Title` - 消息标题（可选，非居中位置默认显示"提示"） **示例**: ```vb ' 简单消息 VBMAN.Toast.Show "操作成功" ' 带标题和时长 VBMAN.Toast.Show "文件保存完成", 5000, "成功" ' 完整链式调用 VBMAN.Toast _ .Pos(RightTop) _ .State(Success) _ .Theme(Light) _ .Tag("save_result") _ .Show "文件保存成功！", 3000, "完成" ``` ## 管理方法 ### CloseMe 关闭指定标签的 Toast。 ```vb Public Function CloseMe(ByVal Name As String) As Boolean ``` **返回值**: 是否成功关闭 **示例**: ```vb ' 关闭指定标签的 Toast If VBMAN.Toast.CloseMe("upload_status") Then Debug.Print "已关闭" End If ``` ### CloseAll 关闭所有 Toast。 ```vb Public Function CloseAll() As Boolean ``` **示例**: ```vb ' 关闭所有 Toast VBMAN.Toast.CloseAll ' 在窗体卸载时调用 Private Sub Form_Unload(Cancel As Integer) VBMAN.Toast.CloseAll End Sub ``` ### Exists 检查指定标签的 Toast 是否存在。 ```vb Public Function Exists(ByVal Name As String) As Boolean ``` **示例**: ```vb ' 检查是否存在 If VBMAN.Toast.Exists("upload_status") Then Debug.Print "上传状态提示正在显示" End If ``` ## 统计属性 ### Count 获取当前显示的 Toast 总数。 ```vb Public Property Get Count() As Long ``` **示例**: ```vb Debug.Print "当前有 " & VBMAN.Toast.Count & " 个 Toast 在显示" ``` ### ActiveKeys 获取所有活动 Toast 的标签集合。 ```vb Public Property Get ActiveKeys() As Collection ``` **示例**: ```vb Dim keys As Collection Set keys = VBMAN.Toast.ActiveKeys Dim key As Variant For Each key In keys Debug.Print "活动 Toast: " & key Next key ``` ## 事件 ### OnToastCountChange Toast 数量变化时触发。 ```vb Public Event OnToastCountChange(ByVal TagName As String, ByVal IsDelete As Boolean, ByVal CurrentCount As Long) ``` **参数**: * `TagName` - 变化的 Toast 标签 * `IsDelete` - True=删除, False=新增 * `CurrentCount` - 当前总数 ### OnCloseAll 所有 Toast 被关闭时触发。 ```vb Public Event OnCloseAll(ByVal closedCount As Long) ``` **参数**: * `closedCount` - 被关闭的 Toast 数量 ## 综合示例 ### 示例1: 不同位置的提示 ```vb Private Sub ShowMultiPos() ' 右上角 - 成功提示 VBMAN.Toast.Pos(RightTop).State(Success).Show "保存成功", 2000 ' 左上角 - 信息提示 VBMAN.Toast.Pos(LeftTop).State(Info).Show "新消息", 3000 ' 右下角 - 警告提示 VBMAN.Toast.Pos(RightBottom).State(Warning).Show "磁盘空间不足", 5000 ' 中央 - 错误提示（居中显示，不堆叠） VBMAN.Toast.Pos(Center).State(Danger).Show "操作失败！", 0, "错误" End Sub ``` ### 示例2: 上传进度提示 ```vb Private Sub UploadFile() Dim filePath As String filePath = "C:\data.zip" ' 显示开始上传提示 VBMAN.Toast _ .Pos(RightTop) _ .State(Info) _ .Tag("upload") _ .Show "正在上传: " & filePath, 0, "上传中" ' 模拟上传过程 Dim i As Integer For i = 0 To 100 Step 10 ' 更新进度... DoEvents Sleep 200 Next i ' 关闭上传提示，显示完成 VBMAN.Toast.CloseMe "upload" VBMAN.Toast _ .Pos(RightTop) _ .State(Success) _ .Show "上传完成！", 3000, "完成" End Sub ``` ### 示例3: 批量操作提示 ```vb Private Sub BatchProcess() Dim i As Integer Dim successCount As Integer Dim failCount As Integer ' 显示开始提示 VBMAN.Toast _ .Pos(CenterBottom) _ .State(Info) _ .Tag("batch") _ .Show "开始批量处理...", 0 For i = 1 To 100 If ProcessItem(i) Then successCount = successCount + 1 Else failCount = failCount + 1 End If ' 每处理25个更新一次提示 If i Mod 25 = 0 Then VBMAN.Toast.CloseMe "batch" VBMAN.Toast _ .Pos(CenterBottom) _ .State(Info) _ .Tag("batch") _ .Show "已处理: " & i & "/100", 0 DoEvents End If Next i ' 关闭进度提示 VBMAN.Toast.CloseMe "batch" ' 显示结果 If failCount = 0 Then VBMAN.Toast _ .Pos(RightTop) _ .State(Success) _ .Show "全部处理成功！", 3000 Else VBMAN.Toast _ .Pos(RightTop) _ .State(Warning) _ .Show "成功: " & successCount & ", 失败: " & failCount, 5000 End If End Sub ``` ### 示例4: 自动堆叠效果 ```vb Private Sub AutoStackDemo() Dim i As Integer ' 在右上角自动堆叠显示多个消息 For i = 1 To 5 VBMAN.Toast _ .Pos(RightTop) _ .State(Info) _ .Show "消息 " & i, 3000 + i * 1000 Sleep 500 Next i End Sub ``` ### 示例5: 服务端使用（避免 MsgBox 阻塞） ```vb Public Sub HandleServerMessage(Data As cJson) If Common.IsServer = True Then ' 服务端避免使用 MsgBox 阻塞，改用 Toast VBMAN.Toast _ .Pos(RightTop) _ .State(Info) _ .Show Data("Content"), 60000, Data("Title") Exit Sub End If End Sub ``` ### 示例6: 暗色主题提示 ```vb Private Sub DarkModeToast() ' 暗色主题的成功提示 VBMAN.Toast _ .Pos(RightBottom) _ .State(Success) _ .Theme(Dark) _ .Show "夜间模式已开启", 2000 ' 暗色主题的警告提示 VBMAN.Toast _ .Pos(LeftBottom) _ .State(Warning) _ .Theme(Dark) _ .Show "电池电量低", 5000, "系统" End Sub ``` ## 使用建议 1. **位置选择**: * 普通通知：右上角（RightTop） * 重要消息：中央（Center） * 辅助信息：中下方（CenterBottom） 2. **居中位置限制**: * Center、LeftCenter、RightCenter 不支持堆叠 * 同一时间只能显示一个居中 Toast 3. **标签管理**: * 需要后续关闭的 Toast 务必设置标签 * 相同标签的 Toast 不会重复创建 4. **时长设置**: * 普通提示：2000-3000ms * 重要消息：5000ms 或更长 * 需要手动关闭：设置为 0 5. **资源清理**: * 窗体卸载时调用 `CloseAll` * 避免 Toast 残留导致内存泄漏 ## 注意事项 * Toast 是非模态的，不会阻塞用户操作 * 显示时长单位为毫秒（1秒 = 1000毫秒） * 支持使用 `vbCrLf` 换行显示多行内容 * 居中位置的 Toast 会覆盖显示，不堆叠 * 在 Windows 服务端可能无法正常显示 UI，建议配合日志使用 --- --- url: /en/vbman/global/toast.md --- # VBMAN.Toast - Notification Message Object ## Overview `VBMAN.Toast` provides non-blocking notification message display functionality, similar to Toast notifications in modern operating systems. Supports **9 display positions**, **4 state styles**, **2 themes**, suitable for scenarios where user notification is needed without interrupting operations. ## Core Features * **9 Display Positions**: Top-left, left-center, bottom-left, top-center, center, bottom-center, top-right, right-center, bottom-right * **Chain Calling**: Supports fluent chain API design * **Auto Stacking**: Non-center positions support automatic stacking display * **State Styles**: Info, Success, Warning, Error four visual states * **Theme Switching**: Supports Light/Dark themes * **Tag Management**: Supports managing specific Toasts by tag name * **Event Notification**: Provides count change and all-close events ## Enum Types ### EnumPos - Display Position | Constant | Value | Description | |----------|-------|-------------| | `LeftTop` | 10 | Top-left corner | | `LeftCenter` | 12 | Left-center (centered, no stacking) | | `LeftBottom` | 14 | Bottom-left corner | | `CenterTop` | 20 | Top-center | | `Center` | 22 | Center (centered, no stacking) | | `CenterBottom` | 24 | Bottom-center | | `RightTop` | 30 | Top-right corner | | `RightCenter` | 32 | Right-center (centered, no stacking) | | `RightBottom` | 34 | Bottom-right corner | ### EnumState - Message State | Constant | Value | Description | |----------|-------|-------------| | `Info` | 1 | Info (blue) | | `Success` | 2 | Success (green) | | `Warning` | 3 | Warning (yellow) | | `Danger` | 4 | Error (red) | ### EnumTheme - Theme | Constant | Value | Description | |----------|-------|-------------| | `Light` | 1 | Light theme | | `Dark` | 2 | Dark theme | ## Chain Calling Methods ### Pos Set display position, supports chain calling. ```vb Public Function Pos(p As EnumPos) As cToast ``` **Example**: ```vb ' Display in top-right corner VBMAN.Toast.Pos(RightTop).Show "Operation successful" ' Display in bottom-left corner VBMAN.Toast.Pos(LeftBottom).Show "Download complete" ``` ### State Set message state, affects visual style. ```vb Public Function State(s As EnumState) As cToast ``` **Example**: ```vb ' Success notification VBMAN.Toast.State(Success).Show "Save successful" ' Error notification VBMAN.Toast.State(Danger).Show "Operation failed" ' Warning notification VBMAN.Toast.State(Warning).Show "Please check" ``` ### Theme Set theme. ```vb Public Function Theme(t As EnumTheme) As cToast ``` **Example**: ```vb ' Dark theme VBMAN.Toast.Theme(Dark).Show "Night mode notification" ' Light theme (default) VBMAN.Toast.Theme(Light).Show "Normal notification" ``` ### InstIndex Manually set stack index (only supports non-center positions). ```vb Public Function InstIndex(ByVal i As Long) As cToast ``` **Description**: * Center positions (Center, LeftCenter, RightCenter) don't support stacking * If this method is not called, system will automatically manage stack order **Example**: ```vb ' Specify stack at position 2 VBMAN.Toast.Pos(RightTop).InstIndex(1).Show "First" VBMAN.Toast.Pos(RightTop).InstIndex(2).Show "Second" ``` ### Tag Set Toast tag name for subsequent management. ```vb Public Function Tag(ByVal Name As String) As cToast ``` **Description**: * If tag is not set, system will auto-generate random tag * Toasts with same tag won't be created repeatedly **Example**: ```vb ' Set tag for later closing VBMAN.Toast.Tag("upload_status").Show "Uploading..." ' Close Toast with specified tag VBMAN.Toast.CloseMe "upload_status" ``` ### Show Display Toast notification, end of chain call. ```vb Public Function Show(ByVal Content As String, Optional ByVal Delay As Long = 3000, Optional ByVal Title As String) As cToast ``` **Parameters**: * `Content` - Message content * `Delay` - Display duration (milliseconds, default 3000) * `Title` - Message title (optional, non-center positions show "Notification" by default) **Example**: ```vb ' Simple message VBMAN.Toast.Show "Operation successful" ' With title and duration VBMAN.Toast.Show "File save complete", 5000, "Success" ' Complete chain call VBMAN.Toast _ .Pos(RightTop) _ .State(Success) _ .Theme(Light) _ .Tag("save_result") _ .Show "File saved successfully!", 3000, "Complete" ``` ## Management Methods ### CloseMe Close Toast with specified tag. ```vb Public Function CloseMe(ByVal Name As String) As Boolean ``` **Return Value**: Whether successfully closed **Example**: ```vb ' Close Toast with specified tag If VBMAN.Toast.CloseMe("upload_status") Then Debug.Print "Closed" End If ``` ### CloseAll Close all Toasts. ```vb Public Function CloseAll() As Boolean ``` **Example**: ```vb ' Close all Toasts VBMAN.Toast.CloseAll ' Call when form unloads Private Sub Form_Unload(Cancel As Integer) VBMAN.Toast.CloseAll End Sub ``` ### Exists Check if Toast with specified tag exists. ```vb Public Function Exists(ByVal Name As String) As Boolean ``` **Example**: ```vb ' Check if exists If VBMAN.Toast.Exists("upload_status") Then Debug.Print "Upload status notification is showing" End If ``` ## Statistics Properties ### Count Get total number of currently displayed Toasts. ```vb Public Property Get Count() As Long ``` **Example**: ```vb Debug.Print "Currently " & VBMAN.Toast.Count & " Toasts are showing" ``` ### ActiveKeys Get collection of all active Toast tags. ```vb Public Property Get ActiveKeys() As Collection ``` **Example**: ```vb Dim keys As Collection Set keys = VBMAN.Toast.ActiveKeys Dim key As Variant For Each key In keys Debug.Print "Active Toast: " & key Next key ``` ## Events ### OnToastCountChange Triggered when Toast count changes. ```vb Public Event OnToastCountChange(ByVal TagName As String, ByVal IsDelete As Boolean, ByVal CurrentCount As Long) ``` **Parameters**: * `TagName` - Tag of changed Toast * `IsDelete` - True=deleted, False=added * `CurrentCount` - Current total count ### OnCloseAll Triggered when all Toasts are closed. ```vb Public Event OnCloseAll(ByVal closedCount As Long) ``` **Parameters**: * `closedCount` - Number of Toasts closed ## Comprehensive Examples ### Example 1: Notifications at Different Positions ```vb Private Sub ShowMultiPos() ' Top-right - Success notification VBMAN.Toast.Pos(RightTop).State(Success).Show "Save successful", 2000 ' Top-left - Info notification VBMAN.Toast.Pos(LeftTop).State(Info).Show "New message", 3000 ' Bottom-right - Warning notification VBMAN.Toast.Pos(RightBottom).State(Warning).Show "Disk space low", 5000 ' Center - Error notification (centered display, no stacking) VBMAN.Toast.Pos(Center).State(Danger).Show "Operation failed!", 0, "Error" End Sub ``` ### Example 2: Upload Progress Notification ```vb Private Sub UploadFile() Dim filePath As String filePath = "C:\data.zip" ' Show start upload notification VBMAN.Toast _ .Pos(RightTop) _ .State(Info) _ .Tag("upload") _ .Show "Uploading: " & filePath, 0, "Uploading" ' Simulate upload process Dim i As Integer For i = 0 To 100 Step 10 ' Update progress... DoEvents Sleep 200 Next i ' Close upload notification, show complete VBMAN.Toast.CloseMe "upload" VBMAN.Toast _ .Pos(RightTop) _ .State(Success) _ .Show "Upload complete!", 3000, "Complete" End Sub ``` ### Example 3: Batch Operation Notification ```vb Private Sub BatchProcess() Dim i As Integer Dim successCount As Integer Dim failCount As Integer ' Show start notification VBMAN.Toast _ .Pos(CenterBottom) _ .State(Info) _ .Tag("batch") _ .Show "Starting batch processing...", 0 For i = 1 To 100 If ProcessItem(i) Then successCount = successCount + 1 Else failCount = failCount + 1 End If ' Update notification every 25 processed If i Mod 25 = 0 Then VBMAN.Toast.CloseMe "batch" VBMAN.Toast _ .Pos(CenterBottom) _ .State(Info) _ .Tag("batch") _ .Show "Processed: " & i & "/100", 0 DoEvents End If Next i ' Close progress notification VBMAN.Toast.CloseMe "batch" ' Show result If failCount = 0 Then VBMAN.Toast _ .Pos(RightTop) _ .State(Success) _ .Show "All processed successfully!", 3000 Else VBMAN.Toast _ .Pos(RightTop) _ .State(Warning) _ .Show "Success: " & successCount & ", Failed: " & failCount, 5000 End If End Sub ``` ### Example 4: Auto Stack Effect ```vb Private Sub AutoStackDemo() Dim i As Integer ' Automatically stack and display multiple messages in top-right corner For i = 1 To 5 VBMAN.Toast _ .Pos(RightTop) _ .State(Info) _ .Show "Message " & i, 3000 + i * 1000 Sleep 500 Next i End Sub ``` ### Example 5: Server-side Use (Avoid MsgBox Blocking) ```vb Public Sub HandleServerMessage(Data As cJson) If Common.IsServer = True Then ' Server-side avoids using MsgBox blocking, use Toast instead VBMAN.Toast _ .Pos(RightTop) _ .State(Info) _ .Show Data("Content"), 60000, Data("Title") Exit Sub End If End Sub ``` ### Example 6: Dark Theme Notification ```vb Private Sub DarkModeToast() ' Dark theme success notification VBMAN.Toast _ .Pos(RightBottom) _ .State(Success) _ .Theme(Dark) _ .Show "Night mode enabled", 2000 ' Dark theme warning notification VBMAN.Toast _ .Pos(LeftBottom) _ .State(Warning) _ .Theme(Dark) _ .Show "Low battery", 5000, "System" End Sub ``` ## Usage Suggestions 1. **Position Selection**: * Normal notifications: Top-right (RightTop) * Important messages: Center (Center) * Auxiliary info: Bottom-center (CenterBottom) 2. **Center Position Limitations**: * Center, LeftCenter, RightCenter don't support stacking * Only one centered Toast can be displayed at a time 3. **Tag Management**: * Toasts that need to be closed later must have tags set * Toasts with same tag won't be created repeatedly 4. **Duration Settings**: * Normal notifications: 2000-3000ms * Important messages: 5000ms or longer * Manual close needed: set to 0 5. **Resource Cleanup**: * Call `CloseAll` when form unloads * Avoid Toast residue causing memory leaks ## Notes * Toast is non-modal, won't block user operations * Display duration unit is milliseconds (1 second = 1000 milliseconds) * Supports using `vbCrLf` for multi-line content display * Centered position Toasts will overlay display, not stack * On Windows server may not display UI properly, recommended to use with logs --- --- url: /zh/vbman/global/toolsarray.md --- # VBMAN.ToolsArray - 数组工具对象 ## 概述 `VBMAN.ToolsArray` 提供了数组操作的实用功能，包括数组删除元素、解构赋值、切片、查找等。 ## 方法 ### Remove 删除数组指定索引的元素 ```vb Public Function Remove(ByRef Arr As Variant, ByVal Index As Integer) As Boolean ``` **参数**: * `Arr` - 数组（按引用传递） * `Index` - 要删除的索引 **返回**: True=成功, False=失败 **说明**: * 将指定索引后面的元素往前移动 * 自动调整数组大小 **示例**: ```vb Dim arr(3) As String arr(0) = "A" arr(1) = "B" arr(2) = "C" arr(3) = "D" ' 删除索引 1 的元素（B） VBMAN.ToolsArray.Remove arr, 1 ' 结果: A, C, D Debug.Print arr(0) ' A Debug.Print arr(1) ' C Debug.Print arr(2) ' D ``` ### DeArray 解构数组到变量 ```vb Public Sub DeArray(Arr As Variant, ParamArray OutVars()) ``` **参数**: * `Arr` - 源数组 * `OutVars` - 输出变量数组 **说明**: * 将数组元素按顺序赋值给变量 * 变量数量不足时只赋值部分元素 **示例**: ```vb Dim a As String, b As String, c As String ' 解构数组 VBMAN.ToolsArray.DeArray Split("苹果/香蕉/橙子", "/"), a, b, c Debug.Print a ' 苹果 Debug.Print b ' 香蕉 Debug.Print c ' 橙子 ' 只取前两个 Dim x As String, y As String VBMAN.ToolsArray.DeArray Array(1, 2, 3, 4), x, y Debug.Print x ' 1 Debug.Print y ' 2 ``` ### GetIndexByValue 根据值查找索引 ```vb Public Function GetIndexByValue(Arr As Variant, Value As String) As Long ``` **参数**: * `Arr` - 数组 * `Value` - 要查找的值 **返回**: 索引值，未找到返回 -1 **示例**: ```vb Dim fruits(3) As String fruits(0) = "apple" fruits(1) = "banana" fruits(2) = "orange" fruits(3) = "grape" Dim idx As Long idx = VBMAN.ToolsArray.GetIndexByValue(fruits, "orange") Debug.Print idx ' 2 idx = VBMAN.ToolsArray.GetIndexByValue(fruits, "watermelon") Debug.Print idx ' -1 ``` ### IsArrayEmpty 检查数组是否为空 ```vb Public Function IsArrayEmpty(Arr As Variant) As Boolean ``` **参数**: * `Arr` - 数组 **返回**: True=空数组, False=非空 **示例**: ```vb Dim emptyArr() As String Dim arr(1) As String arr(0) = "test" Debug.Print VBMAN.ToolsArray.IsArrayEmpty(emptyArr) ' True Debug.Print VBMAN.ToolsArray.IsArrayEmpty(arr) ' False ``` ### IsControlArray 检查控件是否为控件数组 ```vb Public Function IsControlArray(Ctl As Object) As Boolean ``` **参数**: * `Ctl` - 控件对象 **返回**: True=是控件数组, False=不是 **示例**: ```vb ' 检查 Command1 是否是控件数组 If VBMAN.ToolsArray.IsControlArray(Command1) Then Debug.Print "Command1 是控件数组" End If ``` ### SliceByteArray 字节数组切片 ```vb Public Function SliceByteArray(ByRef Arr() As Byte, ByVal StartPos As Long, Optional ByVal EndPos As Long = -1) As Byte() ``` **参数**: * `Arr` - 字节数组 * `StartPos` - 开始位置 * `EndPos` - 结束位置（-1 表示到末尾） **返回**: 切片后的字节数组 **示例**: ```vb Dim bytes(9) As Byte ' ... 填充数据 ' 获取第 2-5 个字节 Dim sliced() As Byte sliced = VBMAN.ToolsArray.SliceByteArray(bytes, 2, 5) ``` ## 综合示例 ### 示例1: 动态删除数组元素 ```vb Private Sub RemoveFromArray() Dim items As Variant items = Array("苹果", "香蕉", "橙子", "葡萄") ' 删除 "香蕉"（索引 1） VBMAN.ToolsArray.Remove items, 1 Dim i As Long For i = LBound(items) To UBound(items) Debug.Print items(i) Next i ' 输出: 苹果, 橙子, 葡萄 End Sub ``` ### 示例2: 批量变量赋值 ```vb Private Sub ParsePath() Dim path As String path = "C:\\Users\\Admin\\Documents\\file.txt" Dim drive As String, user As String, folder As String, file As String ' 解构路径 VBMAN.ToolsArray.DeArray Split(path, "\\"), drive, user, folder, file Debug.Print "驱动器: " & drive ' C: Debug.Print "用户: " & user ' Users Debug.Print "文件夹: " & folder ' Admin Debug.Print "文件: " & file ' Documents End Sub ``` ### 示例3: 查找和删除 ```vb Private Sub RemoveByValue() Dim items() As String items = Split("苹果,香蕉,橙子,葡萄", ",") ' 查找索引 Dim idx As Long idx = VBMAN.ToolsArray.GetIndexByValue(items, "橙子") If idx >= 0 Then ' 删除找到的元素 VBMAN.ToolsArray.Remove items, idx MsgBox "已删除橙子" Else MsgBox "未找到橙子" End If End Sub ``` ## 最佳实践 1. **索引检查**: 删除或访问数组前先检查索引有效性 2. **解构赋值**: `DeArray` 适合处理固定格式的数据解析 3. **数组边界**: 注意 VB6 数组可以自定义起始索引 4. **类型匹配**: `GetIndexByValue` 进行字符串比较，注意类型转换 --- --- url: /en/vbman/global/toolsarray.md --- # VBMAN.ToolsArray - Array Tool Object ## Overview `VBMAN.ToolsArray` provides utility functions for array operations, including array element deletion, destructuring assignment, slicing, searching, etc. ## Methods ### Remove Delete element at specified index from array ```vb Public Function Remove(ByRef Arr As Variant, ByVal Index As Integer) As Boolean ``` **Parameters**: * `Arr` - Array (passed by reference) * `Index` - Index to delete **Returns**: True=success, False=failure **Description**: * Moves elements after specified index forward * Automatically adjusts array size **Example**: ```vb Dim arr(3) As String arr(0) = "A" arr(1) = "B" arr(2) = "C" arr(3) = "D" ' Delete element at index 1 (B) VBMAN.ToolsArray.Remove arr, 1 ' Result: A, C, D Debug.Print arr(0) ' A Debug.Print arr(1) ' C Debug.Print arr(2) ' D ``` ### DeArray Destructure array to variables ```vb Public Sub DeArray(Arr As Variant, ParamArray OutVars()) ``` **Parameters**: * `Arr` - Source array * `OutVars` - Output variable array **Description**: * Assigns array elements to variables in order * Only assigns partial elements if insufficient variables **Example**: ```vb Dim a As String, b As String, c As String ' Destructure array VBMAN.ToolsArray.DeArray Split("Apple/Banana/Orange", "/"), a, b, c Debug.Print a ' Apple Debug.Print b ' Banana Debug.Print c ' Orange ' Only take first two Dim x As String, y As String VBMAN.ToolsArray.DeArray Array(1, 2, 3, 4), x, y Debug.Print x ' 1 Debug.Print y ' 2 ``` ### GetIndexByValue Find index by value ```vb Public Function GetIndexByValue(Arr As Variant, Value As String) As Long ``` **Parameters**: * `Arr` - Array * `Value` - Value to find **Returns**: Index value, returns -1 if not found **Example**: ```vb Dim fruits(3) As String fruits(0) = "apple" fruits(1) = "banana" fruits(2) = "orange" fruits(3) = "grape" Dim idx As Long idx = VBMAN.ToolsArray.GetIndexByValue(fruits, "orange") Debug.Print idx ' 2 idx = VBMAN.ToolsArray.GetIndexByValue(fruits, "watermelon") Debug.Print idx ' -1 ``` ### IsArrayEmpty Check if array is empty ```vb Public Function IsArrayEmpty(Arr As Variant) As Boolean ``` **Parameters**: * `Arr` - Array **Returns**: True=empty array, False=not empty **Example**: ```vb Dim emptyArr() As String Dim arr(1) As String arr(0) = "test" Debug.Print VBMAN.ToolsArray.IsArrayEmpty(emptyArr) ' True Debug.Print VBMAN.ToolsArray.IsArrayEmpty(arr) ' False ``` ### IsControlArray Check if control is a control array ```vb Public Function IsControlArray(Ctl As Object) As Boolean ``` **Parameters**: * `Ctl` - Control object **Returns**: True=is control array, False=is not **Example**: ```vb ' Check if Command1 is a control array If VBMAN.ToolsArray.IsControlArray(Command1) Then Debug.Print "Command1 is a control array" End If ``` ### SliceByteArray Byte array slicing ```vb Public Function SliceByteArray(ByRef Arr() As Byte, ByVal StartPos As Long, Optional ByVal EndPos As Long = -1) As Byte() ``` **Parameters**: * `Arr` - Byte array * `StartPos` - Start position * `EndPos` - End position (-1 means to end) **Returns**: Sliced byte array **Example**: ```vb Dim bytes(9) As Byte ' ... fill data ' Get bytes 2-5 Dim sliced() As Byte sliced = VBMAN.ToolsArray.SliceByteArray(bytes, 2, 5) ``` ## Comprehensive Examples ### Example 1: Dynamic Array Element Deletion ```vb Private Sub RemoveFromArray() Dim items As Variant items = Array("Apple", "Banana", "Orange", "Grape") ' Delete "Banana" (index 1) VBMAN.ToolsArray.Remove items, 1 Dim i As Long For i = LBound(items) To UBound(items) Debug.Print items(i) Next i ' Output: Apple, Orange, Grape End Sub ``` ### Example 2: Batch Variable Assignment ```vb Private Sub ParsePath() Dim path As String path = "C:\\Users\\Admin\\Documents\\file.txt" Dim drive As String, user As String, folder As String, file As String ' Destructure path VBMAN.ToolsArray.DeArray Split(path, "\\"), drive, user, folder, file Debug.Print "Drive: " & drive ' C: Debug.Print "User: " & user ' Users Debug.Print "Folder: " & folder ' Admin Debug.Print "File: " & file ' Documents End Sub ``` ### Example 3: Find and Delete ```vb Private Sub RemoveByValue() Dim items() As String items = Split("Apple,Banana,Orange,Grape", ",") ' Find index Dim idx As Long idx = VBMAN.ToolsArray.GetIndexByValue(items, "Orange") If idx >= 0 Then ' Delete found element VBMAN.ToolsArray.Remove items, idx MsgBox "Orange deleted" Else MsgBox "Orange not found" End If End Sub ``` ## Best Practices 1. **Index Check**: Check index validity before deleting or accessing array 2. **Destructuring Assignment**: `DeArray` is suitable for processing fixed-format data parsing 3. **Array Bounds**: Note that VB6 arrays can have custom starting index 4. **Type Matching**: `GetIndexByValue` performs string comparison, pay attention to type conversion --- --- url: /zh/vbman/global/toolsbase64.md --- # VBMAN.ToolsBase64 - Base64 编解码对象 ## 概述 `VBMAN.ToolsBase64` 提供了 Base64 编码和解码功能，支持字符串和字节数组的相互转换，常用于数据传输、图片编码、配置文件等场景。 ## 核心特性 * **双向转换**: 支持编码和解码 * **多种输入**: 支持字符串和字节数组 * **标准 Base64**: 兼容 RFC 4648 标准 * **URL 安全**: 支持 URL 安全的 Base64 变体 ## 方法 ### Encode 将字符串编码为 Base64 ```vb Public Function Encode(text As String) As String ``` **参数**: * `text` - 要编码的字符串 **返回**: Base64 编码的字符串 **示例**: ```vb ' 编码字符串 Dim encoded As String encoded = VBMAN.ToolsBase64.Encode("Hello World") Debug.Print encoded ' SGVsbG8gV29ybGQ= ' 编码中文 encoded = VBMAN.ToolsBase64.Encode("你好世界") Debug.Print encoded ' 5L2g5aW95LiW55WM ``` ### Decode 将 Base64 解码为字符串 ```vb Public Function Decode(base64String As String) As String ``` **参数**: * `base64String` - Base64 编码的字符串 **返回**: 解码后的字符串 **示例**: ```vb ' 解码 Dim decoded As String decoded = VBMAN.ToolsBase64.Decode("SGVsbG8gV29ybGQ=") Debug.Print decoded ' Hello World ``` ### BytesToBase64 将字节数组转为 Base64 ```vb Public Function BytesToBase64(bytes() As Byte) As String ``` **参数**: * `bytes` - 字节数组 **返回**: Base64 编码的字符串 **示例**: ```vb ' 字节数组转 Base64 Dim bytes(0 To 4) As Byte bytes(0) = 72: bytes(1) = 101 bytes(2) = 108: bytes(3) = 108 bytes(4) = 111 Dim base64 As String base64 = VBMAN.ToolsBase64.BytesToBase64(bytes) Debug.Print base64 ' SGVsbG8= ``` ### Base64ToBytes 将 Base64 转为字节数组 ```vb Public Function Base64ToBytes(base64String As String) As Byte() ``` **参数**: * `base64String` - Base64 编码的字符串 **返回**: 字节数组 **示例**: ```vb ' Base64 转字节数组 Dim bytes() As Byte bytes = VBMAN.ToolsBase64.Base64ToBytes("SGVsbG8=") ' 使用字节数组 Dim i As Integer For i = LBound(bytes) To UBound(bytes) Debug.Print bytes(i); Next ``` ## 综合示例 ### 示例1: 图片 Base64 编码 ```vb Private Function ImageToBase64(filePath As String) As String ' 读取图片文件 VBMAN.FileEx.OpenFile filePath, "R" Dim bytes() As Byte bytes = VBMAN.FileEx.ReadData.ReturnBytes VBMAN.FileEx.CloseFile ' 转为 Base64 ImageToBase64 = VBMAN.ToolsBase64.BytesToBase64(bytes) End Function Private Sub EmbedImage() Dim base64Image As String base64Image = ImageToBase64("C:\\photo.jpg") ' 嵌入 HTML Dim html As String html = "" WebBrowser1.Document.Write html End Sub ``` ### 示例2: Basic 认证头 ```vb Private Function CreateBasicAuthHeader(username As String, password As String) As String ' 组合用户名密码 Dim credentials As String credentials = username & ":" & password ' Base64 编码 Dim encoded As String encoded = VBMAN.ToolsBase64.Encode(credentials) ' 构建认证头 CreateBasicAuthHeader = "Basic " & encoded End Function Private Sub TestAuth() Dim authHeader As String authHeader = CreateBasicAuthHeader("admin", "secret123") Debug.Print authHeader ' Basic YWRtaW46c2VjcmV0MTIz End Sub ``` ### 示例3: 配置文件加密存储 ```vb Private Sub SaveEncodedConfig(config As String, filePath As String) ' 编码配置内容 Dim encoded As String encoded = VBMAN.ToolsBase64.Encode(config) ' 保存到文件 VBMAN.FileEx.SetBufferText(encoded, "UTF-8").SaveData filePath End Sub Private Function LoadEncodedConfig(filePath As String) As String ' 读取文件 Dim encoded As String encoded = VBMAN.FileEx.OpenFile(filePath, "R").ReadData.ReturnText("UTF-8") VBMAN.FileEx.CloseFile ' 解码 LoadEncodedConfig = VBMAN.ToolsBase64.Decode(encoded) End Function ``` ### 示例4: 数据传输 ```vb Private Sub SendDataPacket(data As String) ' 编码数据 Dim encoded As String encoded = VBMAN.ToolsBase64.Encode(data) ' 构建 JSON 数据包 Dim packet As New cJson packet("type") = "data" packet("encoding") = "base64" packet("content") = encoded ' 发送 Socket.SendData VBMAN.ToolsUtf8.Encode(packet.Encode) End Sub Private Sub ReceiveDataPacket(bytes() As Byte) ' 解析 JSON Dim json As cJson Set json = VBMAN.Json.Decode(VBMAN.ToolsUtf8.Decode(bytes)) ' 检查编码方式 If json("encoding") = "base64" Then ' 解码内容 Dim content As String content = VBMAN.ToolsBase64.Decode(json("content")) ' 处理内容... Debug.Print content End If End Sub ``` ## 最佳实践 1. **传输编码**: 二进制数据通过文本协议传输时使用 Base64 2. **图片嵌入**: HTML/CSS 中嵌入小图片使用 Base64 3. **认证信息**: HTTP Basic 认证使用 Base64 编码 4. **数据完整性**: Base64 编码后可安全地在 URL、JSON、XML 中传输 5. **大小注意**: Base64 编码后体积增加约 33%，大数据量考虑其他方案 --- --- url: /en/vbman/global/toolsbase64.md --- # VBMAN.ToolsBase64 - Base64 Encoding/Decoding Object ## Overview `VBMAN.ToolsBase64` provides Base64 encoding and decoding functionality, supporting conversion between strings and byte arrays, commonly used for data transmission, image encoding, configuration files, and other scenarios. ## Core Features * **Bidirectional Conversion**: Supports encoding and decoding * **Multiple Inputs**: Supports strings and byte arrays * **Standard Base64**: Compatible with RFC 4648 standard * **URL Safe**: Supports URL-safe Base64 variant ## Methods ### Encode Encode string to Base64 ```vb Public Function Encode(text As String) As String ``` **Parameters**: * `text` - String to encode **Returns**: Base64 encoded string **Example**: ```vb ' Encode string Dim encoded As String encoded = VBMAN.ToolsBase64.Encode("Hello World") Debug.Print encoded ' SGVsbG8gV29ybGQ= ' Encode Chinese encoded = VBMAN.ToolsBase64.Encode("Hello World") Debug.Print encoded ' 5L2g5aW95LiW55WM ``` ### Decode Decode Base64 to string ```vb Public Function Decode(base64String As String) As String ``` **Parameters**: * `base64String` - Base64 encoded string **Returns**: Decoded string **Example**: ```vb ' Decode Dim decoded As String decoded = VBMAN.ToolsBase64.Decode("SGVsbG8gV29ybGQ=") Debug.Print decoded ' Hello World ``` ### BytesToBase64 Convert byte array to Base64 ```vb Public Function BytesToBase64(bytes() As Byte) As String ``` **Parameters**: * `bytes` - Byte array **Returns**: Base64 encoded string **Example**: ```vb ' Byte array to Base64 Dim bytes(0 To 4) As Byte bytes(0) = 72: bytes(1) = 101 bytes(2) = 108: bytes(3) = 108 bytes(4) = 111 Dim base64 As String base64 = VBMAN.ToolsBase64.BytesToBase64(bytes) Debug.Print base64 ' SGVsbG8= ``` ### Base64ToBytes Convert Base64 to byte array ```vb Public Function Base64ToBytes(base64String As String) As Byte() ``` **Parameters**: * `base64String` - Base64 encoded string **Returns**: Byte array **Example**: ```vb ' Base64 to byte array Dim bytes() As Byte bytes = VBMAN.ToolsBase64.Base64ToBytes("SGVsbG8=") ' Use byte array Dim i As Integer For i = LBound(bytes) To UBound(bytes) Debug.Print bytes(i); Next ``` ## Comprehensive Examples ### Example 1: Image Base64 Encoding ```vb Private Function ImageToBase64(filePath As String) As String ' Read image file VBMAN.FileEx.OpenFile filePath, "R" Dim bytes() As Byte bytes = VBMAN.FileEx.ReadData.ReturnBytes VBMAN.FileEx.C