From 2a22978bdbd71cbe897e6cadeb1e0315aebea0a1 Mon Sep 17 00:00:00 2001 From: Sancarn Date: Tue, 10 Nov 2026 19:05:51 +0000 Subject: [PATCH 1/5] Add stdOutlook for native Outlook data access and mail submission --- README.md | 1 + changelog.md | 4 + docs.json | 766 +++++++++ docs/stdOutlook.md | 445 ++++++ src/stdOutlook.cls | 1415 +++++++++++++++++ tests/README.md | 6 + tests/harnesses/stdOutlook-tests/run.py | 150 ++ .../stdOutlookSendCalendarTests.bas | 595 +++++++ .../stdOutlook-tests/stdOutlookSyncFake.cls | 69 + tests/manifest.json | 20 + tests/native/test_outlook_abi.py | 169 ++ tests/stdOutlookTests.bas | 414 +++++ 12 files changed, 4054 insertions(+) create mode 100644 docs/stdOutlook.md create mode 100644 src/stdOutlook.cls create mode 100644 tests/harnesses/stdOutlook-tests/run.py create mode 100644 tests/harnesses/stdOutlook-tests/stdOutlookSendCalendarTests.bas create mode 100644 tests/harnesses/stdOutlook-tests/stdOutlookSyncFake.cls create mode 100644 tests/native/test_outlook_abi.py create mode 100644 tests/stdOutlookTests.bas diff --git a/README.md b/README.md index 3459e71..02fc4ce 100644 --- a/README.md +++ b/README.md @@ -155,6 +155,7 @@ As an indicator of where my focuses have been in the past year, take a look at t |![l](docs/assets/Status_G.png) | READY | Automation |stdProcess | None | Create and manage processes. |![l](docs/assets/Status_G.png) | READY | Automation |stdAcc | [docs](docs/stdAcc.md) | Use Microsoft Active Accessibility framework within VBA - Very useful for automation. |![l](docs/assets/Status_G.png) | READY | Automation |stdWebSocket | None | WebSocket automation. Currently uses IE, need to move to more stable runtime. Will be useful for modern automation e.g. chrome +|![l](docs/assets/Status_Y.png) | WIP | Automation |stdOutlook | [docs](docs/stdOutlook.md) | Classic Outlook identity, contacts, mail and calendar through native MAPI; plain-text/HTML submission with Outlook Send/Receive. Windows VBA7 only. |![l](docs/assets/Status_Y.png) | WIP | Excel |xlTable | None | Better tables for VBA, e.g. Map rows etc. |![l](docs/assets/Status_G.png) | READY | DevTools |stdPerformance | None | Performance testing diff --git a/changelog.md b/changelog.md index b985af8..43d8eef 100644 --- a/changelog.md +++ b/changelog.md @@ -484,3 +484,7 @@ The 2025-2026 entries were audited retrospectively against commits through `1bcb - 2026-11-01 `Tools/Testing` DEV - Add one manifest-driven command for aggregate, class and named-case tests, structured results, isolated Office workers, dialog/time limits and exact settings restoration. Move specialized test assets under root tests and register Python/native checks. Existing commands inside mixed build-tool folders remain compatibility shims. Split Callback and Regex into independently callable case groups; explicitly report unsupported hosts and legacy fixtures as skipped. - 2026-11-01 `stdLambda` BREAKING - Remove the production test-only protRunVMTests member and its private test helpers. Developers calling stdLambda.protRunVMTests must instead run `python Tools/Testing/run.py --suite stdLambda.vm --test Instructions`; the runner injects tests from tests/support into a disposable class copy. Normal Lambda evaluation APIs, defaults and callback contracts are unchanged. - 2026-11-01 `Tools/Testing` BREAKING - Remove the separate Tools/stdCallback-tests, stdDate-test, stdHTTP-tests, stdImage-tests stdWebSocket-tests and stdEnumerator-tests command folders. Maintainer scripts invoking those paths must migrate to `python Tools/Testing/run.py --suite `: stdCallback.probes, stdDate, stdHTTP.local, stdImage stdWebSocket.local or stdEnumerator.local respectively. Image host selection is now `--host Excel` or `--host Word` through the shared command (formerly `--hosts`). Test bodies and specialized harnesses now live under tests/harnesses. + +- 2026-11-10 `stdOutlook` WIP - Add a standalone Windows VBA7 class for classic Outlook profile identity, address-book contact search, Inbox/message reads and default-calendar text search through Extended MAPI. Uses predeclared Create/protInit construction, TThis state and structured documentation; 32-bit execution and provider coverage remain experimental. Existing stdVBA APIs are unchanged. +- 2026-11-10 `stdOutlook` WIP - Add plain-text and UTF-8 HTML submission with To/CC/BCC and Sent Items copies, native queue flushing, and default late-bound Outlook Send/Receive synchronization. Validate matching stores, keep Outlook available for asynchronous transfer, and report sync errors separately without resubmitting queued mail. Live automatic synchronization/delivery is not validated by tests; calendar recurrences are not expanded. +- 2026-11-10 `stdOutlook-tests` DEV - Register isolated Excel regression tests with synthetic native interfaces and Outlook automation, shared assertion reporting, modal-dialog deadlines and exact VBE settings restoration. Add native ABI checks for 25 vtable slots and both pointer widths, plus opt-in read-only live checks. Tests never submit or synchronize real mail. diff --git a/docs.json b/docs.json index 426e03a..6688936 100644 --- a/docs.json +++ b/docs.json @@ -11323,6 +11323,772 @@ "events": [], "implements": [] }, + { + "name": "stdOutlook", + "fileName": "stdOutlook.cls", + "description": "Access classic Outlook profiles through native Extended MAPI from a single VBA7 class.", + "remarks": [ + "Experimental: 64-bit Excel tested; 32-bit runtime and live synchronization remain unverified.", + "Data access and submission avoid guarded Outlook automation. Send/Receive uses late-bound automation." + ], + "examples": [ + "Set client = stdOutlook.Create()" + ], + "devNotes": [], + "todos": [], + "requires": [ + "Windows VBA7 and classic Outlook with matching Office bitness and a configured profile." + ], + "methods": [ + { + "name": "OpenProfile", + "description": "Release the current native handles and open another profile without logging off Outlook.", + "remarks": [], + "examples": [], + "params": [ + { + "name": "profileName", + "type": "String", + "description": "Profile name; empty shares the current session or uses the default. Explicit names request a separate MAPI session. No native logon UI.", + "optional": true, + "defaultValue": "\"\"", + "paramArray": false, + "referenceType": "ByVal" + } + ], + "returns": null, + "deprecation": { + "status": false, + "message": "" + }, + "isDefaultMember": false, + "devNotes": [], + "todos": [], + "isProtected": false, + "throws": [], + "requires": [], + "isStatic": false + }, + { + "name": "protInit", + "description": "Initialize an instance with a native MAPI profile; prefer Create or OpenProfile.", + "remarks": [], + "examples": [], + "params": [ + { + "name": "profileName", + "type": "String", + "description": "Profile name; empty shares the current session or uses the default. Explicit names request a separate MAPI session. No native logon UI.", + "optional": true, + "defaultValue": "\"\"", + "paramArray": false, + "referenceType": "ByVal" + } + ], + "returns": null, + "deprecation": { + "status": false, + "message": "" + }, + "isDefaultMember": false, + "devNotes": [], + "todos": [], + "isProtected": true, + "throws": [], + "requires": [], + "isStatic": false + }, + { + "name": "Disconnect", + "description": "Release owned native handles and balance MAPI initialization; safe to call repeatedly. Does not quit Outlook.", + "remarks": [], + "examples": [], + "params": [], + "returns": null, + "deprecation": { + "status": false, + "message": "" + }, + "isDefaultMember": false, + "devNotes": [], + "todos": [], + "isProtected": false, + "throws": [], + "requires": [], + "isStatic": false + }, + { + "name": "CurrentUser", + "description": "Primary profile identity, not every account's sending address.\r\nProviders without an identity (for example some PST/IMAP profiles) can fail.", + "remarks": [], + "examples": [], + "params": [], + "returns": { + "type": "Collection", + "description": "Keyed identity properties including Email, DisplayName, EntryID and PropertyErrors; not all account identities." + }, + "deprecation": { + "status": false, + "message": "" + }, + "isDefaultMember": false, + "devNotes": [], + "todos": [], + "isProtected": false, + "throws": [], + "requires": [], + "isStatic": false + }, + { + "name": "AddressBooks", + "description": "Return all address-book containers, including nested Outlook Contacts books.\r\nOnly folders enabled as an Outlook Address Book are visible through this API.", + "remarks": [], + "examples": [], + "params": [], + "returns": { + "type": "Collection", + "description": "One keyed Collection per container: EntryID, DisplayName, Flags, Depth and PropertyErrors." + }, + "deprecation": { + "status": false, + "message": "" + }, + "isDefaultMember": false, + "devNotes": [], + "todos": [], + "isProtected": false, + "throws": [], + "requires": [], + "isStatic": false + }, + { + "name": "SearchContacts", + "description": "Provider-side ambiguous-name resolution (ANR), usually name/alias prefixes.\r\nNot arbitrary substring matching: email matching depends on the provider.\r\ncontainerEntryID optionally limits the search to one AddressBooks() entry.\r\nWarnings and SearchTruncated describe partial results; always inspect them.", + "remarks": [], + "examples": [], + "params": [ + { + "name": "query", + "type": "String", + "description": "Search text; matching rules are described by this method.", + "optional": false, + "defaultValue": null, + "paramArray": false, + "referenceType": "ByVal" + }, + { + "name": "maxResults", + "type": "Long", + "description": "Maximum returned records, from 1 to 10000.", + "optional": true, + "defaultValue": "100", + "paramArray": false, + "referenceType": "ByVal" + }, + { + "name": "containerEntryID", + "type": "String", + "description": "Hexadecimal AddressBooks entry ID; empty searches all recipient containers.", + "optional": true, + "defaultValue": "\"\"", + "paramArray": false, + "referenceType": "ByVal" + } + ], + "returns": { + "type": "Collection", + "description": "Copied keyed contact records with Email, EntryID, AddressBook and PropertyErrors; inspect SearchWarnings and SearchTruncated." + }, + "deprecation": { + "status": false, + "message": "" + }, + "isDefaultMember": false, + "devNotes": [], + "todos": [], + "isProtected": false, + "throws": [], + "requires": [], + "isStatic": false + }, + { + "name": "ReadContact", + "description": "Read copied properties of an address-book entry without guarded Outlook automation.", + "remarks": [], + "examples": [], + "params": [ + { + "name": "entryID", + "type": "String", + "description": "Nonempty, even-length hexadecimal MAPI entry ID in the current profile.", + "optional": false, + "defaultValue": null, + "paramArray": false, + "referenceType": "ByVal" + } + ], + "returns": { + "type": "Collection", + "description": "Copied person fields including Email and PropertyErrors. Missing values are Empty." + }, + "deprecation": { + "status": false, + "message": "" + }, + "isDefaultMember": false, + "devNotes": [], + "todos": [], + "isProtected": false, + "throws": [], + "requires": [], + "isStatic": false + }, + { + "name": "Inbox", + "description": "Optional mail access: newest messages in the default store's Inbox.\r\nDoes not mark messages read. Times are UTC. No bodies in the table result.", + "remarks": [], + "examples": [], + "params": [ + { + "name": "maxResults", + "type": "Long", + "description": "Maximum returned records, from 1 to 10000.", + "optional": true, + "defaultValue": "50", + "paramArray": false, + "referenceType": "ByVal" + } + ], + "returns": { + "type": "Collection", + "description": "Newest message metadata records, without bodies; times are UTC and entries are not marked read." + }, + "deprecation": { + "status": false, + "message": "" + }, + "isDefaultMember": false, + "devNotes": [], + "todos": [], + "isProtected": false, + "throws": [], + "requires": [], + "isStatic": false + }, + { + "name": "ReadMessage", + "description": "Entry ID must belong to the default store (e.g. from Inbox).\r\nLarge/unavailable bodies remain Empty with the HRESULT in PropertyErrors.", + "remarks": [], + "examples": [], + "params": [ + { + "name": "entryID", + "type": "String", + "description": "Nonempty, even-length hexadecimal MAPI entry ID in the current profile.", + "optional": false, + "defaultValue": null, + "paramArray": false, + "referenceType": "ByVal" + } + ], + "returns": { + "type": "Collection", + "description": "Message metadata and plain-text Body. Missing or oversized values are Empty with HRESULTs in PropertyErrors." + }, + "deprecation": { + "status": false, + "message": "" + }, + "isDefaultMember": false, + "devNotes": [], + "todos": [], + "isProtected": false, + "throws": [], + "requires": [], + "isStatic": false + }, + { + "name": "SendEmail", + "description": "Submit a plain-text message. Lists contain semicolon-separated bare SMTP\r\naddresses (not display names/aliases). Success means queued, not delivered.", + "remarks": [ + "Success means submitted. Inspect LastSendSyncError; never resend a queued message after a sync error." + ], + "examples": [], + "params": [ + { + "name": "toAddresses", + "type": "String", + "description": "Semicolon-separated bare SMTP addresses. At least one To, CC, or BCC recipient is required.", + "optional": false, + "defaultValue": null, + "paramArray": false, + "referenceType": "ByVal" + }, + { + "name": "subject", + "type": "String", + "description": "Subject text; empty is allowed, embedded null characters are rejected.", + "optional": false, + "defaultValue": null, + "paramArray": false, + "referenceType": "ByVal" + }, + { + "name": "body", + "type": "String", + "description": "Plain-text Unicode body; empty is allowed, embedded null characters are rejected.", + "optional": false, + "defaultValue": null, + "paramArray": false, + "referenceType": "ByVal" + }, + { + "name": "ccAddresses", + "type": "String", + "description": "Optional semicolon-separated bare SMTP CC addresses.", + "optional": true, + "defaultValue": "\"\"", + "paramArray": false, + "referenceType": "ByVal" + }, + { + "name": "bccAddresses", + "type": "String", + "description": "Optional semicolon-separated bare SMTP BCC addresses.", + "optional": true, + "defaultValue": "\"\"", + "paramArray": false, + "referenceType": "ByVal" + }, + { + "name": "flushQueue", + "type": "Boolean", + "description": "True requests synchronization after successful submission; False queues only. Defaults to True.", + "optional": true, + "defaultValue": "True", + "paramArray": false, + "referenceType": "ByVal" + } + ], + "returns": null, + "deprecation": { + "status": false, + "message": "" + }, + "isDefaultMember": false, + "devNotes": [], + "todos": [], + "isProtected": false, + "throws": [], + "requires": [], + "isStatic": false + }, + { + "name": "SendEmailHTML", + "description": "Submit an HTML message. HTML is written as UTF-8 PR_HTML, with CPID 65001.\r\nNo attachments, account override, or plain-text alternative is synthesized.", + "remarks": [ + "Success means submitted. Inspect LastSendSyncError; never resend a queued message after a sync error." + ], + "examples": [], + "params": [ + { + "name": "toAddresses", + "type": "String", + "description": "Semicolon-separated bare SMTP addresses. At least one To, CC, or BCC recipient is required.", + "optional": false, + "defaultValue": null, + "paramArray": false, + "referenceType": "ByVal" + }, + { + "name": "subject", + "type": "String", + "description": "Subject text; empty is allowed, embedded null characters are rejected.", + "optional": false, + "defaultValue": null, + "paramArray": false, + "referenceType": "ByVal" + }, + { + "name": "htmlBody", + "type": "String", + "description": "HTML fragment or document stored as UTF-8 PR_HTML; no plain-text alternative is synthesized.", + "optional": false, + "defaultValue": null, + "paramArray": false, + "referenceType": "ByVal" + }, + { + "name": "ccAddresses", + "type": "String", + "description": "Optional semicolon-separated bare SMTP CC addresses.", + "optional": true, + "defaultValue": "\"\"", + "paramArray": false, + "referenceType": "ByVal" + }, + { + "name": "bccAddresses", + "type": "String", + "description": "Optional semicolon-separated bare SMTP BCC addresses.", + "optional": true, + "defaultValue": "\"\"", + "paramArray": false, + "referenceType": "ByVal" + }, + { + "name": "flushQueue", + "type": "Boolean", + "description": "True requests synchronization after successful submission; False queues only. Defaults to True.", + "optional": true, + "defaultValue": "True", + "paramArray": false, + "referenceType": "ByVal" + } + ], + "returns": null, + "deprecation": { + "status": false, + "message": "" + }, + "isDefaultMember": false, + "devNotes": [], + "todos": [], + "isProtected": false, + "throws": [], + "requires": [], + "isStatic": false + }, + { + "name": "SendAndReceive", + "description": "The documented equivalent of Outlook's Send/Receive All button. This is the\r\nonly production path using Outlook automation; no guarded data or Send calls.\r\nStarts classic Outlook if needed, and leaves a window open so asynchronous\r\ntransfer can continue after this class is released. Never calls Outlook.Quit.\r\nAll accounts in that Outlook profile participate. Return is NOT delivery.", + "remarks": [], + "examples": [], + "params": [ + { + "name": "showProgress", + "type": "Boolean", + "description": "Whether to show Outlook Send/Receive progress; defaults to False.", + "optional": true, + "defaultValue": "False", + "paramArray": false, + "referenceType": "ByVal" + } + ], + "returns": null, + "deprecation": { + "status": false, + "message": "" + }, + "isDefaultMember": false, + "devNotes": [], + "todos": [], + "isProtected": false, + "throws": [], + "requires": [], + "isStatic": false + }, + { + "name": "FlushQueues", + "description": "Request immediate transfer of pending mail in this profile, including mail\r\nqueued by other callers. Not equivalent to synchronizing every Outlook folder.\r\nReturns the number of status objects that accepted the request; raises on\r\nunsupported providers or failure (possibly after some queues were flushed).\r\nSpooler requests may be asynchronous; direct transport calls can block.", + "remarks": [], + "examples": [], + "params": [ + { + "name": "includeReceive", + "type": "Boolean", + "description": "True flushes incoming and outgoing queues; False requests outgoing only. Defaults to False.", + "optional": true, + "defaultValue": "False", + "paramArray": false, + "referenceType": "ByVal" + } + ], + "returns": { + "type": "Long", + "description": "Number of status objects accepting the request, not messages delivered; raises on unsupported providers or failure." + }, + "deprecation": { + "status": false, + "message": "" + }, + "isDefaultMember": false, + "devNotes": [], + "todos": [], + "isProtected": false, + "throws": [], + "requires": [], + "isStatic": false + }, + { + "name": "SearchCalendar", + "description": "Search stored calendar items by case-insensitive subject/location/organizer\r\nsubstring. Empty query lists items. Recurring masters are NOT expanded.", + "remarks": [ + "Empty query lists appointments; nonempty text matches Subject, Location or OrganizerName. Stored masters only." + ], + "examples": [], + "params": [ + { + "name": "query", + "type": "String", + "description": "Search text; matching rules are described by this method.", + "optional": true, + "defaultValue": "\"\"", + "paramArray": false, + "referenceType": "ByVal" + }, + { + "name": "maxResults", + "type": "Long", + "description": "Maximum returned records, from 1 to 10000.", + "optional": true, + "defaultValue": "100", + "paramArray": false, + "referenceType": "ByVal" + } + ], + "returns": { + "type": "Collection", + "description": "Stored appointment records with Subject, Location, OrganizerName, StartUtc, EndUtc, IsRecurring, RecurrenceExpanded and PropertyErrors. Recurrences are not expanded." + }, + "deprecation": { + "status": false, + "message": "" + }, + "isDefaultMember": false, + "devNotes": [], + "todos": [], + "isProtected": false, + "throws": [], + "requires": [], + "isStatic": false + } + ], + "properties": [ + { + "name": "IsOpen", + "access": "ReadOnly", + "description": "Whether this instance owns an open MAPI session.", + "remarks": [], + "examples": [], + "params": [], + "returns": { + "type": "Boolean", + "description": "True if a native session is open." + }, + "deprecation": { + "status": false, + "message": "" + }, + "isDefaultMember": false, + "devNotes": [], + "todos": [], + "isProtected": false, + "throws": [], + "requires": [], + "isStatic": false + }, + { + "name": "CurrentUserEmail", + "access": "ReadOnly", + "description": "Resolve the profile identity SMTP address; raise if none is supplied by the provider.", + "remarks": [], + "examples": [], + "params": [], + "returns": { + "type": "String", + "description": "The resolved primary SMTP address, never an Exchange legacy DN." + }, + "deprecation": { + "status": false, + "message": "" + }, + "isDefaultMember": false, + "devNotes": [], + "todos": [], + "isProtected": false, + "throws": [], + "requires": [], + "isStatic": false + }, + { + "name": "SearchTruncated", + "access": "ReadOnly", + "description": "Whether the latest contact search may have omitted matching records.", + "remarks": [], + "examples": [], + "params": [], + "returns": { + "type": "Boolean", + "description": "True if results may be incomplete; conservative when the result limit is reached." + }, + "deprecation": { + "status": false, + "message": "" + }, + "isDefaultMember": false, + "devNotes": [], + "todos": [], + "isProtected": false, + "throws": [], + "requires": [], + "isStatic": false + }, + { + "name": "SearchWarnings", + "access": "ReadOnly", + "description": "Return an independent copy of warnings from the latest contact search.", + "remarks": [], + "examples": [], + "params": [], + "returns": { + "type": "Collection", + "description": "Warning strings; mutating this copy cannot change diagnostic state." + }, + "deprecation": { + "status": false, + "message": "" + }, + "isDefaultMember": false, + "devNotes": [], + "todos": [], + "isProtected": false, + "throws": [], + "requires": [], + "isStatic": false + }, + { + "name": "LastSendSyncRequested", + "access": "ReadOnly", + "description": "These describe only the latest SendEmail/SendEmailHTML call. A successful\r\nflush request is not a delivery receipt. False + empty error means skipped.", + "remarks": [], + "examples": [], + "params": [], + "returns": { + "type": "Boolean", + "description": "True if the latest send synchronization request was accepted; not confirmation of delivery." + }, + "deprecation": { + "status": false, + "message": "" + }, + "isDefaultMember": false, + "devNotes": [], + "todos": [], + "isProtected": false, + "throws": [], + "requires": [], + "isStatic": false + }, + { + "name": "LastSendSyncError", + "access": "ReadOnly", + "description": "Immediate synchronization error from the latest send, or an empty string; never a delivery receipt.", + "remarks": [], + "examples": [], + "params": [], + "returns": { + "type": "String", + "description": "Error description after a successful submission but failed synchronization; empty if skipped or no immediate error." + }, + "deprecation": { + "status": false, + "message": "" + }, + "isDefaultMember": false, + "devNotes": [], + "todos": [], + "isProtected": false, + "throws": [], + "requires": [], + "isStatic": false + }, + { + "name": "UseOutlookSendReceive", + "access": "ReadWrite", + "description": "True by default: use Outlook's Send/Receive All after submission. False keeps\r\nthe older native FlushQueues path, which some cached transports do not drain.\r\nThe per-send flushQueue:=False option skips either synchronization path.", + "remarks": [], + "examples": [], + "params": [], + "returns": { + "type": "Boolean", + "description": "True for Outlook automation, False for native queue flushing." + }, + "deprecation": { + "status": false, + "message": "" + }, + "isDefaultMember": false, + "devNotes": [], + "todos": [], + "isProtected": false, + "throws": [], + "requires": [], + "isStatic": false + }, + { + "name": "CalendarSearchTruncated", + "access": "ReadOnly", + "description": "Whether the latest calendar search found additional records beyond its result limit.", + "remarks": [], + "examples": [], + "params": [], + "returns": { + "type": "Boolean", + "description": "True when more records exist than the requested maximum." + }, + "deprecation": { + "status": false, + "message": "" + }, + "isDefaultMember": false, + "devNotes": [], + "todos": [], + "isProtected": false, + "throws": [], + "requires": [], + "isStatic": false + } + ], + "constructors": [ + { + "name": "Create", + "description": "Empty profile: share the current MAPI session, or use the default profile.\r\nExplicit profile: request a separate session so MAPI cannot ignore its name.\r\nNever enables logon UI. Credentials/profile setup remain Outlook's job.", + "remarks": [], + "examples": [ + "Set client = stdOutlook.Create()" + ], + "params": [ + { + "name": "profileName", + "type": "String", + "description": "Profile name; empty shares the current session or uses the default. Explicit names request a separate MAPI session. No native logon UI.", + "optional": true, + "defaultValue": "\"\"", + "paramArray": false, + "referenceType": "ByVal" + } + ], + "returns": { + "type": "stdOutlook", + "description": "An initialized stdOutlook instance owning its MAPI handles." + }, + "deprecation": { + "status": false, + "message": "" + }, + "isDefaultMember": false, + "devNotes": [], + "todos": [], + "isProtected": false, + "throws": [], + "requires": [], + "isStatic": false + } + ], + "events": [], + "implements": [] + }, { "name": "stdPerformance", "fileName": "stdPerformance.cls", diff --git a/docs/stdOutlook.md b/docs/stdOutlook.md new file mode 100644 index 0000000..5e685d6 --- /dev/null +++ b/docs/stdOutlook.md @@ -0,0 +1,445 @@ +# stdOutlook + +Read Outlook's current profile identity, address-book contacts, messages, and +calendar, and send plain-text or HTML email from one VBA class, without +Redemption or an Outlook reference. Data access and message submission use native +MAPI; automatic synchronization uses late-bound `Outlook.Application`. + +Import **[src/stdOutlook.cls](../src/stdOutlook.cls)**. Everything needed at runtime is +inside that class; the accompanying Outlook documentation and tests are not runtime dependencies. + +## How it works + +The timed address-access prompts are associated with Outlook's **Object Model +Guard**, rather than a general five-minute COM lifetime. This class calls the +documented **Extended MAPI** interfaces underneath classic Outlook for reading +data and submitting messages. Synchronization uses `NameSpace.SendAndReceive`, +which is not listed among Microsoft's +[Object Model Guard protected members](https://learn.microsoft.com/en-us/office/vba/outlook/how-to/security/protected-properties-and-methods). +The class does not change security settings or use guarded address/body access +or `MailItem.Send`. Outlook startup/sign-in can still require user interaction. + +`MAPIInitialize` and `MAPILogonEx` open the installed MAPI provider. VBA calls its +native interfaces through `oleaut32!DispCallFunc`. This follows the native-call +approach used by [stdVBA's stdCOM](https://github.com/sancarn/stdVBA/blob/master/src/stdCOM.cls), +without requiring stdCOM or executable-memory thunks. + +MAPI uses COM-style `IUnknown` vtables internally. Data access is independent of +Outlook automation, not literally free of COM technology. It uses the existing +profile and its permissions; it does not extract credentials or parse OST/PST +files. Providers can access the server as well as cached data. + +## Requirements + +- Windows, **classic Outlook**, and a configured profile. New Outlook has no + Extended MAPI support. +- A VBA7 host, such as Excel 2010 or later, with the **same bitness as Outlook**. +- Classic Outlook registered as the MAPI client used by Windows's `mapi32.dll`. +- A profile already able to sign in. Native MAPI logon and address-book dialogs + are disabled; missing credentials, permissions, or profile setup produce VBA + errors. Automatic synchronization also requires working Outlook automation. + +64-bit Excel/classic Outlook has been exercised locally. The 32-bit branch has +layout checks but has **not yet been run in 32-bit Office**. Treat that platform +as experimental until tested there. Mac VBA, VBA6, and new Outlook are unsupported. + +## Installation and first call + +In the VBA editor, use **File > Import File** to import `src/stdOutlook.cls`. +Importing preserves the predeclared instance required by `stdOutlook.Create`; +pasting into a blank class does not. + +```vb +Sub WhoAmI() + Dim outlook As stdOutlook + Set outlook = stdOutlook.Create() + Debug.Print outlook.CurrentUserEmail + outlook.Disconnect +End Sub +``` + +Keep that instance for subsequent calls. `Create()` shares the existing MAPI +session when one is available, otherwise uses the default profile. For a specific +profile, use `stdOutlook.Create("Profile name")`; this requests a new session to +ensure the profile name is honored. A profile is not an account display name. +Sessions are mail-capable (the `MAPI_NO_MAIL` flag is not used), so MAPI can start +the profile's transport/spooler. Store handles are opened read-only initially; +the first send requests a writable handle. Only the send methods submit messages. + +`Disconnect` is idempotent and releases the native objects and MAPI initialization. +It does not log Outlook out of a shared session. Normal class termination also +cleans up. Avoid VBA's `End` statement or the VBE Reset button while the instance +is live: those bypass normal class cleanup. Use normal error handlers and release +the instance before editing/recompiling the project. + +## Find contact details + +```vb +Sub FindPeople() + Dim outlook As stdOutlook, people As Collection, person As Collection + Dim warning As Variant, number As Long, description As String + On Error GoTo Failed + Set outlook = stdOutlook.Create() + Set people = outlook.SearchContacts("Ada", maxResults:=25) + For Each person In people + Debug.Print person("DisplayName"), person("Email"), _ + person("BusinessPhone"), person("MobilePhone") + Next + If outlook.SearchTruncated Then Debug.Print "Result limit reached. Narrow the search." + For Each warning In outlook.SearchWarnings + Debug.Print warning + Next +Done: + On Error GoTo 0 + If Not outlook Is Nothing Then outlook.Disconnect + If number <> 0 Then Err.Raise number, "FindPeople", description + Exit Sub +Failed: + number = Err.Number: description = Err.Description + Resume Done +End Sub +``` + +Search uses the address-book provider's **ambiguous name resolution (ANR)**, usually +matching name or alias prefixes. Matching full SMTP addresses depends on the +provider. This is not an arbitrary substring, phone-number, or message-body search. +The provider filters results before they are fetched; the class does not download +the whole directory to search it in VBA. + +`AddressBooks()` lists containers, including nested books. To target one, pass its +hexadecimal `EntryID` as the third argument to `SearchContacts`. Searching all books +skips containers without recipient contents and deduplicates identical entry IDs; +the same person with different entry IDs can still appear more than once. + +Search covers the directory and Contacts folders **exposed by Outlook's address-book +providers**. A Contacts folder not enabled as an Outlook Address Book, autocomplete +recipients, and addresses occurring only in mail history are outside this API. +Distribution lists and other addressable directory objects can also match; +inspect `ObjectType` (`6` = mail user, `8` = distribution list). + +Always inspect `SearchWarnings` and `SearchTruncated`. A failed provider or contact +read is reported as a warning while other books continue. A zero-match result with +warnings is not a complete negative search. Truncation is conservative when the +global result cap is reached. The maximum result limit is 10,000; default is 100. +Calls are synchronous, and a slow provider can block VBA. + +## Returned records + +Records are native VBA `Collection` objects with string keys. No scripting runtime +or additional COM library is needed. Data is copied out before native buffers are +released, so records remain valid after `Disconnect`. + +`CurrentUser()` and `ReadContact(entryID)` return these keys: + +- `EntryID`, `DisplayName`, `GivenName`, `Surname`, `ObjectType`. +- `Email`, `SmtpAddress`, `AddressType`, `EmailAddress`, `ProxyAddresses`. +- `Company`, `Department`, `JobTitle`, `Office`. +- `BusinessPhone`, `MobilePhone`, `HomePhone`. +- `PropertyErrors`, a keyed Collection of HRESULTs for unavailable properties. + +Search results have the same keys plus `AddressBook`. Unsupported or unavailable +properties have the value `Empty`; `PropertyErrors("BusinessPhone")`, for example, +contains the provider's HRESULT if that field failed. `ProxyAddresses`, when +available, is a zero-based string array. Binary entry IDs are hexadecimal strings. + +`Email` prefers `PR_SMTP_ADDRESS`, then an address whose type is SMTP, then the +uppercase `SMTP:` primary Exchange proxy. An Exchange `/o=...` address is preserved +in `EmailAddress` but is never presented as an SMTP address. If no primary SMTP +address is available, `Email` is an empty string and `CurrentUserEmail` raises +`MAPI_E_NOT_FOUND` instead of inventing one. + +The current user is the profile's **primary MAPI identity**, not a list of all +configured accounts. Some PST/IMAP profiles do not implement `QueryIdentity`. +Those providers raise their native error; no registry or account-name guess is +used as a substitute. + +`AddressBooks()` records contain `EntryID`, `DisplayName`, `Flags`, `Depth`, and +`PropertyErrors`. The hierarchy is bounded at 10,000 containers and fails explicitly +if that bound is exceeded. + +## Optional message reads + +```vb +Sub ReadRecentMail() + Dim outlook As stdOutlook, headers As Collection, header As Collection + Dim message As Collection + Set outlook = stdOutlook.Create() + Set headers = outlook.Inbox(10) + For Each header In headers + Debug.Print header("Subject"), header("ReceivedTimeUtc") + Next + If headers.Count > 0 Then + Set header = headers(1) + Set message = outlook.ReadMessage(header("EntryID")) + Debug.Print message("Body") + End If + outlook.Disconnect +End Sub +``` + +`Inbox` reads the default message store's Inbox, newest first. Records contain +`EntryID`, `Subject`, `SenderName`, `SenderAddressType`, `SenderEmailAddress`, +`SenderSmtpAddress`, `ReceivedTimeUtc`, `MessageClass`, `MessageFlags`, +`HasAttachments`, and `PropertyErrors`. Timestamps are UTC VBA dates. Raw sender +addresses can be Exchange distinguished names; use `SenderSmtpAddress` for SMTP +when supplied. `ReadMessage` adds the plain-text `Body` and accepts an entry ID from +that same default store. + +These reads do not mark messages as read. Editing existing messages, attachments, +HTML/RTF reading, arbitrary folders, secondary stores, and full-text mail search +are not implemented. +Large bodies that require `IStream` can return `Empty` with an error in +`PropertyErrors`; streaming large bodies is not implemented. There is no promise +that a provider will have every requested field cached or available offline. + +## Send plain-text or HTML email + +```vb +Sub SendExamples() + Dim outlook As stdOutlook + Set outlook = stdOutlook.Create() + + 'Each call immediately submits a message; there is no compose dialog. + outlook.SendEmail "alice@example.com;bob@example.com", _ + "Status update", "The report is ready.", _ + ccAddresses:="manager@example.com" + If Len(outlook.LastSendSyncError) > 0 Then + Debug.Print "Submitted, but synchronization failed: " & outlook.LastSendSyncError + 'Do not send the same message again. It is already queued. + End If + + outlook.SendEmailHTML "alice@example.com", "Status update", _ + "

Report ready

Please review the summary.

", _ + bccAddresses:="archive@example.com" + + outlook.Disconnect +End Sub +``` + +The signatures are: + +```vb +SendEmail(toAddresses As String, subject As String, body As String, _ + Optional ccAddresses As String = "", Optional bccAddresses As String = "", _ + Optional flushQueue As Boolean = True) +SendEmailHTML(toAddresses As String, subject As String, htmlBody As String, _ + Optional ccAddresses As String = "", Optional bccAddresses As String = "", _ + Optional flushQueue As Boolean = True) +``` + +Both are Subs. They submit through the default message store's transport and +request a copy in that store's Sent Items folder. They do not choose a secondary +account or override the sender. The profile must have an Outbox, Sent Items, +write access, and a working transport. If a profile was previously shared by a +client using `MAPI_NO_MAIL`, reconnect with an explicit profile name to obtain a +fresh mail-capable session. + +Use semicolon-separated **bare SMTP addresses**. Display-name forms such as +`Alice `, aliases, comma-separated lists, quoted local parts, +and empty entries are rejected. At least one To, CC, or BCC recipient is required; +BCC-only messages are supported. The limit is 1,000 recipients across all lists. +Validation checks the supported syntax, not whether a mailbox exists or accepts +mail. Addresses are explicit SMTP one-off recipients; no ambiguous name is +silently resolved to a different person. + +`SendEmail` stores a Unicode plain-text body. `SendEmailHTML` writes UTF-8 binary +`PR_HTML` and sets `PR_INTERNET_CPID` to 65001. It accepts an HTML fragment or full +document. It does not escape HTML, synthesize a plain-text alternative, or add +attachments/embedded images. Empty subjects and bodies are allowed. Embedded null +characters are rejected to prevent native strings from being silently truncated. + +Successful return means **accepted for submission**, not confirmed delivery. +Both methods now call Outlook's **Send/Receive All** after submission and release +of the message. Earlier versions used native `FlushQueues`, which accepted requests +but did not drain the Outbox in the reported setup. Existing calls gain Outlook +synchronization automatically; use `flushQueue:=False` to retain queue-only +behavior or batch several messages before a single `SendAndReceive` call. The +existing parameter name is retained for named-argument compatibility. + +Delivery depends on the transport and connectivity; classic Outlook may need to +be running for a cached profile's transport to drain the Outbox. Preparation +and per-property `SetProps` failures raise VBA errors. Preparation failures prevent +submission, and submission failures are never automatically retried. A provider +may retain an unsent item after a failure; inspect the Outbox before manually +retrying to avoid duplicates. There is no delivery receipt or cancellation API. + +### Request immediate sending / receiving + +```vb +'For already queued messages; does not create or resubmit an email: +outlook.SendAndReceive 'The Outlook button equivalent; hide progress +'outlook.SendAndReceive True 'Optionally show the progress dialog +``` + +`SendAndReceive(Optional showProgress As Boolean = False)` is a Sub using +[`NameSpace.SendAndReceive`](https://learn.microsoft.com/en-us/office/vba/api/outlook.namespace.sendandreceive). +It attaches to running classic Outlook or starts it, initializes its default +profile by accessing the Inbox folder (without reading messages), and checks that +Outlook and this class use the same default message store. Native `CompareEntryIDs` +checks store identity rather than comparing identifier strings. A mismatch or +failed comparison prevents the Send/Receive request. For an explicitly selected +nondefault MAPI profile, open Outlook with that profile first; this method does +not switch a running Outlook session to another profile. + +If Outlook has no Explorer window, the method opens the Inbox window and leaves +it open. This keeps Outlook available for asynchronous synchronization after the +macro ends or `Disconnect` releases this class. Existing windows are reused without +opening another one. The class never calls Outlook's `Quit`. Startup may prompt +for profile setup or credentials if Outlook is not already configured to sign in. + +The request affects **all accounts and pending messages in that Outlook profile**, +including messages queued outside this library. It returns before synchronization +finishes; successful return does not confirm delivery. Offline/network/provider +errors can occur later in Outlook. An explicit call raises startup, store validation, +or immediate automation errors; automatic calls report them in `LastSendSyncError`. + +### Native-only queue flushing + +`UseOutlookSendReceive` defaults to True. Set it to False to use the previous +native-only automatic synchronization path, or call the native method directly: + +```vb +outlook.UseOutlookSendReceive = False 'Future sends use native FlushQueues +Debug.Print outlook.FlushQueues() 'Outgoing mail only (default) +Debug.Print outlook.FlushQueues(True) 'Outgoing and incoming mail +``` + +`FlushQueues(Optional includeReceive As Boolean = False) As Long` uses native +[`IMAPIStatus::FlushQueues`](https://learn.microsoft.com/en-us/office/client-developer/outlook/mapi/imapistatus-flushqueues). +It checks the status table's advertised capabilities, prefers the MAPI spooler, +or calls supported individual transports when no capable spooler is present. +The return value counts status objects that accepted the request, not messages +delivered. An explicit call raises if no provider supports flushing or a native +call fails; earlier transports may already have processed mail before a failure. +It does not fall back to Outlook automation or retry failed requests. + +**Scope:** flushing can send other pending messages in the same profile, including +ones queued outside this library. It is a mail queue operation, not a promise to +synchronize every folder or calendar like Outlook's **Send/Receive All Folders**. +Providers can reject the request or remain offline. Spooler calls allow asynchronous +processing; direct transport calls are synchronous and may block while transferring +mail. Progress UI is suppressed. In the reported setup, this native path did not +send queued mail until Outlook's Send/Receive button was used, even with Outlook +running. Treat a successful native return only as acceptance of the request. + +After each `SendEmail` or `SendEmailHTML`, inspect `LastSendSyncRequested` and +`LastSendSyncError`. True means the selected synchronization request was accepted, +not that delivery completed. A nonempty error means submission succeeded but +synchronization failed or is unsupported: **do not call SendEmail again for that +message**. Call `SendAndReceive` or use Outlook's button instead. Both properties +reset at the start of each send; False with an empty error means synchronization +was skipped (or submission +failed before synchronization). Explicit `FlushQueues` and `SendAndReceive` calls +do not alter these properties. Automatic synchronization errors are deliberately +not raised as send failures, to keep callers from retrying and creating duplicate +messages. + +## Search the calendar + +```vb +Sub FindAppointments() + Dim outlook As stdOutlook, appointments As Collection, item As Collection + Set outlook = stdOutlook.Create() + Set appointments = outlook.SearchCalendar("planning", maxResults:=50) + For Each item In appointments + Debug.Print item("Subject"), item("Location"), _ + item("StartUtc"), item("EndUtc"), item("IsRecurring") + Next + If outlook.CalendarSearchTruncated Then Debug.Print "More calendar items match." + outlook.Disconnect +End Sub +``` + +`SearchCalendar(Optional query As String = "", Optional maxResults As Long = 100)` +searches the **default store's Calendar folder**, using a provider-side, +case-insensitive substring restriction across `Subject`, `Location`, and +`OrganizerName`. An empty query lists stored calendar items. Results are ordered +by descending start time when the start property is mapped. The limit is 1–10,000. +`CalendarSearchTruncated` reports whether more matching rows were available and +is independent of contact-search diagnostics. Provider failures raise errors. + +Records contain `EntryID`, `Subject`, `OrganizerName`, `MessageClass`, `Location`, +`StartUtc`, `EndUtc`, `IsRecurring`, `RecurrenceExpanded`, and `PropertyErrors`. +Organizer name comes from `PR_SENT_REPRESENTING_NAME`; a provider can leave it +unavailable. Missing properties are `Empty`, with HRESULTs in `PropertyErrors`. +Named appointment properties are resolved for this store with `GetIDsFromNames`; +the class does not assume fixed property IDs or create mappings while searching. + +Results are **stored appointments and recurring-series masters**, not expanded +occurrences. `RecurrenceExpanded` is always `False`. For a recurring master, +`StartUtc`/`EndUtc` describe the first occurrence, not the next occurrence. Embedded +exceptions and their changed subjects/locations are not searched separately. +There is no date-range filtering, free/busy calculation, recurrence expansion, +meeting-body search, or traversal of shared/secondary calendars. All returned +times are UTC; convert them for display in the user's time zone. + +## Development tests and VBE safeguards + +The test runner follows the safeguards in +[stdVBA's AGENTS.md](https://github.com/sancarn/stdVBA/blob/master/AGENTS.md). +Install Python with `pywin32` and run from this repository root: + +```powershell +python Tools/Testing/run.py --suite stdOutlook +python tests/harnesses/stdOutlook-tests/run.py --live +python tests/native/test_outlook_abi.py --download +``` + +The first command uses synthetic native vtables and MAPI-allocated buffers. It +requires classic Outlook's native MAPI installation but does not open a profile. +`--live` additionally opens the default profile and reads identity, contact search, +one Inbox message, and calendar search. Both send methods and queue flushing are +always tested with synthetic vtables, and Outlook synchronization uses a test-only +late-bound fake. Application acquisition is replaced only in the temporary class; +the runner rejects unexpected source changes rather than risk starting Outlook. +**No real email is sent or real queues flushed, even with `--live`.** Logs contain +assertions and counts, not email addresses, +names, subjects, or bodies. Do not run the live test against a profile you do not +intend to access. + +The ABI check derives method slots from Microsoft's pinned MAPI header blobs and +checks both 32-bit and 64-bit structure layouts. To run without network access, +use `--headers path/to/MAPIStubLibrary/include` instead of `--download`. + +Validation includes live SMTP identity lookup, contact search, an Inbox message +read, and a calendar subject search in 64-bit Excel. Simulated send tests cover +plain text, UTF-8 HTML, To/CC/BCC, write access, property failures, submission +failures, cleanup, and no automatic retries. Queue tests cover automatic flushing, +batch opt-out, spooler preference, direct transport fallback, incoming flags, +unsupported providers, failure isolation, and status-object cleanup. The current +synthetic suite passes 109 assertions in 64-bit Excel. Outlook tests cover existing +and newly started instances, window lifetime, matching/mismatched stores, startup +and synchronization failures, batch opt-out, and no duplicate submission. All 25 +native vtable slots match Microsoft's headers, and both pointer-width layout checks +pass. Live Outlook automation startup/synchronization and delivery, every provider, +32-bit Office execution, and long-duration sessions have not been validated by +the test suite. + +Before imports, the runner verifies actual CRLF bytes and stages a temporary copy +of the class with test probes. It creates a separate hidden Excel process and +disposable workbook, detects the installed Office/VBE versions, respects managed +policy, and records/restores the exact `AccessVBOM`, `BreakOnAllErrors`, and +`BreakOnServerErrors` registry values. Tests use **Break on Unhandled Errors**. +The parent watchdog dismisses only the owned instance's dialogs, treats every +such dialog as failure, enforces bounded execution, and closes only its own process. +A process lock prevents overlapping stdVBA test transactions. + +The runner uses a temporary copy of stdVBA's host with an explicit compile step +and `ShowWindowAsync` so minimizing a busy Office window cannot block the watchdog. +The shared host source is not modified. Compile dialogs can still appear briefly; +the watchdog captures their text and minimizes the owned windows. Cleanup restores +the saved settings after ordinary failures and worker timeouts. As with any +process-based runner, forcibly killing the parent or powering off the machine +can prevent its cleanup. + +## Native interface references + +- [Outlook Object Model Guard](https://learn.microsoft.com/en-us/office/vba/outlook/how-to/security/security-behavior-of-the-outlook-object-model). +- [MAPILogonEx and profile selection](https://learn.microsoft.com/en-us/office/client-developer/outlook/mapi/mapilogonex). +- [Microsoft's MAPI interface headers](https://github.com/microsoft/MAPIStubLibrary/tree/main/include). +- [Address-book restrictions and ANR](https://learn.microsoft.com/en-us/office/client-developer/outlook/mapi/address-book-restrictions). +- [MAPI property errors](https://learn.microsoft.com/en-us/office/client-developer/outlook/mapi/handling-mapi-property-errors). +- [Submitting messages](https://learn.microsoft.com/en-us/office/client-developer/outlook/mapi/imessage-submitmessage). +- [Locating the default Calendar](https://learn.microsoft.com/en-us/office/client-developer/outlook/mapi/pidtagipmappointmententryid-canonical-property). +- [Mapping named properties](https://learn.microsoft.com/en-us/office/client-developer/outlook/mapi/imapiprop-getidsfromnames). +- [Classic versus new Outlook support](https://support.microsoft.com/en-us/outlook/getstarted/feature-comparison-between-new-outlook-and-classic-outlook). diff --git a/src/stdOutlook.cls b/src/stdOutlook.cls new file mode 100644 index 0000000..b7492d1 --- /dev/null +++ b/src/stdOutlook.cls @@ -0,0 +1,1415 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "stdOutlook" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = True +Attribute VB_Exposed = False +Option Explicit + +'@module +'@description Access classic Outlook profiles through native Extended MAPI from a single VBA7 class. +'@remark Experimental: 64-bit Excel tested; 32-bit runtime and live synchronization remain unverified. +'@remark Data access and submission avoid guarded Outlook automation. Send/Receive uses late-bound automation. +'@requires Windows VBA7 and classic Outlook with matching Office bitness and a configured profile. +'@example Set client = stdOutlook.Create() + +'Extended MAPI client for Windows VBA7, both Office architectures. +'Import this file; no Outlook reference, stdVBA dependency, or helper DLL. +'Data/submission use MAPI; automatic sync uses unguarded Outlook automation. +'MAPI uses IUnknown vtables, NOT the guarded Outlook automation object model. +'See docs/stdOutlook.md for provider limitations and tests/ for ABI validation. + +Private Declare PtrSafe Function MAPIInitialize Lib "mapi32.dll" (ByVal pInit As LongPtr) As Long +Private Declare PtrSafe Sub MAPIUninitialize Lib "mapi32.dll" () +Private Declare PtrSafe Function MAPILogonEx Lib "mapi32.dll" (ByVal hwnd As LongPtr, ByVal profile As LongPtr, ByVal password As LongPtr, ByVal flags As Long, ByRef session As LongPtr) As Long +Private Declare PtrSafe Function MAPIFreeBuffer Lib "mapi32.dll" (ByVal buffer As LongPtr) As Long +Private Declare PtrSafe Function MAPIAllocateBuffer Lib "mapi32.dll" (ByVal size As Long, ByRef buffer As LongPtr) As Long +Private Declare PtrSafe Function MAPIAllocateMore Lib "mapi32.dll" (ByVal size As Long, ByVal parent As LongPtr, ByRef buffer As LongPtr) As Long +Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal length As LongPtr) +Private Declare PtrSafe Function lstrlenW Lib "kernel32" (ByVal value As LongPtr) As Long +Private Declare PtrSafe Function lstrlenA Lib "kernel32" (ByVal value As LongPtr) As Long +Private Declare PtrSafe Function MultiByteToWideChar Lib "kernel32" (ByVal codePage As Long, ByVal flags As Long, ByVal source As LongPtr, ByVal sourceLength As Long, ByVal destination As LongPtr, ByVal capacity As Long) As Long +Private Declare PtrSafe Function WideCharToMultiByte Lib "kernel32" (ByVal codePage As Long, ByVal flags As Long, ByVal source As LongPtr, ByVal sourceLength As Long, ByVal destination As LongPtr, ByVal capacity As Long, ByVal defaultChar As LongPtr, ByVal usedDefault As LongPtr) As Long +Private Declare PtrSafe Function FileTimeToSystemTime Lib "kernel32" (ByVal fileTime As LongPtr, ByRef systemTime As SYSTEMTIME) As Long +Private Declare PtrSafe Function DispCallFunc Lib "oleaut32.dll" (ByVal instance As LongPtr, ByVal vtableOffset As LongPtr, ByVal convention As Long, ByVal returnType As Integer, ByVal argumentCount As Long, ByVal argumentTypes As LongPtr, ByVal argumentValues As LongPtr, ByRef result As Variant) As Long + +Private Type SYSTEMTIME + year As Integer + month As Integer + dayOfWeek As Integer + day As Integer + hour As Integer + minute As Integer + second As Integer + milliseconds As Integer +End Type + +#If Win64 Then + Private Const PTR_BYTES As Long = 8 + Private Const PROP_BYTES As Long = 24 + Private Const ROW_BYTES As Long = 16 + Private Const ROWSET_OFFSET As Long = 8 + Private Const RESTRICTION_BYTES As Long = 32 + Private Const RESTRICTION_UNION As Long = 8 + Private Const BINARY_POINTER_OFFSET As Long = 8 +#Else + Private Const PTR_BYTES As Long = 4 + Private Const PROP_BYTES As Long = 16 + Private Const ROW_BYTES As Long = 12 + Private Const ROWSET_OFFSET As Long = 4 + Private Const RESTRICTION_BYTES As Long = 16 + Private Const RESTRICTION_UNION As Long = 4 + Private Const BINARY_POINTER_OFFSET As Long = 4 +#End If + +Private Const MAPI_UNICODE As Long = &H80000000 +Private Const MAPI_EXTENDED As Long = &H20& +Private Const MAPI_USE_DEFAULT As Long = &H40& +Private Const MAPI_NEW_SESSION As Long = &H2& +Private Const MAPI_MODIFY As Long = 1 +Private Const MDB_WRITE As Long = 4 +Private Const MAPI_E_BAD_CHARWIDTH As Long = &H80040103 +Private Const MAPI_E_NOT_FOUND As Long = &H8004010F +Private Const MAPI_E_NO_SUPPORT As Long = &H80040102 +Private Const MAPI_E_TOO_BIG As Long = &H80040305 +Private Const AB_NO_DIALOG As Long = 1 +Private Const MDB_NO_DIALOG As Long = 1 +Private Const CONVENIENT_DEPTH As Long = 1 +Private Const AB_RECIPIENTS As Long = 1 +Private Const BATCH_SIZE As Long = 64 + +'Vtable slots are zero based, including IUnknown's three methods. +Private Const VT_RELEASE As Long = 2 +Private Const VT_GET_PROPS As Long = 5 +Private Const VT_SET_PROPS As Long = 8 +Private Const VT_NAMED_IDS As Long = 13 +Private Const VT_AB_ONE_OFF As Long = 18 +Private Const VT_FOLDER_CREATE_MESSAGE As Long = 19 +Private Const VT_MESSAGE_RECIPIENTS As Long = 19 +Private Const VT_MESSAGE_SUBMIT As Long = 20 +Private Const VT_SESSION_STORES As Long = 4 +Private Const VT_SESSION_OPEN_STORE As Long = 5 +Private Const VT_SESSION_ADDRESS_BOOK As Long = 6 +Private Const VT_SESSION_STATUS_TABLE As Long = 8 +Private Const VT_SESSION_OPEN_ENTRY As Long = 9 +Private Const VT_SESSION_COMPARE_IDS As Long = 10 +Private Const VT_STATUS_FLUSH As Long = 17 +Private Const VT_SESSION_IDENTITY As Long = 16 +Private Const VT_AB_OPEN_ENTRY As Long = 14 +Private Const VT_CONTAINER_CONTENTS As Long = 14 +Private Const VT_CONTAINER_HIERARCHY As Long = 15 +Private Const VT_STORE_OPEN_ENTRY As Long = 17 +Private Const VT_STORE_RECEIVE_FOLDER As Long = 19 +Private Const VT_TABLE_COLUMNS As Long = 7 +Private Const VT_TABLE_RESTRICT As Long = 14 +Private Const VT_TABLE_SORT As Long = 17 +Private Const VT_TABLE_ROWS As Long = 19 + +Private Type TThis + Session As LongPtr + AddressBook As LongPtr + Store As LongPtr + StoreWritable As Boolean + Initialized As Boolean + Warnings As Collection + SearchTruncated As Boolean + CalendarSearchTruncated As Boolean + LastSendSyncError As String + LastSendSyncRequested As Boolean + UseOutlookSendReceive As Boolean +End Type +Private This As TThis + +'Empty profile: share the current MAPI session, or use the default profile. +'Explicit profile: request a separate session so MAPI cannot ignore its name. +'Never enables logon UI. Credentials/profile setup remain Outlook's job. +'@constructor +'@param profileName - Profile name; empty shares the current session or uses the default. Explicit names request a separate MAPI session. No native logon UI. +'@returns - An initialized stdOutlook instance owning its MAPI handles. +'@example Set client = stdOutlook.Create() +Public Function Create(Optional ByVal profileName As String = "") As stdOutlook + Dim client As stdOutlook + Set client = New stdOutlook + client.protInit profileName + Set Create = client +End Function + +'Release the current native handles and open another profile without logging off Outlook. +'@param profileName - Profile name; empty shares the current session or uses the default. Explicit names request a separate MAPI session. No native logon UI. +Public Sub OpenProfile(Optional ByVal profileName As String = "") + protInit profileName +End Sub + +'Initialize an instance with a native MAPI profile; prefer Create or OpenProfile. +'@protected +'@param profileName - Profile name; empty shares the current session or uses the default. Explicit names request a separate MAPI session. No native logon UI. +Public Sub protInit(Optional ByVal profileName As String = "") + Dim flags As Long, number As Long, description As String + If InStr(profileName, vbNullChar) > 0 Or Len(profileName) > 64 Then + Err.Raise 5, "stdOutlook.OpenProfile", "Invalid profile name." + End If + Me.Disconnect + On Error GoTo Failed + CheckHR MAPIInitialize(0), "MAPIInitialize (requires classic Outlook and matching Office bitness)" + This.Initialized = True + 'A mail-capable session is required for SubmitMessage, including spooler-based + 'transports. Store handles remain read-only until a send explicitly upgrades. + flags = MAPI_EXTENDED Or MAPI_UNICODE + If Len(profileName) = 0 Then + flags = flags Or MAPI_USE_DEFAULT + Else + flags = flags Or MAPI_NEW_SESSION + End If + CheckHR MAPILogonEx(0, StrPtr(profileName), 0, flags, This.Session), "MAPILogonEx (open/sign in to this profile in classic Outlook first)" + RequirePointer This.Session, "MAPILogonEx" + Exit Sub +Failed: + number = Err.Number: description = Err.description + Me.Disconnect + Err.Raise number, "stdOutlook.OpenProfile", description +End Sub + +'Whether this instance owns an open MAPI session. +'@returns - True if a native session is open. +Public Property Get IsOpen() As Boolean + IsOpen = (This.Session <> 0) +End Property + +'Release owned native handles and balance MAPI initialization; safe to call repeatedly. Does not quit Outlook. +Public Sub Disconnect() + 'Release child objects before their session. Do not Logoff a shared session: + 'that can interfere with Outlook or another stdOutlook instance. + On Error Resume Next + ReleaseObject This.Store + This.StoreWritable = False + ReleaseObject This.AddressBook + ReleaseObject This.Session + If This.Initialized Then + This.Initialized = False + MAPIUninitialize + End If + On Error GoTo 0 +End Sub + +'Initialize diagnostics and the default synchronization policy. +Private Sub Class_Initialize() + Set This.Warnings = New Collection + This.UseOutlookSendReceive = True +End Sub + +'Release this instance without logging off a shared MAPI session. +Private Sub Class_Terminate() + Me.Disconnect +End Sub + +'Primary profile identity, not every account's sending address. +'Providers without an identity (for example some PST/IMAP profiles) can fail. +'@returns Collection - Keyed identity properties including Email, DisplayName, EntryID and PropertyErrors; not all account identities. +Public Function CurrentUser() As Collection + Dim cb As Long, entry As LongPtr, person As LongPtr, kind As Long + Dim number As Long, description As String + EnsureAddressBook + On Error GoTo Failed + CheckHR CallVTable(This.Session, VT_SESSION_IDENTITY, VarPtr(cb), VarPtr(entry)), "IMAPISession.QueryIdentity" + If cb <= 0 Then Err.Raise MAPI_E_NOT_FOUND, "stdOutlook", "The profile has no primary identity." + RequirePointer entry, "QueryIdentity entry ID" + CheckHR CallVTable(This.AddressBook, VT_AB_OPEN_ENTRY, cb, entry, CLngPtr(0), 0&, VarPtr(kind), VarPtr(person)), "IAddrBook.OpenEntry(identity)" + Set CurrentUser = ReadPerson(person) +Done: + On Error GoTo 0 + ReleaseObject person + FreeBuffer entry + If number <> 0 Then Err.Raise number, "stdOutlook.CurrentUser", description + Exit Function +Failed: + number = Err.Number: description = Err.description + Resume Done +End Function + +'Resolve the profile identity SMTP address; raise if none is supplied by the provider. +'@returns - The resolved primary SMTP address, never an Exchange legacy DN. +Public Property Get CurrentUserEmail() As String + Dim person As Collection + Set person = CurrentUser() + CurrentUserEmail = person("Email") + If Len(CurrentUserEmail) = 0 Then + Err.Raise MAPI_E_NOT_FOUND, "stdOutlook.CurrentUserEmail", "The identity provider did not supply an SMTP address. Inspect CurrentUser and its PropertyErrors." + End If +End Property + +'Return all address-book containers, including nested Outlook Contacts books. +'Only folders enabled as an Outlook Address Book are visible through this API. +'@returns Collection - One keyed Collection per container: EntryID, DisplayName, Flags, Depth and PropertyErrors. +Public Function AddressBooks() As Collection + Dim root As LongPtr, table As LongPtr, kind As Long, capped As Boolean + Dim number As Long, description As String + EnsureAddressBook + On Error GoTo Failed + CheckHR CallVTable(This.AddressBook, VT_AB_OPEN_ENTRY, 0&, CLngPtr(0), CLngPtr(0), 0&, VarPtr(kind), VarPtr(root)), "IAddrBook.OpenEntry(root)" + CheckHR CallVTable(root, VT_CONTAINER_HIERARCHY, CONVENIENT_DEPTH, VarPtr(table)), "IABContainer.GetHierarchyTable" + Set AddressBooks = ReadTable(table, BookColumns(), 10000, capped) + If capped Then Err.Raise MAPI_E_TOO_BIG, "stdOutlook", "Address-book hierarchy exceeded 10000 containers." +Done: + On Error GoTo 0 + ReleaseObject table + ReleaseObject root + If number <> 0 Then Err.Raise number, "stdOutlook.AddressBooks", description + Exit Function +Failed: + number = Err.Number: description = Err.description + Resume Done +End Function + +'Provider-side ambiguous-name resolution (ANR), usually name/alias prefixes. +'Not arbitrary substring matching: email matching depends on the provider. +'containerEntryID optionally limits the search to one AddressBooks() entry. +'Warnings and SearchTruncated describe partial results; always inspect them. +'@param query - Search text; matching rules are described by this method. +'@param maxResults - Maximum returned records, from 1 to 10000. +'@param containerEntryID - Hexadecimal AddressBooks entry ID; empty searches all recipient containers. +'@returns Collection - Copied keyed contact records with Email, EntryID, AddressBook and PropertyErrors; inspect SearchWarnings and SearchTruncated. +Public Function SearchContacts(ByVal query As String, Optional ByVal maxResults As Long = 100, Optional ByVal containerEntryID As String = "") As Collection + Dim books As Collection, book As Collection, results As New Collection + Dim seen As New Collection, matches As Collection, person As Collection + Dim entry As Variant, capped As Boolean + Set This.Warnings = New Collection + This.SearchTruncated = False + query = Trim$(query) + If Len(query) = 0 Or InStr(query, vbNullChar) > 0 Then Err.Raise 5, "stdOutlook.SearchContacts", "Supply a nonempty name, alias, or email search." + ValidateLimit maxResults + EnsureAddressBook + If Len(containerEntryID) > 0 Then + Set books = New Collection + Set book = New Collection + book.Add containerEntryID, "EntryID" + book.Add "Selected address book", "DisplayName" + book.Add AB_RECIPIENTS, "Flags" + books.Add book + Else + Set books = AddressBooks() + End If + For Each book In books + If (CLng(Val(CStr(book("Flags")))) And AB_RECIPIENTS) <> 0 Then + Set matches = SearchBook(CStr(book("EntryID")), query, maxResults + 1, capped) + If capped Then This.SearchTruncated = True + For Each person In matches + entry = person("EntryID") + If Not HasKey(seen, CStr(entry)) Then + If results.Count = maxResults Then + This.SearchTruncated = True + Exit For + End If + seen.Add True, CStr(entry) + person.Add book("DisplayName"), "AddressBook" + results.Add person + End If + Next + If results.Count = maxResults Then + 'Conservative: remaining containers could contain additional matches. + This.SearchTruncated = True + Exit For + End If + End If + Next + Set SearchContacts = results +End Function + +'Whether the latest contact search may have omitted matching records. +'@returns - True if results may be incomplete; conservative when the result limit is reached. +Public Property Get SearchTruncated() As Boolean + SearchTruncated = This.SearchTruncated +End Property + +'Return an independent copy of warnings from the latest contact search. +'@returns Collection - Warning strings; mutating this copy cannot change diagnostic state. +Public Property Get SearchWarnings() As Collection + 'Return a copy so callers cannot mutate the diagnostic state. + Dim result As New Collection, warning As Variant + For Each warning In This.Warnings + result.Add warning + Next + Set SearchWarnings = result +End Property + +'Read copied properties of an address-book entry without guarded Outlook automation. +'@param entryID - Nonempty, even-length hexadecimal MAPI entry ID in the current profile. +'@returns Collection - Copied person fields including Email and PropertyErrors. Missing values are Empty. +Public Function ReadContact(ByVal entryID As String) As Collection + Dim bytes() As Byte, person As LongPtr, kind As Long + Dim number As Long, description As String + EnsureAddressBook + bytes = DecodeEntryID(entryID) + On Error GoTo Failed + CheckHR CallVTable(This.AddressBook, VT_AB_OPEN_ENTRY, CLng(UBound(bytes) + 1), VarPtr(bytes(0)), CLngPtr(0), 0&, VarPtr(kind), VarPtr(person)), "IAddrBook.OpenEntry(contact)" + Set ReadContact = ReadPerson(person) +Done: + On Error GoTo 0 + ReleaseObject person + If number <> 0 Then Err.Raise number, "stdOutlook.ReadContact", description + Exit Function +Failed: + number = Err.Number: description = Err.description + Resume Done +End Function + +'Optional mail access: newest messages in the default store's Inbox. +'Does not mark messages read. Times are UTC. No bodies in the table result. +'@param maxResults - Maximum returned records, from 1 to 10000. +'@returns Collection - Newest message metadata records, without bodies; times are UTC and entries are not marked read. +Public Function Inbox(Optional ByVal maxResults As Long = 50) As Collection + Dim folder As LongPtr, table As LongPtr, entry As LongPtr, cb As Long, kind As Long + Dim messageClass As String, sort(0 To 4) As Long, capped As Boolean + Dim number As Long, description As String + ValidateLimit maxResults + EnsureStore + On Error GoTo Failed + messageClass = "IPM.Note" + CheckHR CallVTable(This.Store, VT_STORE_RECEIVE_FOLDER, StrPtr(messageClass), MAPI_UNICODE, VarPtr(cb), VarPtr(entry), CLngPtr(0)), "IMsgStore.GetReceiveFolder" + If cb <= 0 Then Err.Raise MAPI_E_NOT_FOUND, "stdOutlook", "No Inbox entry ID was returned." + RequirePointer entry, "Inbox entry ID" + CheckHR CallVTable(This.Store, VT_STORE_OPEN_ENTRY, cb, entry, CLngPtr(0), 0&, VarPtr(kind), VarPtr(folder)), "IMsgStore.OpenEntry(Inbox)" + CheckHR CallVTable(folder, VT_CONTAINER_CONTENTS, 0&, VarPtr(table)), "IMAPIFolder.GetContentsTable" + sort(0) = 1: sort(3) = &HE060040: sort(4) = 1 'PR_MESSAGE_DELIVERY_TIME descending + CheckHR CallVTable(table, VT_TABLE_SORT, VarPtr(sort(0)), 0&), "IMAPITable.SortTable" + Set Inbox = ReadTable(table, MessageColumns(False), maxResults, capped) +Done: + On Error GoTo 0 + ReleaseObject table + ReleaseObject folder + FreeBuffer entry + If number <> 0 Then Err.Raise number, "stdOutlook.Inbox", description + Exit Function +Failed: + number = Err.Number: description = Err.description + Resume Done +End Function + +'Entry ID must belong to the default store (e.g. from Inbox). +'Large/unavailable bodies remain Empty with the HRESULT in PropertyErrors. +'@param entryID - Nonempty, even-length hexadecimal MAPI entry ID in the current profile. +'@returns Collection - Message metadata and plain-text Body. Missing or oversized values are Empty with HRESULTs in PropertyErrors. +Public Function ReadMessage(ByVal entryID As String) As Collection + Dim bytes() As Byte, message As LongPtr, kind As Long + Dim number As Long, description As String + EnsureStore + bytes = DecodeEntryID(entryID) + On Error GoTo Failed + CheckHR CallVTable(This.Store, VT_STORE_OPEN_ENTRY, CLng(UBound(bytes) + 1), VarPtr(bytes(0)), CLngPtr(0), 0&, VarPtr(kind), VarPtr(message)), "IMsgStore.OpenEntry(message)" + If kind <> 5 Then Err.Raise 5, "stdOutlook", "The entry is not a MAPI message." + Set ReadMessage = GetProperties(message, MessageColumns(True)) +Done: + On Error GoTo 0 + ReleaseObject message + If number <> 0 Then Err.Raise number, "stdOutlook.ReadMessage", description + Exit Function +Failed: + number = Err.Number: description = Err.description + Resume Done +End Function + +'Submit a plain-text message. Lists contain semicolon-separated bare SMTP +'addresses (not display names/aliases). Success means queued, not delivered. +'@param toAddresses - Semicolon-separated bare SMTP addresses. At least one To, CC, or BCC recipient is required. +'@param subject - Subject text; empty is allowed, embedded null characters are rejected. +'@param body - Plain-text Unicode body; empty is allowed, embedded null characters are rejected. +'@param ccAddresses - Optional semicolon-separated bare SMTP CC addresses. +'@param bccAddresses - Optional semicolon-separated bare SMTP BCC addresses. +'@param flushQueue - True requests synchronization after successful submission; False queues only. Defaults to True. +'@remark Success means submitted. Inspect LastSendSyncError; never resend a queued message after a sync error. +Public Sub SendEmail(ByVal toAddresses As String, ByVal subject As String, ByVal body As String, Optional ByVal ccAddresses As String = "", Optional ByVal bccAddresses As String = "", Optional ByVal flushQueue As Boolean = True) + SendCore toAddresses, subject, body, ccAddresses, bccAddresses, False, flushQueue +End Sub + +'Submit an HTML message. HTML is written as UTF-8 PR_HTML, with CPID 65001. +'No attachments, account override, or plain-text alternative is synthesized. +'@param toAddresses - Semicolon-separated bare SMTP addresses. At least one To, CC, or BCC recipient is required. +'@param subject - Subject text; empty is allowed, embedded null characters are rejected. +'@param htmlBody - HTML fragment or document stored as UTF-8 PR_HTML; no plain-text alternative is synthesized. +'@param ccAddresses - Optional semicolon-separated bare SMTP CC addresses. +'@param bccAddresses - Optional semicolon-separated bare SMTP BCC addresses. +'@param flushQueue - True requests synchronization after successful submission; False queues only. Defaults to True. +'@remark Success means submitted. Inspect LastSendSyncError; never resend a queued message after a sync error. +Public Sub SendEmailHTML(ByVal toAddresses As String, ByVal subject As String, ByVal htmlBody As String, Optional ByVal ccAddresses As String = "", Optional ByVal bccAddresses As String = "", Optional ByVal flushQueue As Boolean = True) + SendCore toAddresses, subject, htmlBody, ccAddresses, bccAddresses, True, flushQueue +End Sub + +'These describe only the latest SendEmail/SendEmailHTML call. A successful +'flush request is not a delivery receipt. False + empty error means skipped. +'@returns - True if the latest send synchronization request was accepted; not confirmation of delivery. +Public Property Get LastSendSyncRequested() As Boolean + LastSendSyncRequested = This.LastSendSyncRequested +End Property + +'Immediate synchronization error from the latest send, or an empty string; never a delivery receipt. +'@returns - Error description after a successful submission but failed synchronization; empty if skipped or no immediate error. +Public Property Get LastSendSyncError() As String + LastSendSyncError = This.LastSendSyncError +End Property + +'True by default: use Outlook's Send/Receive All after submission. False keeps +'the older native FlushQueues path, which some cached transports do not drain. +'The per-send flushQueue:=False option skips either synchronization path. +'@returns - True for Outlook automation, False for native queue flushing. +Public Property Get UseOutlookSendReceive() As Boolean + UseOutlookSendReceive = This.UseOutlookSendReceive +End Property + +'Select the automatic synchronization mechanism; True uses Outlook Send/Receive and is the default. +'@param value - True selects Outlook Send/Receive; False selects native FlushQueues. Defaults to True. +Public Property Let UseOutlookSendReceive(ByVal value As Boolean) + This.UseOutlookSendReceive = value +End Property + +'The documented equivalent of Outlook's Send/Receive All button. This is the +'only production path using Outlook automation; no guarded data or Send calls. +'Starts classic Outlook if needed, and leaves a window open so asynchronous +'transfer can continue after this class is released. Never calls Outlook.Quit. +'All accounts in that Outlook profile participate. Return is NOT delivery. +'@param showProgress - Whether to show Outlook Send/Receive progress; defaults to False. +Public Sub SendAndReceive(Optional ByVal showProgress As Boolean = False) + Dim outlookApp As Object, session As Object, inbox As Object, explorer As Object + EnsureSession + EnsureStore + Set outlookApp = RunningOutlook() + If outlookApp Is Nothing Then Set outlookApp = CreateObject("Outlook.Application") + Set session = outlookApp.GetNamespace("MAPI") + 'Initialize a default-profile session without Logon/profile-selection prompts. + Set inbox = session.GetDefaultFolder(6) 'olFolderInbox + CheckSyncStore session + If outlookApp.Explorers.Count = 0 Then + Set explorer = inbox.GetExplorer + explorer.Display + End If + session.SendAndReceive showProgress +End Sub + +'Return an existing Outlook automation instance, or Nothing when unavailable. +Private Function RunningOutlook() As Object + On Error Resume Next + Set RunningOutlook = GetObject(, "Outlook.Application") + On Error GoTo 0 +End Function + +'Compare native and Outlook default-store entry IDs; refuse mismatched or unverifiable stores. +Private Sub CheckSyncStore(ByVal session As Object) + Dim props As Collection, nativeID() As Byte, outlookID() As Byte, same As Long + Set props = GetProperties(This.Store, Array(Array("EntryID", &HFFF0102))) + nativeID = DecodeEntryID(CStr(props("EntryID"))) + outlookID = DecodeEntryID(CStr(session.DefaultStore.StoreID)) + CheckHR CallVTable(This.Session, VT_SESSION_COMPARE_IDS, CLng(UBound(nativeID) + 1), VarPtr(nativeID(0)), CLng(UBound(outlookID) + 1), VarPtr(outlookID(0)), 0&, VarPtr(same)), "IMAPISession.CompareEntryIDs(sync store)" + If same = 0 Then Err.Raise 5, "stdOutlook.SendAndReceive", "Outlook is using a different default message store. Open Outlook with the same profile as this stdOutlook instance, then call SendAndReceive again; do not resubmit the message." +End Sub + +'Request immediate transfer of pending mail in this profile, including mail +'queued by other callers. Not equivalent to synchronizing every Outlook folder. +'Returns the number of status objects that accepted the request; raises on +'unsupported providers or failure (possibly after some queues were flushed). +'Spooler requests may be asynchronous; direct transport calls can block. +'@param includeReceive - True flushes incoming and outgoing queues; False requests outgoing only. Defaults to False. +'@returns - Number of status objects accepting the request, not messages delivered; raises on unsupported providers or failure. +Public Function FlushQueues(Optional ByVal includeReceive As Boolean = False) As Long + Dim table As LongPtr, rows As Collection, row As Collection, spooler As Collection + Dim capped As Boolean, number As Long, description As String + EnsureSession + EnsureStore 'Keep the default store open while asking transports to send. + On Error GoTo Failed + CheckHR CallVTable(This.Session, VT_SESSION_STATUS_TABLE, 0&, VarPtr(table)), "IMAPISession.GetStatusTable" + RequirePointer table, "GetStatusTable" + Set rows = ReadTable(table, Array(Array("EntryID", &HFFF0102), Array("ResourceType", &H3E030003), Array("Methods", &H3E020003)), 1000, capped) + ReleaseObject table + If capped Then Err.Raise MAPI_E_TOO_BIG, "stdOutlook.FlushQueues", "Status table exceeds 1000 rows; no queues were flushed." + 'Prefer the spooler, which coordinates all transports. Do not flush both the + 'spooler and its individual transports for the same request. + For Each row In rows + If CLng(row("ResourceType")) = 37 And (CLng(row("Methods")) And 8) <> 0 Then + Set spooler = row + Exit For + End If + Next + If Not spooler Is Nothing Then + FlushStatus spooler, includeReceive + FlushQueues = 1 + Else + For Each row In rows + If CLng(row("ResourceType")) = 36 And (CLng(row("Methods")) And 8) <> 0 Then + FlushStatus row, includeReceive + FlushQueues = FlushQueues + 1 + End If + Next + End If + If FlushQueues = 0 Then Err.Raise MAPI_E_NO_SUPPORT, "stdOutlook.FlushQueues", "This profile exposes no transport supporting native FlushQueues; use Outlook Send/Receive." +Done: + On Error GoTo 0 + ReleaseObject table + If number <> 0 Then Err.Raise number, "stdOutlook.FlushQueues", description + Exit Function +Failed: + number = Err.Number: description = Err.description + Resume Done +End Function + +'Open and release one supported status object while requesting queue transfer. +Private Sub FlushStatus(ByVal row As Collection, ByVal includeReceive As Boolean) + Dim bytes() As Byte, status As LongPtr, kind As Long, flags As Long + Dim number As Long, description As String + On Error GoTo Failed + bytes = DecodeEntryID(CStr(row("EntryID"))) + CheckHR CallVTable(This.Session, VT_SESSION_OPEN_ENTRY, CLng(UBound(bytes) + 1), VarPtr(bytes(0)), CLngPtr(0), 0&, VarPtr(kind), VarPtr(status)), "IMAPISession.OpenEntry(status)" + RequirePointer status, "OpenEntry(status)" + If kind <> 10 Then Err.Raise 5, "stdOutlook.FlushQueues", "The transport entry is not a MAPI status object." + flags = &H2 Or &H8 Or &H10 'FLUSH_UPLOAD | FLUSH_FORCE | FLUSH_NO_UI + If includeReceive Then flags = flags Or &H4 + If CLng(row("ResourceType")) = 37 Then flags = flags Or &H20 'FLUSH_ASYNC_OK: spooler only + CheckHR CallVTable(status, VT_STATUS_FLUSH, CLngPtr(0), 0&, CLngPtr(0), flags), "IMAPIStatus.FlushQueues (message already queued; do not resend)" +Done: + On Error GoTo 0 + ReleaseObject status + If number <> 0 Then Err.Raise number, "stdOutlook.FlushQueues", description + Exit Sub +Failed: + number = Err.Number: description = Err.description + Resume Done +End Sub + +'Record synchronization failure separately after successful submission; never resubmit. +Private Sub RequestSendSync() + On Error GoTo Failed + If This.UseOutlookSendReceive Then + Me.SendAndReceive False + Else + Me.FlushQueues False + End If + This.LastSendSyncRequested = True + Exit Sub +Failed: + This.LastSendSyncError = Err.description +End Sub + +'Validate recipients, create and submit one message, release native buffers, then request synchronization. +Private Sub SendCore(ByVal toAddresses As String, ByVal subject As String, ByVal body As String, ByVal ccAddresses As String, ByVal bccAddresses As String, ByVal isHtml As Boolean, ByVal flushQueue As Boolean) + Dim recipients As New Collection, folders As Collection, outbox As LongPtr, message As LongPtr + Dim bytes() As Byte, sentID As String, kind As Long, list As LongPtr + Dim number As Long, description As String + This.LastSendSyncError = "": This.LastSendSyncRequested = False + 'Validate everything before opening a writable store or creating a message. + AddRecipients recipients, toAddresses, 1 + AddRecipients recipients, ccAddresses, 2 + AddRecipients recipients, bccAddresses, 3 + If recipients.Count = 0 Then Err.Raise 5, "stdOutlook.SendEmail", "At least one SMTP recipient is required." + If InStr(subject, vbNullChar) > 0 Or InStr(body, vbNullChar) > 0 Then Err.Raise 5, "stdOutlook.SendEmail", "Subject and body cannot contain null characters." + EnsureAddressBook + EnsureStore True + On Error GoTo Failed + Set folders = GetProperties(This.Store, Array(Array("Outbox", &H35E20102), Array("Sent", &H35E40102))) + bytes = DecodeEntryID(CStr(folders("Outbox"))) + sentID = CStr(folders("Sent")) + If Len(sentID) = 0 Then Err.Raise MAPI_E_NOT_FOUND, "stdOutlook", "The default store has no Sent Items folder." + list = BuildRecipientList(recipients) + CheckHR CallVTable(This.Store, VT_STORE_OPEN_ENTRY, CLng(UBound(bytes) + 1), VarPtr(bytes(0)), CLngPtr(0), MAPI_MODIFY, VarPtr(kind), VarPtr(outbox)), "IMsgStore.OpenEntry(Outbox, write)" + If kind <> 3 Then Err.Raise 5, "stdOutlook", "The Outbox entry is not a folder." + CheckHR CallVTable(outbox, VT_FOLDER_CREATE_MESSAGE, CLngPtr(0), 0&, VarPtr(message)), "IMAPIFolder.CreateMessage" + SetOutgoingProperties message, subject, body, sentID, isHtml + CheckHR CallVTable(message, VT_MESSAGE_RECIPIENTS, 2&, list), "IMessage.ModifyRecipients(MODRECIP_ADD)" + 'SubmitMessage saves the message. Never retry automatically: a transport failure + 'can have an uncertain outcome. After success only Release is allowed. + CheckHR CallVTable(message, VT_MESSAGE_SUBMIT, 0&), "IMessage.SubmitMessage (not retried; inspect Outbox before retrying)" +Done: + On Error Resume Next + ReleaseObject message + ReleaseObject outbox + FreeRows list 'ADRLIST and SRowSet have identical ownership/layout here. + On Error GoTo 0 + If number <> 0 Then Err.Raise number, "stdOutlook.SendEmail", description + 'Submission has succeeded. A subsequent synchronization failure must never + 'look like a failed send: callers might otherwise create a duplicate message. + If flushQueue Then RequestSendSync + Exit Sub +Failed: + number = Err.Number: description = Err.description + Resume Done +End Sub + +'Append validated SMTP recipients with their MAPI To/CC/BCC type; enforce the shared limit. +Private Sub AddRecipients(ByVal recipients As Collection, ByVal addresses As String, ByVal recipientType As Long) + Dim parts As Variant, part As Variant, address As String, at As Long, i As Long, character As String + If Len(Trim$(addresses)) = 0 Then Exit Sub + parts = Split(addresses, ";") + For Each part In parts + address = Trim$(CStr(part)) + at = InStr(address, "@") + If at <= 1 Or at = Len(address) Or InStr(at + 1, address, "@") > 0 Then GoTo Invalid + For i = 1 To Len(address) + character = Mid$(address, i, 1) + If AscW(character) >= 0 And AscW(character) <= 32 Then GoTo Invalid + If AscW(character) = 127 Then GoTo Invalid + If InStr(",<>""()", character) > 0 Then GoTo Invalid + Next + If recipients.Count >= 1000 Then Err.Raise 5, "stdOutlook.SendEmail", "At most 1000 recipients are supported." + recipients.Add Array(address, recipientType) + Next + Exit Sub +Invalid: + Err.Raise 5, "stdOutlook.SendEmail", "Use semicolon-separated bare SMTP addresses with no empty entries, display names, or control characters." +End Sub + +'Allocate an owned ADRLIST with one-off recipient IDs; caller frees it with FreeRows. +Private Function BuildRecipientList(ByVal recipients As Collection) As LongPtr + Dim list As LongPtr, props As LongPtr, row As LongPtr, oneOff As LongPtr, cb As Long + Dim entry As Variant, address As String, addressType As String, i As Long + Dim number As Long, description As String, zeros() As Byte + Dim propZeros(0 To PROP_BYTES * 5 - 1) As Byte + On Error GoTo Failed + ReDim zeros(0 To ROWSET_OFFSET + recipients.Count * ROW_BYTES - 1) + CheckHR MAPIAllocateBuffer(UBound(zeros) + 1, list), "MAPIAllocateBuffer(ADRLIST)" + CopyMemory ByVal list, zeros(0), UBound(zeros) + 1 + WriteLong list, recipients.Count + addressType = "SMTP" + For Each entry In recipients + address = CStr(entry(0)) + row = PtrAdd(list, ROWSET_OFFSET + i * ROW_BYTES) + CheckHR MAPIAllocateBuffer(5 * PROP_BYTES, props), "MAPIAllocateBuffer(recipient properties)" + WritePointer PtrAdd(row, 8), props 'Transfer ownership before any fallible work. + WriteLong PtrAdd(row, 4), 5 + CopyMemory ByVal props, propZeros(0), PROP_BYTES * 5 + WriteLong props, &HC150003 'PR_RECIPIENT_TYPE: To=1, CC=2, BCC=3 + WriteLong PtrAdd(props, 8), CLng(entry(1)) + AllocatedStringProperty PtrAdd(props, PROP_BYTES), &H3001001F, address, props + AllocatedStringProperty PtrAdd(props, PROP_BYTES * 2), &H3002001F, addressType, props + AllocatedStringProperty PtrAdd(props, PROP_BYTES * 3), &H3003001F, address, props + CheckHR CallVTable(This.AddressBook, VT_AB_ONE_OFF, StrPtr(address), StrPtr(addressType), StrPtr(address), MAPI_UNICODE Or &H10000, VarPtr(cb), VarPtr(oneOff)), "IAddrBook.CreateOneOff(SMTP)" + RequirePointer oneOff, "CreateOneOff" + If cb <= 0 Then Err.Raise 5, "stdOutlook", "Empty one-off entry ID." + Dim copy As LongPtr, binaryProp As LongPtr + CheckHR MAPIAllocateMore(cb, props, copy), "MAPIAllocateMore(entry ID)" + CopyMemory ByVal copy, ByVal oneOff, cb + binaryProp = PtrAdd(props, PROP_BYTES * 4) + WriteLong binaryProp, &HFFF0102 + WriteLong PtrAdd(binaryProp, 8), cb + WritePointer PtrAdd(binaryProp, 8 + BINARY_POINTER_OFFSET), copy + FreeBuffer oneOff + i = i + 1 + Next + BuildRecipientList = list + list = 0 +Done: + On Error GoTo 0 + FreeBuffer oneOff + FreeRows list + If number <> 0 Then Err.Raise number, "stdOutlook.BuildRecipientList", description + Exit Function +Failed: + number = Err.Number: description = Err.description + Resume Done +End Function + +'Allocate a null-terminated Unicode string under a MAPI parent and populate its property value. +Private Sub AllocatedStringProperty(ByVal prop As LongPtr, ByVal tag As Long, ByVal value As String, ByVal parent As LongPtr) + Dim text As LongPtr, cb As Long, terminator As Integer + cb = LenB(value) + CheckHR MAPIAllocateMore(cb + 2, parent, text), "MAPIAllocateMore(text)" + If cb > 0 Then CopyMemory ByVal text, ByVal StrPtr(value), cb + CopyMemory ByVal PtrAdd(text, cb), terminator, 2 + WriteLong prop, tag + WritePointer PtrAdd(prop, 8), text +End Sub + +'Populate message, body, recipient-independent delivery properties and reject per-property errors. +Private Sub SetOutgoingProperties(ByVal message As LongPtr, ByVal subject As String, ByVal body As String, ByVal sentID As String, ByVal isHtml As Boolean) + Dim props(0 To PROP_BYTES * 6 - 1) As Byte, p As LongPtr, messageClass As String + Dim sentBytes() As Byte, html() As Byte, htmlSize As Long, problems As LongPtr + Dim number As Long, description As String + On Error GoTo Failed + messageClass = "IPM.Note" + subject = subject & vbNullChar + If Not isHtml Then body = body & vbNullChar + sentBytes = DecodeEntryID(sentID) + p = VarPtr(props(0)) + WriteLong p, &H1A001F: WritePointer PtrAdd(p, 8), StrPtr(messageClass) + p = PtrAdd(p, PROP_BYTES) + WriteLong p, &H37001F: WritePointer PtrAdd(p, 8), StrPtr(subject) + p = PtrAdd(p, PROP_BYTES) + If isHtml Then + htmlSize = 0 + If Len(body) > 0 Then + htmlSize = WideCharToMultiByte(65001, &H80&, StrPtr(body), Len(body), 0, 0, 0, 0) + If htmlSize = 0 Then Err.Raise 5, "stdOutlook", "HTML contains invalid Unicode." + End If + ReDim html(0 To htmlSize) + If htmlSize > 0 Then + If WideCharToMultiByte(65001, &H80&, StrPtr(body), Len(body), VarPtr(html(0)), htmlSize, 0, 0) <> htmlSize Then Err.Raise 5, "stdOutlook", "Cannot encode HTML as UTF-8." + End If + WriteLong p, &H10130102: WriteLong PtrAdd(p, 8), htmlSize + WritePointer PtrAdd(p, 8 + BINARY_POINTER_OFFSET), VarPtr(html(0)) + Else + WriteLong p, &H1000001F: WritePointer PtrAdd(p, 8), StrPtr(body) + End If + p = PtrAdd(p, PROP_BYTES) + WriteLong p, &HE0A0102: WriteLong PtrAdd(p, 8), UBound(sentBytes) + 1 + WritePointer PtrAdd(p, 8 + BINARY_POINTER_OFFSET), VarPtr(sentBytes(0)) + p = PtrAdd(p, PROP_BYTES) + WriteLong p, &HE070003: WriteLong PtrAdd(p, 8), 8 'MSGFLAG_UNSENT + p = PtrAdd(p, PROP_BYTES) + WriteLong p, &H3FDE0003: WriteLong PtrAdd(p, 8), 65001 'PR_INTERNET_CPID + CheckHR CallVTable(message, VT_SET_PROPS, 6&, VarPtr(props(0)), VarPtr(problems)), "IMAPIProp.SetProps(outgoing message)" + If problems <> 0 Then + If ReadLong(problems) > 0 Then + 'SPropProblemArray: count, then {index, tag, HRESULT} (all ULONGs). + number = ReadLong(PtrAdd(problems, 12)) + If number >= 0 Then number = &H80004005 + description = "An outgoing message property was rejected (index " & ReadLong(PtrAdd(problems, 4)) & "). Message was not submitted." + End If + End If +Done: + On Error GoTo 0 + FreeBuffer problems + If number <> 0 Then Err.Raise number, "stdOutlook.SetOutgoingProperties", description + Exit Sub +Failed: + number = Err.Number: description = Err.description + Resume Done +End Sub + +'Search stored calendar items by case-insensitive subject/location/organizer +'substring. Empty query lists items. Recurring masters are NOT expanded. +'@param query - Search text; matching rules are described by this method. +'@param maxResults - Maximum returned records, from 1 to 10000. +'@returns Collection - Stored appointment records with Subject, Location, OrganizerName, StartUtc, EndUtc, IsRecurring, RecurrenceExpanded and PropertyErrors. Recurrences are not expanded. +'@remark Empty query lists appointments; nonempty text matches Subject, Location or OrganizerName. Stored masters only. +Public Function SearchCalendar(Optional ByVal query As String = "", Optional ByVal maxResults As Long = 100) As Collection + Dim folder As LongPtr, table As LongPtr, columns As Variant, sort(0 To 4) As Long + Dim results As Collection, record As Collection, errors As Collection, field As Variant + Dim number As Long, description As String + This.CalendarSearchTruncated = False + ValidateLimit maxResults + If InStr(query, vbNullChar) > 0 Then Err.Raise 5, "stdOutlook.SearchCalendar", "Query cannot contain null characters." + EnsureStore + On Error GoTo Failed + folder = OpenCalendarFolder() + columns = CalendarColumns(folder) + CheckHR CallVTable(folder, VT_CONTAINER_CONTENTS, 0&, VarPtr(table)), "IMAPIFolder.GetContentsTable(calendar)" + If Len(query) > 0 Then RestrictCalendar table, query, columns + For Each field In columns + If field(0) = "StartUtc" Then + sort(0) = 1: sort(3) = CLng(field(1)): sort(4) = 1 + CheckHR CallVTable(table, VT_TABLE_SORT, VarPtr(sort(0)), 0&), "IMAPITable.SortTable(calendar)" + Exit For + End If + Next + Set results = ReadTable(table, columns, maxResults, This.CalendarSearchTruncated) + For Each record In results + Set errors = record("PropertyErrors") + For Each field In Array("Location", "StartUtc", "EndUtc", "IsRecurring") + If Not HasKey(record, CStr(field)) Then + record.Add Empty, CStr(field) + errors.Add MAPI_E_NOT_FOUND, CStr(field) + End If + Next + record.Add False, "RecurrenceExpanded" + Next + Set SearchCalendar = results +Done: + On Error GoTo 0 + ReleaseObject table + ReleaseObject folder + If number <> 0 Then Err.Raise number, "stdOutlook.SearchCalendar", description + Exit Function +Failed: + number = Err.Number: description = Err.description + Resume Done +End Function + +'Whether the latest calendar search found additional records beyond its result limit. +'@returns - True when more records exist than the requested maximum. +Public Property Get CalendarSearchTruncated() As Boolean + CalendarSearchTruncated = This.CalendarSearchTruncated +End Property + +'Resolve the default Calendar through Inbox then root properties; return an owned folder interface. +Private Function OpenCalendarFolder() As LongPtr + Dim source As LongPtr, entry As LongPtr, cb As Long, kind As Long, record As Collection + Dim messageClass As String, calendarID As String, bytes() As Byte, folder As LongPtr + Dim number As Long, description As String + On Error GoTo InboxFailed + messageClass = "IPM.Note" + CheckHR CallVTable(This.Store, VT_STORE_RECEIVE_FOLDER, StrPtr(messageClass), MAPI_UNICODE, VarPtr(cb), VarPtr(entry), CLngPtr(0)), "GetReceiveFolder(calendar lookup)" + If cb <= 0 Then Err.Raise MAPI_E_NOT_FOUND + RequirePointer entry, "Inbox entry ID" + CheckHR CallVTable(This.Store, VT_STORE_OPEN_ENTRY, cb, entry, CLngPtr(0), 0&, VarPtr(kind), VarPtr(source)), "OpenEntry(Inbox for calendar)" + Set record = GetProperties(source, Array(Array("Calendar", &H36D00102))) + calendarID = CStr(record("Calendar")) + If Len(calendarID) > 0 Then GoTo OpenCalendar +TryRoot: + 'The Calendar entry ID lives on Inbox or the store's root, not IMsgStore. + On Error GoTo Failed + FreeBuffer entry + ReleaseObject source + CheckHR CallVTable(This.Store, VT_STORE_OPEN_ENTRY, 0&, CLngPtr(0), CLngPtr(0), 0&, VarPtr(kind), VarPtr(source)), "OpenEntry(root for calendar)" + Set record = GetProperties(source, Array(Array("Calendar", &H36D00102))) + calendarID = CStr(record("Calendar")) +OpenCalendar: + On Error GoTo Failed + If Len(calendarID) = 0 Then Err.Raise MAPI_E_NOT_FOUND, "stdOutlook", "The default store has no Calendar folder." + bytes = DecodeEntryID(calendarID) + CheckHR CallVTable(This.Store, VT_STORE_OPEN_ENTRY, CLng(UBound(bytes) + 1), VarPtr(bytes(0)), CLngPtr(0), 0&, VarPtr(kind), VarPtr(folder)), "OpenEntry(Calendar)" + If kind <> 3 Then Err.Raise 5, "stdOutlook", "The calendar entry is not a folder." + OpenCalendarFolder = folder: folder = 0 +Done: + On Error GoTo 0 + FreeBuffer entry + ReleaseObject source + ReleaseObject folder + If number <> 0 Then Err.Raise number, "stdOutlook.OpenCalendarFolder", description + Exit Function +Failed: + number = Err.Number: description = Err.description + Resume Done +InboxFailed: + Resume TryRoot +End Function + +'Build calendar columns using store-specific appointment named-property IDs. +Private Function CalendarColumns(ByVal folder As LongPtr) As Variant + Dim columns As Variant, fields As Variant, field As Variant, tag As Long, n As Long + columns = Array(Array("EntryID", &HFFF0102), Array("Subject", &H37001F), _ + Array("OrganizerName", &H42001F), Array("MessageClass", &H1A001F)) + fields = Array(Array("Location", &H8208&, 31&), Array("StartUtc", &H820D&, 64&), _ + Array("EndUtc", &H820E&, 64&), Array("IsRecurring", &H8223&, 11&)) + For Each field In fields + tag = AppointmentTag(folder, CLng(field(1)), CLng(field(2))) + If tag <> 0 Then + n = UBound(columns) + 1 + ReDim Preserve columns(0 To n) + columns(n) = Array(field(0), tag) + End If + Next + CalendarColumns = columns +End Function + +'Resolve an appointment property without creating mappings; return zero when unavailable. +Private Function AppointmentTag(ByVal folder As LongPtr, ByVal lid As Long, ByVal propertyType As Long) As Long + Dim guid(0 To 3) As Long, name(0 To PTR_BYTES * 3 - 1) As Byte + Dim namePointer As LongPtr, tags As LongPtr, tag As Long, number As Long, description As String + 'PSETID_Appointment = {00062002-0000-0000-C000-000000000046}. + guid(0) = &H62002: guid(2) = &HC0&: guid(3) = &H46000000 + WritePointer VarPtr(name(0)), VarPtr(guid(0)) + WriteLong PtrAdd(VarPtr(name(0)), PTR_BYTES), 0 'MNID_ID + WriteLong PtrAdd(VarPtr(name(0)), PTR_BYTES * 2), lid + namePointer = VarPtr(name(0)) + On Error GoTo Failed + 'Never MAPI_CREATE: searching must not change the named-property mapping. + CheckHR CallVTable(folder, VT_NAMED_IDS, 1&, VarPtr(namePointer), 0&, VarPtr(tags)), "IMAPIProp.GetIDsFromNames(calendar)" + RequirePointer tags, "GetIDsFromNames" + If ReadLong(tags) <> 1 Then Err.Raise 5, "stdOutlook", "Unexpected named-property count." + tag = ReadLong(PtrAdd(tags, 4)) + If (tag And &HFFFF&) <> 10 Then AppointmentTag = (tag And &HFFFF0000) Or propertyType +Done: + On Error GoTo 0 + FreeBuffer tags + If number <> 0 Then Err.Raise number, "stdOutlook.AppointmentTag", description + Exit Function +Failed: + number = Err.Number: description = Err.description + Resume Done +End Function + +'Apply a native case-insensitive substring OR restriction to available calendar text columns. +Private Sub RestrictCalendar(ByVal table As LongPtr, ByVal query As String, ByVal columns As Variant) + Dim restriction(0 To RESTRICTION_BYTES - 1) As Byte + Dim children(0 To RESTRICTION_BYTES * 3 - 1) As Byte, props(0 To PROP_BYTES * 3 - 1) As Byte + Dim field As Variant, child As LongPtr, prop As LongPtr, count As Long + For Each field In columns + If field(0) = "Subject" Or field(0) = "Location" Or field(0) = "OrganizerName" Then + child = PtrAdd(VarPtr(children(0)), count * RESTRICTION_BYTES) + prop = PtrAdd(VarPtr(props(0)), count * PROP_BYTES) + WriteLong child, 3 'RES_CONTENT + WriteLong PtrAdd(child, RESTRICTION_UNION), &H10001 'FL_SUBSTRING | FL_IGNORECASE + WriteLong PtrAdd(child, RESTRICTION_UNION + 4), CLng(field(1)) + WritePointer PtrAdd(child, RESTRICTION_UNION + 8), prop + WriteLong prop, CLng(field(1)) + WritePointer PtrAdd(prop, 8), StrPtr(query) + count = count + 1 + End If + Next + WriteLong VarPtr(restriction(0)), 1 'RES_OR + WriteLong PtrAdd(VarPtr(restriction(0)), RESTRICTION_UNION), count + WritePointer PtrAdd(VarPtr(restriction(0)), RESTRICTION_UNION + PTR_BYTES), VarPtr(children(0)) + CheckHR CallVTable(table, VT_TABLE_RESTRICT, VarPtr(restriction(0)), 0&), "IMAPITable.Restrict(calendar substring)" +End Sub + +'Raise if the instance has no native session. +Private Sub EnsureSession() + If This.Session = 0 Then Err.Raise 91, "stdOutlook", "Use stdOutlook.Create or OpenProfile before reading Outlook data." +End Sub + +'Lazily open the address book with dialogs disabled. +Private Sub EnsureAddressBook() + EnsureSession + If This.AddressBook = 0 Then + CheckHR CallVTable(This.Session, VT_SESSION_ADDRESS_BOOK, CLngPtr(0), CLngPtr(0), AB_NO_DIALOG, VarPtr(This.AddressBook)), "IMAPISession.OpenAddressBook" + RequirePointer This.AddressBook, "OpenAddressBook" + End If +End Sub + +'Lazily open the default store; upgrade a read-only handle only for explicit writes. +Private Sub EnsureStore(Optional ByVal writable As Boolean = False) + Dim table As LongPtr, rows As Collection, row As Collection, bytes() As Byte + Dim capped As Boolean, number As Long, description As String, flags As Long + EnsureSession + If This.Store <> 0 Then + If Not writable Or This.StoreWritable Then Exit Sub + ReleaseObject This.Store + End If + This.StoreWritable = False + flags = MDB_NO_DIALOG + If writable Then flags = flags Or MDB_WRITE + On Error GoTo Failed + CheckHR CallVTable(This.Session, VT_SESSION_STORES, 0&, VarPtr(table)), "IMAPISession.GetMsgStoresTable" + Set rows = ReadTable(table, Array(Array("EntryID", &HFFF0102), Array("Default", &H3400000B)), 1000, capped) + For Each row In rows + If row("Default") = True Then + bytes = DecodeEntryID(CStr(row("EntryID"))) + CheckHR CallVTable(This.Session, VT_SESSION_OPEN_STORE, CLngPtr(0), CLng(UBound(bytes) + 1), VarPtr(bytes(0)), CLngPtr(0), flags, VarPtr(This.Store)), "IMAPISession.OpenMsgStore" + RequirePointer This.Store, "OpenMsgStore" + This.StoreWritable = writable + Exit For + End If + Next + If This.Store = 0 Then Err.Raise MAPI_E_NOT_FOUND, "stdOutlook", "The profile has no accessible default message store." +Done: + On Error GoTo 0 + ReleaseObject table + If number <> 0 Then Err.Raise number, "stdOutlook", description + Exit Sub +Failed: + number = Err.Number: description = Err.description + ReleaseObject This.Store + Resume Done +End Sub + +'Search one address-book container, copying records and preserving partial-result diagnostics. +Private Function SearchBook(ByVal entryID As String, ByVal query As String, ByVal limit As Long, ByRef capped As Boolean) As Collection + Dim bytes() As Byte, container As LongPtr, table As LongPtr, kind As Long + Dim rows As Collection, row As Collection, person As Collection, result As New Collection + Dim number As Long, description As String + capped = False + On Error GoTo Failed + bytes = DecodeEntryID(entryID) + CheckHR CallVTable(This.AddressBook, VT_AB_OPEN_ENTRY, CLng(UBound(bytes) + 1), VarPtr(bytes(0)), CLngPtr(0), 0&, VarPtr(kind), VarPtr(container)), "IAddrBook.OpenEntry(container)" + CheckHR CallVTable(container, VT_CONTAINER_CONTENTS, 0&, VarPtr(table)), "IABContainer.GetContentsTable" + RestrictName table, query + Set rows = ReadTable(table, Array(Array("EntryID", &HFFF0102)), limit, capped) + For Each row In rows + Set person = ReadContactForSearch(CStr(row("EntryID"))) + If Not person Is Nothing Then result.Add person + Next +Done: + On Error GoTo 0 + ReleaseObject table + ReleaseObject container + If number <> 0 Then This.Warnings.Add "Address book " & entryID & ": " & description + Set SearchBook = result + Exit Function +Failed: + number = Err.Number: description = Err.description + Resume Done +End Function + +'Read a search result or record its provider failure as a warning. +Private Function ReadContactForSearch(ByVal entryID As String) As Collection + On Error GoTo Failed + Set ReadContactForSearch = ReadContact(entryID) + Exit Function +Failed: + This.Warnings.Add "Contact " & entryID & ": " & Err.description +End Function + +'Apply provider-side ambiguous-name resolution, retrying ANSI for unsupported Unicode. +Private Sub RestrictName(ByVal table As LongPtr, ByVal query As String) + Dim restriction(0 To RESTRICTION_BYTES - 1) As Byte + Dim prop(0 To PROP_BYTES - 1) As Byte + Dim hr As Long, ansi() As Byte + 'RES_PROPERTY { RELOP_EQ, PR_ANR_W, &SPropValue }. Explicit native padding. + WriteLong VarPtr(restriction(0)), 4 + WriteLong PtrAdd(VarPtr(restriction(0)), RESTRICTION_UNION), 4 + WriteLong PtrAdd(VarPtr(restriction(0)), RESTRICTION_UNION + 4), &H360C001F + WritePointer PtrAdd(VarPtr(restriction(0)), RESTRICTION_UNION + 8), VarPtr(prop(0)) + WriteLong VarPtr(prop(0)), &H360C001F + WritePointer PtrAdd(VarPtr(prop(0)), 8), StrPtr(query) + hr = CallVTable(table, VT_TABLE_RESTRICT, VarPtr(restriction(0)), 0&) + If hr = MAPI_E_BAD_CHARWIDTH Then + ansi = StrConv(query & vbNullChar, vbFromUnicode) + WriteLong PtrAdd(VarPtr(restriction(0)), RESTRICTION_UNION + 4), &H360C001E + WriteLong VarPtr(prop(0)), &H360C001E + WritePointer PtrAdd(VarPtr(prop(0)), 8), VarPtr(ansi(0)) + hr = CallVTable(table, VT_TABLE_RESTRICT, VarPtr(restriction(0)), 0&) + End If + CheckHR hr, "IMAPITable.Restrict(PR_ANR)" +End Sub + +'Copy person fields and resolve primary SMTP from direct, SMTP-type or uppercase proxy values. +Private Function ReadPerson(ByVal person As LongPtr) As Collection + Dim result As Collection, email As String, address As Variant, proxies As Variant + Set result = GetProperties(person, PersonColumns()) + email = CStr(result("SmtpAddress")) + If Len(email) = 0 And StrComp(CStr(result("AddressType")), "SMTP", vbTextCompare) = 0 Then email = CStr(result("EmailAddress")) + If Len(email) = 0 Then + proxies = result("ProxyAddresses") + If IsArray(proxies) Then + For Each address In proxies + 'Exchange marks the PRIMARY address with uppercase SMTP:, aliases lowercase. + If StrComp(Left$(CStr(address), 5), "SMTP:", vbBinaryCompare) = 0 Then + email = Mid$(CStr(address), 6) + Exit For + End If + Next + End If + End If + result.Add email, "Email" + Set ReadPerson = result +End Function + +'Return name/property-tag pairs for copied contact fields. +Private Function PersonColumns() As Variant + PersonColumns = Array( _ + Array("EntryID", &HFFF0102), Array("DisplayName", &H3001001F), _ + Array("AddressType", &H3002001F), Array("EmailAddress", &H3003001F), _ + Array("SmtpAddress", &H39FE001F), Array("GivenName", &H3A06001F), _ + Array("Surname", &H3A11001F), Array("Company", &H3A16001F), _ + Array("Department", &H3A18001F), Array("JobTitle", &H3A17001F), _ + Array("BusinessPhone", &H3A08001F), Array("MobilePhone", &H3A1C001F), _ + Array("HomePhone", &H3A09001F), Array("Office", &H3A19001F), _ + Array("ObjectType", &HFFE0003), Array("ProxyAddresses", &H800F101F)) +End Function + +'Return name/property-tag pairs for address-book hierarchy rows. +Private Function BookColumns() As Variant + BookColumns = Array(Array("EntryID", &HFFF0102), Array("DisplayName", &H3001001F), Array("Flags", &H36000003), Array("Depth", &H30050003)) +End Function + +'Return message metadata columns, optionally including the plain-text body. +Private Function MessageColumns(ByVal includeBody As Boolean) As Variant + Dim result As Variant + result = Array(Array("EntryID", &HFFF0102), Array("Subject", &H37001F), _ + Array("SenderName", &HC1A001F), Array("SenderAddressType", &HC1E001F), _ + Array("SenderEmailAddress", &HC1F001F), Array("SenderSmtpAddress", &H5D01001F), _ + Array("ReceivedTimeUtc", &HE060040), Array("MessageClass", &H1A001F), _ + Array("MessageFlags", &HE070003), Array("HasAttachments", &HE1B000B)) + If includeBody Then + ReDim Preserve result(0 To 10) + result(10) = Array("Body", &H1000001F) + End If + MessageColumns = result +End Function + +'Copy requested native properties and always free the returned MAPI buffer. +Private Function GetProperties(ByVal instance As LongPtr, ByVal columns As Variant) As Collection + Dim tags() As Long, count As Long, props As LongPtr + Dim number As Long, description As String, hr As Long + BuildTags columns, tags, True + On Error GoTo Failed + hr = CallVTable(instance, VT_GET_PROPS, VarPtr(tags(0)), MAPI_UNICODE, VarPtr(count), VarPtr(props)) + If hr = MAPI_E_BAD_CHARWIDTH Then + FreeBuffer props + hr = CallVTable(instance, VT_GET_PROPS, VarPtr(tags(0)), 0&, VarPtr(count), VarPtr(props)) + End If + CheckHR hr, "IMAPIProp.GetProps" + 'Positive MAPI_W_ERRORS_RETURNED is partial success. Decode PT_ERROR per field. + Set GetProperties = DecodeProperties(props, count, columns) +Done: + On Error GoTo 0 + FreeBuffer props + If number <> 0 Then Err.Raise number, "stdOutlook.GetProperties", description + Exit Function +Failed: + number = Err.Number: description = Err.description + Resume Done +End Function + +'Build an SPropTagArray from name/tag pairs, optionally allowing either string width. +Private Sub BuildTags(ByVal columns As Variant, ByRef tags() As Long, Optional ByVal unspecifiedStrings As Boolean = False) + Dim i As Long, tag As Long + ReDim tags(0 To UBound(columns) + 1) + tags(0) = UBound(columns) + 1 + For i = 0 To UBound(columns) + tag = CLng(columns(i)(1)) + If unspecifiedStrings Then + If (tag And &HFFF&) = 31 Then tag = tag And &HFFFF0000 'PT_UNSPECIFIED; native A or W + End If + tags(i + 1) = tag + Next +End Sub + +'Copy paginated rows, continuing after short pages and reading one extra row to detect truncation. +Private Function ReadTable(ByVal table As LongPtr, ByVal columns As Variant, ByVal limit As Long, ByRef capped As Boolean) As Collection + Dim tags() As Long, rows As LongPtr, count As Long, i As Long, row As LongPtr + Dim take As Long, result As New Collection, item As Collection + Dim number As Long, description As String, hr As Long + capped = False + BuildTags columns, tags + On Error GoTo Failed + hr = CallVTable(table, VT_TABLE_COLUMNS, VarPtr(tags(0)), 0&) + If hr = MAPI_E_BAD_CHARWIDTH Then + For i = 1 To UBound(tags) + If (tags(i) And &HFFFF&) = 31 Then tags(i) = tags(i) - 1 + Next + hr = CallVTable(table, VT_TABLE_COLUMNS, VarPtr(tags(0)), 0&) + End If + CheckHR hr, "IMAPITable.SetColumns" + Do + take = limit - result.Count + 1 + If take > BATCH_SIZE Then take = BATCH_SIZE + CheckHR CallVTable(table, VT_TABLE_ROWS, take, 0&, VarPtr(rows)), "IMAPITable.QueryRows" + RequirePointer rows, "QueryRows" + count = ReadLong(rows) + If count < 0 Or count > take Then Err.Raise 5, "stdOutlook", "Invalid native row count." + For i = 0 To count - 1 + If result.Count = limit Then + capped = True + Exit For + End If + row = PtrAdd(rows, ROWSET_OFFSET + i * ROW_BYTES) + Set item = DecodeProperties(ReadPointer(PtrAdd(row, 8)), ReadLong(PtrAdd(row, 4)), columns) + result.Add item + Next + FreeRows rows + If count = 0 Or capped Then Exit Do + 'A short page is NOT necessarily EOF. Keep going until QueryRows returns 0. + Loop + Set ReadTable = result +Done: + On Error GoTo 0 + FreeRows rows + If number <> 0 Then Err.Raise number, "stdOutlook.ReadTable", description + Exit Function +Failed: + number = Err.Number: description = Err.description + Resume Done +End Function + +'Map native properties into keyed values and a separate keyed PropertyErrors collection. +Private Function DecodeProperties(ByVal props As LongPtr, ByVal count As Long, ByVal columns As Variant) As Collection + Dim result As New Collection, errors As New Collection + Dim i As Long, prop As LongPtr, tag As Long, value As Variant + If count <> UBound(columns) + 1 Then Err.Raise 5, "stdOutlook", "Provider returned an unexpected property count." + RequirePointer props, "property array" + For i = 0 To count - 1 + prop = PtrAdd(props, i * PROP_BYTES) + tag = ReadLong(prop) + value = Empty + If (tag And &HFFFF&) = 10 Then + errors.Add ReadLong(PtrAdd(prop, 8)), CStr(columns(i)(0)) + Else + value = DecodeValue(prop) + End If + result.Add value, CStr(columns(i)(0)) + Next + result.Add errors, "PropertyErrors" + Set DecodeProperties = result +End Function + +'Decode a supported SPropValue into a detached VBA value; timestamps are UTC. +Private Function DecodeValue(ByVal prop As LongPtr) As Variant + Dim value As LongPtr, p As LongPtr, count As Long, i As Long + Dim small As Integer, stamp As SYSTEMTIME, strings() As String, tag As Long + tag = ReadLong(prop) And &HFFFF& + value = PtrAdd(prop, 8) + Select Case tag + Case 0, 1, 10 'PT_UNSPECIFIED, PT_NULL, PT_ERROR + DecodeValue = Empty + Case 2 + CopyMemory small, ByVal value, 2 + DecodeValue = small + Case 3 + DecodeValue = ReadLong(value) + Case 11 + CopyMemory small, ByVal value, 2 + DecodeValue = (small <> 0) + Case 30, 31 + DecodeValue = ReadString(ReadPointer(value), tag = 31) + Case 64 + If FileTimeToSystemTime(value, stamp) <> 0 Then + If stamp.year >= 100 And stamp.year <= 9999 Then + DecodeValue = DateSerial(stamp.year, stamp.month, stamp.day) + TimeSerial(stamp.hour, stamp.minute, stamp.second) + End If + End If + Case 258 'PT_BINARY, returned as a portable hex entry ID / blob + count = ReadLong(value) + p = ReadPointer(PtrAdd(value, BINARY_POINTER_OFFSET)) + DecodeValue = HexBytes(p, count) + Case &H101E, &H101F 'PT_MV_STRING8 / PT_MV_UNICODE (proxy addresses) + count = ReadLong(value) + If count < 0 Or count > 100000 Then Err.Raise 5, "stdOutlook", "Invalid string-array size." + If count = 0 Then + DecodeValue = Array() + Else + p = ReadPointer(PtrAdd(value, BINARY_POINTER_OFFSET)) + RequirePointer p, "string array" + ReDim strings(0 To count - 1) + For i = 0 To count - 1 + strings(i) = ReadString(ReadPointer(PtrAdd(p, i * PTR_BYTES)), tag = &H101F) + Next + DecodeValue = strings + End If + Case Else + Err.Raise MAPI_E_NO_SUPPORT, "stdOutlook", "Unsupported native property type 0x" & Hex$(tag) + End Select +End Function + +'DispCallFunc performs the ABI bridge. No generated machine code or RWX pages. +'ParamArray values MUST be typed: Long for ULONG/HRESULT, LongPtr for pointers. +'The array passed to DispCallFunc contains pointers to VARIANTs, not their data. +Private Function CallVTable(ByVal instance As LongPtr, ByVal slot As Long, ParamArray arguments() As Variant) As Long + Dim values() As Variant, types() As Integer, pointers() As LongPtr + Dim count As Long, i As Long, result As Variant, hr As Long + RequirePointer instance, "native interface" + values = arguments + count = UBound(values) + 1 + ReDim types(0 To count): ReDim pointers(0 To count) + For i = 0 To count - 1 + types(i) = VarType(values(i)) + pointers(i) = VarPtr(values(i)) + Next + hr = DispCallFunc(instance, CLngPtr(slot * PTR_BYTES), 4, vbLong, count, VarPtr(types(0)), VarPtr(pointers(0)), result) + CheckHR hr, "DispCallFunc" + CallVTable = CLng(result) +End Function + +'Release one owned IUnknown pointer and clear it to prevent repeated release. +Private Sub ReleaseObject(ByRef instance As LongPtr) + Dim owned As LongPtr + If instance = 0 Then Exit Sub + owned = instance: instance = 0 + CallVTable owned, VT_RELEASE +End Sub + +'Free one MAPI allocation and clear its pointer. +Private Sub FreeBuffer(ByRef buffer As LongPtr) + If buffer = 0 Then Exit Sub + MAPIFreeBuffer buffer + buffer = 0 +End Sub + +'SRowSet owns separate property buffers per row. MAPIFreeBuffer(rows) alone +'leaks them. This is the documented FreeProws algorithm, without another DLL. +Private Sub FreeRows(ByRef rows As LongPtr) + Dim i As Long, props As LongPtr + If rows = 0 Then Exit Sub + For i = 0 To ReadLong(rows) - 1 + props = ReadPointer(PtrAdd(rows, ROWSET_OFFSET + i * ROW_BYTES + 8)) + FreeBuffer props + Next + FreeBuffer rows +End Sub + +'Add a byte offset while preserving unsigned 32-bit pointer arithmetic. +Private Function PtrAdd(ByVal pointer As LongPtr, ByVal offset As Long) As LongPtr +#If Win64 Then + PtrAdd = pointer + offset +#Else + 'Handle 32-bit addresses crossing the signed Long boundary. + Dim address As Double + address = CDbl(pointer) + If address < 0 Then address = address + 4294967296# + address = address + offset + If address >= 2147483648# Then address = address - 4294967296# + PtrAdd = CLng(address) +#End If +End Function + +'Copy a native four-byte signed integer. +Private Function ReadLong(ByVal pointer As LongPtr) As Long + CopyMemory ReadLong, ByVal pointer, 4 +End Function + +'Copy a native pointer using the host pointer width. +Private Function ReadPointer(ByVal pointer As LongPtr) As LongPtr + CopyMemory ReadPointer, ByVal pointer, PTR_BYTES +End Function + +'Write a native four-byte integer. +Private Sub WriteLong(ByVal pointer As LongPtr, ByVal value As Long) + CopyMemory ByVal pointer, value, 4 +End Sub + +'Write a native pointer using the host pointer width. +Private Sub WritePointer(ByVal pointer As LongPtr, ByVal value As LongPtr) + CopyMemory ByVal pointer, value, PTR_BYTES +End Sub + +'Copy a null-terminated native Unicode or system-code-page string. +Private Function ReadString(ByVal pointer As LongPtr, ByVal unicode As Boolean) As String + Dim length As Long, characters As Long + If pointer = 0 Then Exit Function + If unicode Then + length = lstrlenW(pointer) + If length > 0 Then + ReadString = String$(length, vbNullChar) + CopyMemory ByVal StrPtr(ReadString), ByVal pointer, CLngPtr(length) * 2 + End If + Else + length = lstrlenA(pointer) + If length > 0 Then + characters = MultiByteToWideChar(0, 0, pointer, length, 0, 0) + If characters = 0 Then Err.Raise 5, "stdOutlook", "Cannot decode provider ANSI text." + ReadString = String$(characters, vbNullChar) + If MultiByteToWideChar(0, 0, pointer, length, StrPtr(ReadString), characters) = 0 Then Err.Raise 5, "stdOutlook", "Cannot decode provider ANSI text." + End If + End If +End Function + +'Copy native binary bytes to an uppercase hexadecimal string. +Private Function HexBytes(ByVal pointer As LongPtr, ByVal length As Long) As String + Dim bytes() As Byte, i As Long + If length < 0 Or length > 16777216 Then Err.Raise 5, "stdOutlook", "Invalid binary property length." + If length = 0 Then Exit Function + RequirePointer pointer, "binary property" + ReDim bytes(0 To length - 1) + CopyMemory bytes(0), ByVal pointer, length + HexBytes = String$(length * 2, "0") + For i = 0 To length - 1 + Mid$(HexBytes, i * 2 + 1, 2) = Right$("0" & Hex$(bytes(i)), 2) + Next +End Function + +'Validate a nonempty even-length hex ID and return a zero-based Byte array. +Private Function DecodeEntryID(ByVal value As String) As Byte() + Dim bytes() As Byte, i As Long + If Len(value) = 0 Or Len(value) Mod 2 <> 0 Or Len(value) > 131072 Then + Err.Raise 5, "stdOutlook", "EntryID must be a nonempty, even-length hexadecimal string." + End If + ReDim bytes(0 To Len(value) \ 2 - 1) + For i = 1 To Len(value) + If InStr(1, "0123456789ABCDEF", Mid$(value, i, 1), vbTextCompare) = 0 Then Err.Raise 5, "stdOutlook", "EntryID contains a non-hexadecimal character." + Next + For i = 0 To UBound(bytes) + bytes(i) = CByte("&H" & Mid$(value, i * 2 + 1, 2)) + Next + DecodeEntryID = bytes +End Function + +'Check membership in a VBA Collection without exposing a missing-key error. +Private Function HasKey(ByVal items As Collection, ByVal key As String) As Boolean + Dim value As Variant + On Error Resume Next + value = items(key) + HasKey = (Err.Number = 0) + On Error GoTo 0 +End Function + +'Reject public result limits outside 1 through 10000. +Private Sub ValidateLimit(ByVal limit As Long) + If limit < 1 Or limit > 10000 Then Err.Raise 5, "stdOutlook", "maxResults must be between 1 and 10000." +End Sub + +'Reject a null interface or buffer returned by a native operation. +Private Sub RequirePointer(ByVal pointer As LongPtr, ByVal operation As String) + If pointer = 0 Then Err.Raise 91, "stdOutlook", operation & " returned a null pointer." +End Sub + +'Raise on negative HRESULTs while retaining the native operation context. +Private Sub CheckHR(ByVal hr As Long, ByVal operation As String) + If hr < 0 Then Err.Raise hr, "stdOutlook", operation & " failed (HRESULT 0x" & Right$("00000000" & Hex$(hr), 8) & ")." +End Sub diff --git a/tests/README.md b/tests/README.md index a0919a9..539fd12 100644 --- a/tests/README.md +++ b/tests/README.md @@ -22,3 +22,9 @@ Some legacy suites remain aggregate cases; split those as they are maintained. C Access host automation is not implemented. The old Clipboard suite requires a workbook-specific worksheet builder, contains hard-coded paths and documents known failures; it is explicitly unavailable in the automated inventory. The old WebSocket module is commented-out placeholder code; use `stdWebSocket.local`. The historical Regex thunk comparison also requires removed experimental CreateVBA/CreateNative APIs and is explicitly unavailable; current Regex cases cover the distributed class. These are visible skips under `--all`, not passing coverage. Existing WIP prototype classes can contain exploratory test methods; they are not production regression coverage. Run the runner's own contract tests without Office with `python -B tests/tooling/test_runner.py`. + +Outlook tests are opt-in: `python Tools/Testing/run.py --suite stdOutlook`. The +standalone harness uses the shared Office host in its own bounded settings +transaction, stages private probes and fake Outlook acquisition, and imports the +shared assertion reporter. It never submits or synchronizes real mail. See +[stdOutlook](../docs/stdOutlook.md) for separate read-only live and ABI checks. diff --git a/tests/harnesses/stdOutlook-tests/run.py b/tests/harnesses/stdOutlook-tests/run.py new file mode 100644 index 0000000..8ed5e9d --- /dev/null +++ b/tests/harnesses/stdOutlook-tests/run.py @@ -0,0 +1,150 @@ +"""Run VBA in a disposable Excel process using stdVBA's safeguarded test host. + +Requires pywin32, Excel and classic Outlook; uses this checkout's shared Office host. +The production class has no dependency on this test-only tooling. +""" +import argparse +import importlib.util +import json +import os +from pathlib import Path +import tempfile +import sys +sys.dont_write_bytecode = True + +ROOT = Path(__file__).resolve().parents[3] +HERE = Path(__file__).resolve().parent + +# Append test entry points to a TEMPORARY copy, never the distributable class. +PROBES = ''' +Friend Function TestDecode(ByVal pointer As LongPtr) As Variant + TestDecode = DecodeValue(pointer) +End Function +Friend Function TestProperties(ByVal pointer As LongPtr, ByVal count As Long, ByVal columns As Variant) As Collection + Set TestProperties = DecodeProperties(pointer, count, columns) +End Function +Friend Function TestTable(ByVal pointer As LongPtr, ByVal limit As Long, ByRef capped As Boolean) As Collection + Set TestTable = ReadTable(pointer, Array(Array("Number", &H30000003), Array("Text", &H3001001F)), limit, capped) +End Function +Friend Sub TestRestriction(ByVal pointer As LongPtr, ByVal query As String) + RestrictName pointer, query +End Sub +Friend Sub TestRelease(ByRef pointer As LongPtr) + ReleaseObject pointer +End Sub +Friend Function TestEntryID(ByVal value As String) As String + Dim bytes() As Byte + bytes = DecodeEntryID(value) + TestEntryID = HexBytes(VarPtr(bytes(0)), UBound(bytes) + 1) +End Function +Friend Function TestPerson(ByVal pointer As LongPtr) As Collection + Set TestPerson = ReadPerson(pointer) +End Function +Friend Sub TestTransport(ByVal session As LongPtr, ByVal book As LongPtr, ByVal store As LongPtr, Optional ByVal writable As Boolean = True) + This.Session = session + This.AddressBook = book + This.Store = store + This.StoreWritable = writable +End Sub +Friend Function TestAppointmentTag(ByVal folder As LongPtr, ByVal lid As Long, ByVal kind As Long) As Long + TestAppointmentTag = AppointmentTag(folder, lid, kind) +End Function +Friend Sub TestCalendarRestriction(ByVal table As LongPtr, ByVal query As String, ByVal columns As Variant) + RestrictCalendar table, query, columns +End Sub +''' + + +def crlf(data: bytes) -> bytes: + return data.replace(b"\r\n", b"\n").replace(b"\r", b"\n").replace(b"\n", b"\r\n") + + +def main(): + parser = argparse.ArgumentParser(description=__doc__) + parser.add_argument("--stdvba", type=Path, default=ROOT, help="Path to stdVBA checkout (defaults to this repository)") + parser.add_argument("--live", action="store_true", help="Also read the default Outlook profile; no personal data is logged") + args = parser.parse_args() + host_file = args.stdvba.resolve() / "Tools/Testing/office.py" + if not host_file.is_file(): + parser.error("stdVBA Tools/Testing/office.py was not found") + with tempfile.TemporaryDirectory(prefix="stdOutlook-tests-") as temp: + scratch = Path(temp) + # Keep stdVBA's checkout unchanged. Add an explicit VBE compilation step + # to its temporary runner; its existing watchdog treats any dialog as failure. + host_source = host_file.read_text(encoding="utf-8") + # ShowWindow can block behind a busy Office GUI thread, defeating the + # parent deadline. The async form keeps the watchdog independent. + host_source = host_source.replace("USER.ShowWindow", "USER.ShowWindowAsync") + host_source = host_source.replace( + ' macro = "UnifiedTestRunner.RunCase"', + ' print("Imported modules:", [(c.Name, c.Type, c.CodeModule.CountOfLines) for c in project.VBComponents], flush=True)\n' + ' compile_command = app.VBE.CommandBars.FindControl(1, 578)\n' + ' if compile_command is not None and compile_command.Enabled:\n' + ' compile_command.Execute()\n' + ' print("Compile command returned", flush=True)\n' + ' pane = app.VBE.ActiveCodePane\n' + ' if pane is not None:\n' + ' selection = pane.GetSelection()\n' + ' print("VBE location:", pane.CodeModule.Name, selection, pane.CodeModule.Lines(selection[0], 1), flush=True)\n' + ' macro = "UnifiedTestRunner.RunCase"', + ) + host_source = host_source.replace( + ' if dialogs:\n raise RuntimeError', + ' if dialogs:\n time.sleep(0.25) # Let the worker report the selected compile-error line.\n raise RuntimeError', + ) + staged_host = scratch / "office_host.py" + staged_host.write_bytes(crlf(host_source.encode("utf-8"))) + spec = importlib.util.spec_from_file_location("stdvba_office", staged_host) + office = importlib.util.module_from_spec(spec) + spec.loader.exec_module(office) + source = (ROOT / "src/stdOutlook.cls").read_bytes() + # Reject bad repository bytes before doing ANY VBA import. + files = [ROOT / "src/stdOutlook.cls", ROOT / "tests/stdOutlookTests.bas", HERE / "stdOutlookSendCalendarTests.bas", HERE / "stdOutlookSyncFake.cls", ROOT / "tests/support/Test.cls"] + for path in files: + data = path.read_bytes() + if data != crlf(data): + raise RuntimeError(f"CRLF required before import: {path}") + staged_class = scratch / "stdOutlook.cls" + # Replace acquisition only in the staged class. All production sync logic + # runs against a late-bound fake, even with --live. Fail closed on drift. + for original, replacement in ( + (b'GetObject(, "Outlook.Application")', b'stdOutlookSendCalendarTests.GetRunningOutlookFake()'), + (b'CreateObject("Outlook.Application")', b'stdOutlookSendCalendarTests.StartOutlookFake()'), + ): + if source.count(original) != 1: + raise RuntimeError("Outlook acquisition changed; update safe test substitution") + source = source.replace(original, replacement) + staged_class.write_bytes(crlf(source + PROBES.encode("ascii"))) + staged_tests = scratch / "UnifiedTestRunner.bas" + test_source = files[1].read_bytes().replace(b'Attribute VB_Name = "stdOutlookTests"', b'Attribute VB_Name = "UnifiedTestRunner"').replace(b"#Const LIVE_TEST = False", b"#Const LIVE_TEST = " + str(args.live).encode("ascii")) + staged_tests.write_bytes(crlf(test_source)) + staged_extra = scratch / "stdOutlookSendCalendarTests.bas" + staged_extra.write_bytes(crlf(files[2].read_bytes())) + staged_outlook = scratch / "stdOutlookSyncFake.cls" + staged_outlook.write_bytes(crlf(files[3].read_bytes())) + staged_reporter = scratch / "Test.cls" + staged_reporter.write_bytes(crlf(files[4].read_bytes())) + # stdVBA's host probes the installed Office/VBE versions, checks policy, + # records/restores AccessVBOM and both error-trapping registry values, + # owns a separate Excel PID, monitors/dismisses only its modal dialogs, + # imposes a 90-second deadline, and locks against overlapping test runs. + progress = scratch / "progress.txt" + old_progress = os.environ.get("STDOUTLOOK_TEST_PROGRESS") + os.environ["STDOUTLOOK_TEST_PROGRESS"] = str(progress) + try: + office.run({"kind": "vba", "files": [str(staged_class), str(staged_tests), str(staged_extra), str(staged_outlook), str(staged_reporter)]}, "Excel", temp) + finally: + if old_progress is None: + os.environ.pop("STDOUTLOOK_TEST_PROGRESS", None) + else: + os.environ["STDOUTLOOK_TEST_PROGRESS"] = old_progress + if progress.exists(): + print(progress.read_text()) + result = json.loads((scratch / "result.json").read_text(encoding="utf-8")) + print(json.dumps(result, indent=2)) + if result.get("status") != "passed" or result.get("assertions", 0) <= 0: + raise SystemExit(1) + + +if __name__ == "__main__": + main() diff --git a/tests/harnesses/stdOutlook-tests/stdOutlookSendCalendarTests.bas b/tests/harnesses/stdOutlook-tests/stdOutlookSendCalendarTests.bas new file mode 100644 index 0000000..d9383ab --- /dev/null +++ b/tests/harnesses/stdOutlook-tests/stdOutlookSendCalendarTests.bas @@ -0,0 +1,595 @@ +Attribute VB_Name = "stdOutlookSendCalendarTests" +Option Explicit + +'All submission interfaces below are synthetic VBA vtables. No live message +'store is ever attached to these tests, including when --live is requested. +Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal length As LongPtr) +Private Declare PtrSafe Function MAPIAllocateBuffer Lib "mapi32.dll" (ByVal size As Long, ByRef pointer As LongPtr) As Long +Private Declare PtrSafe Function MAPIAllocateMore Lib "mapi32.dll" (ByVal size As Long, ByVal parent As LongPtr, ByRef pointer As LongPtr) As Long +Private Declare PtrSafe Function lstrlenW Lib "kernel32" (ByVal pointer As LongPtr) As Long +Private Declare PtrSafe Function MultiByteToWideChar Lib "kernel32" (ByVal cp As Long, ByVal flags As Long, ByVal source As LongPtr, ByVal length As Long, ByVal dest As LongPtr, ByVal capacity As Long) As Long + +#If Win64 Then + Private Const PB As Long = 8 + Private Const SP As Long = 24 + Private Const SR As Long = 16 + Private Const RO As Long = 8 + Private Const RU As Long = 8 + Private Const RS As Long = 32 +#Else + Private Const PB As Long = 4 + Private Const SP As Long = 16 + Private Const SR As Long = 12 + Private Const RO As Long = 4 + Private Const RU As Long = 4 + Private Const RS As Long = 16 +#End If + +Private sessionVT(0 To 10) As LongPtr, bookVT(0 To 18) As LongPtr +Private storeVT(0 To 17) As LongPtr, folderVT(0 To 19) As LongPtr +Private messageVT(0 To 20) As LongPtr, tableVT(0 To 14) As LongPtr +Private storesTableVT(0 To 19) As LongPtr, storesTableObj As LongPtr +Private sessionObj As LongPtr, bookObj As LongPtr, storeObj As LongPtr +Private folderObj As LongPtr, messageObj As LongPtr, tableObj As LongPtr +Private assertions As Long, failure As String, failStage As Long +Private submits As Long, creates As Long, messageReleases As Long, folderReleases As Long +Private recipientCount As Long, recipientTypes As String, recipientAddresses As String +Private capturedBody As String, capturedSubject As String, capturedHTML As Boolean +Private missingName As Boolean, expectedLid As Long, restrictionCalls As Long +Private storeRowsRead As Boolean, denyWrite As Boolean, writeOpens As Long +Private statusTableVT(0 To 19) As LongPtr, statusVT(0 To 17) As LongPtr +Private statusTableObj As LongPtr, statusObj As LongPtr, statusRowsRead As Boolean +Private syncMode As Long, syncCalls As Long, syncFlags As Long, syncEntry As Long +Private syncFail As Boolean, wrongStatusType As Boolean, statusReleases As Long +Private automation As stdOutlookSyncFake, outlookRunning As Boolean, starts As Long +Private mismatchStore As Boolean, failCompare As Boolean, failStart As Boolean + +Public Function RunTests() As Long + Dim client As stdOutlook, stage As Long, number As Long, errorSource As String, errorDescription As String + On Error GoTo Failed + sessionVT(2) = Address(AddressOf ReleaseFake) + sessionVT(4) = Address(AddressOf StoresTableFake): sessionVT(5) = Address(AddressOf OpenStoreFake) + sessionVT(8) = Address(AddressOf StatusTableFake): sessionVT(9) = Address(AddressOf OpenStatusFake) + sessionVT(10) = Address(AddressOf CompareIDsFake) + statusTableVT(2) = Address(AddressOf ReleaseFake): statusTableVT(7) = Address(AddressOf StatusColumnsFake) + statusTableVT(19) = Address(AddressOf StatusRowsFake): statusTableObj = VarPtr(statusTableVT(0)) + statusVT(2) = Address(AddressOf ReleaseFake): statusVT(17) = Address(AddressOf FlushFake) + statusObj = VarPtr(statusVT(0)) + storesTableVT(2) = Address(AddressOf ReleaseFake): storesTableVT(7) = Address(AddressOf StoreColumnsFake) + storesTableVT(19) = Address(AddressOf StoreRowsFake): storesTableObj = VarPtr(storesTableVT(0)) + bookVT(2) = Address(AddressOf ReleaseFake): bookVT(18) = Address(AddressOf OneOffFake) + storeVT(2) = Address(AddressOf ReleaseFake): storeVT(5) = Address(AddressOf StorePropertiesFake) + storeVT(17) = Address(AddressOf OpenOutboxFake) + folderVT(2) = Address(AddressOf ReleaseFake): folderVT(19) = Address(AddressOf CreateMessageFake) + folderVT(13) = Address(AddressOf NamedIDsFake) + messageVT(2) = Address(AddressOf ReleaseFake): messageVT(8) = Address(AddressOf SetPropertiesFake) + messageVT(19) = Address(AddressOf RecipientsFake): messageVT(20) = Address(AddressOf SubmitFake) + tableVT(14) = Address(AddressOf CalendarRestrictionFake) + sessionObj = VarPtr(sessionVT(0)): bookObj = VarPtr(bookVT(0)): storeObj = VarPtr(storeVT(0)) + folderObj = VarPtr(folderVT(0)): messageObj = VarPtr(messageVT(0)): tableObj = VarPtr(tableVT(0)) + Set client = New stdOutlook + client.TestTransport VarPtr(sessionObj), VarPtr(bookObj), VarPtr(storeObj) + assertions = 0 + Check client.UseOutlookSendReceive, "Outlook synchronization enabled by default" + client.UseOutlookSendReceive = False 'Retain coverage of the explicit native option. + + ResetCapture + client.SendEmail "ada@example.test; bob@example.test", "Unicode " & ChrW$(&H6771), "Line 1" & vbCrLf & "Zo" & ChrW$(&HEB), "cc@example.test", "bcc@example.test" + Check failure = "", "Plain send native arguments: " & failure + Check submits = 1 And creates = 1, "Plain send submits exactly once" + Check capturedSubject = "Unicode " & ChrW$(&H6771), "Unicode subject retained" + Check capturedBody = "Line 1" & vbCrLf & "Zo" & ChrW$(&HEB) And Not capturedHTML, "Plain Unicode body retained" + Check recipientCount = 4 And recipientTypes = "1123", "To, CC, and BCC recipient types" + Check recipientAddresses = "ada@example.test;bob@example.test;cc@example.test;bcc@example.test;", "Recipient addresses copied correctly" + Check messageReleases = 1 And folderReleases = 1, "Send releases message and Outbox" + Check syncCalls = 1 And syncEntry = 2 And syncFlags = &H3A, "Send prefers spooler and requests outgoing async flush" + Check client.LastSendSyncRequested And client.LastSendSyncError = "" And statusReleases = 1, "Accepted sync reported separately and status released" + + ResetCapture + client.SendEmailHTML "ada@example.test", "HTML", "

Zo" & ChrW$(&HEB) & " " & ChrW$(&H6771) & "

" + Check failure = "", "HTML send native arguments: " & failure + Check capturedHTML And capturedBody = "

Zo" & ChrW$(&HEB) & " " & ChrW$(&H6771) & "

", "HTML body is UTF-8 binary without a trailing null" + Check submits = 1, "HTML submits once" + Check syncCalls = 1 And client.LastSendSyncRequested, "HTML also automatically flushes" + ResetCapture + syncFail = True + client.SendEmail "ada@example.test", "queued", "body" + Check submits = 1 And syncCalls = 1 And Not client.LastSendSyncRequested, "Flush failure does not fail or retry the submitted email" + Check Len(client.LastSendSyncError) > 0 And statusReleases = 1, "Flush error available separately with cleanup" + ResetCapture + client.SendEmail "ada@example.test", "batch", "body", flushQueue:=False + Check submits = 1 And syncCalls = 0 And Not client.LastSendSyncRequested And client.LastSendSyncError = "", "Opt-out resets previous sync diagnostics" + ResetCapture + Check client.FlushQueues(True) = 1 And syncFlags = &H3E, "Explicit flush can include incoming mail" + ResetCapture + syncMode = 1 + Check client.FlushQueues() = 2 And syncCalls = 2 And syncFlags = &H1A And statusReleases = 2, "Without spooler both transports flushed synchronously" + Check failure = "", "Transport flush ABI: " & failure + ResetCapture + syncMode = 2 + client.SendEmailHTML "ada@example.test", "unsupported", "body" + Check submits = 1 And syncCalls = 0 And Len(client.LastSendSyncError) > 0, "Unsupported sync does not lose submission success" + On Error Resume Next + client.FlushQueues + number = Err.Number + On Error GoTo Failed + Check number <> 0 And syncCalls = 0, "Explicit unsupported flush raises without calling unsupported methods" + ResetCapture + syncMode = 3 + client.SendEmail "ada@example.test", "no status table", "body" + Check submits = 1 And syncCalls = 0 And Len(client.LastSendSyncError) > 0, "Status-table failure retained separately" + ResetCapture + wrongStatusType = True + On Error Resume Next + client.FlushQueues + number = Err.Number + On Error GoTo Failed + Check number <> 0 And syncCalls = 0 And statusReleases = 1, "Wrong native object type rejected before vtable call" + ResetCapture + syncFail = True + On Error Resume Next + client.FlushQueues + number = Err.Number + On Error GoTo Failed + Check number <> 0 And syncCalls = 1 And statusReleases = 1, "Explicit failed flush raises and releases without retry" + ResetCapture + client.SendEmail "", vbNullString, vbNullString, "", "bcc@example.test" + Check submits = 1 And capturedBody = "" And capturedSubject = "", "BCC-only and empty subject/body supported" + ResetCapture + client.SendEmailHTML "ada@example.test", "", "" + Check submits = 1 And capturedBody = "" And capturedHTML, "Empty HTML supported" + + For stage = 1 To 4 + ResetCapture + failStage = stage + On Error Resume Next + client.SendEmail "ada@example.test", "fail", "body" + number = Err.Number + On Error GoTo Failed + Check number <> 0, "Native failure surfaced at stage " & stage + If stage < 4 Then + Check submits = 0, "Preparation failure prevents submit at stage " & stage + Else + Check submits = 1, "Failed submission is not retried" + End If + Check messageReleases = 1 And folderReleases = 1, "Failure cleanup at stage " & stage + Check syncCalls = 0 And Not client.LastSendSyncRequested, "No flush after failed submission at stage " & stage + Next + ResetCapture + On Error Resume Next + client.SendEmail "Ada ", "subject", "body" + number = Err.Number + On Error GoTo Failed + Check number = 5 And creates = 0, "Display-name syntax rejected before mutation" + On Error Resume Next + client.SendEmail "ada@example.test;", "subject", "body" + number = Err.Number + On Error GoTo Failed + Check number = 5 And creates = 0, "Empty recipient rejected before mutation" + On Error Resume Next + client.SendEmail "", "subject", "body" + number = Err.Number + On Error GoTo Failed + Check number = 5 And creates = 0, "No recipients rejected before mutation" + On Error Resume Next + client.SendEmail "a" & Chr$(127) & "@example.test", "subject", "body" + number = Err.Number + On Error GoTo Failed + Check number = 5 And creates = 0, "DEL control character rejected before mutation" + On Error Resume Next + client.SendEmailHTML "ada@example.test", "subject", "

" & vbNullChar + number = Err.Number + On Error GoTo Failed + Check number = 5 And creates = 0, "Null body rejected before mutation" + + expectedLid = &H8208&: missingName = False + Check client.TestAppointmentTag(VarPtr(folderObj), expectedLid, 31) = &H9000001F, "Named calendar property mapped with store-specific ID" + Check failure = "", "MAPINAMEID native structure: " & failure + missingName = True + Check client.TestAppointmentTag(VarPtr(folderObj), expectedLid, 31) = 0, "Missing named property does not create a mapping" + restrictionCalls = 0 + client.TestCalendarRestriction VarPtr(tableObj), "planning", Array(Array("Subject", &H37001F), Array("Location", &H9000001F), Array("OrganizerName", &H42001F)) + Check restrictionCalls = 1 And failure = "", "Calendar OR/substring restriction ABI: " & failure + client.Disconnect + client.TestTransport VarPtr(sessionObj), VarPtr(bookObj), VarPtr(storeObj), False + ResetCapture + writeOpens = 0: denyWrite = False + client.SendEmail "ada@example.test", "upgrade", "body" + Check writeOpens = 1 And submits = 1 And failure = "", "Read-only store upgraded with MDB_WRITE before sending" + TestOutlookSync client + client.Disconnect + client.TestTransport VarPtr(sessionObj), VarPtr(bookObj), VarPtr(storeObj), False + ResetCapture + denyWrite = True + On Error Resume Next + client.SendEmail "ada@example.test", "denied", "body" + number = Err.Number + On Error GoTo Failed + Check number <> 0 And creates = 0 And submits = 0, "Denied write access cannot create or submit a message" + client.Disconnect + Set client = Nothing + RunTests = assertions + Exit Function +Failed: + number = Err.Number: errorSource = Err.Source: errorDescription = Err.description + If Not client Is Nothing Then client.Disconnect + Err.Raise number, errorSource, errorDescription +End Function + +Private Sub TestOutlookSync(ByVal client As stdOutlook) + Dim number As Long + client.UseOutlookSendReceive = True + ResetCapture + outlookRunning = True: automation.WindowCount = 1 + client.SendEmail "ada@example.test", "sync", "body" + Check starts = 0 And automation.Requests = 1 And automation.Displays = 0, "Existing Outlook reused without opening another window" + Check submits = 1 And syncCalls = 0 And client.LastSendSyncRequested, "Automatic send uses Outlook instead of native flush" + Check Not automation.ShowProgress And failure = "", "Automatic sync hides progress and follows native message cleanup" + Check automation.Order = "Namespace;Initialize;Store;Sync;", "Initialization and store validation precede sync" + + ResetCapture + client.SendEmailHTML "ada@example.test", "start", "

body

" + Check starts = 1 And automation.Displays = 1 And automation.Requests = 1, "HTML starts Outlook and opens a window for asynchronous lifetime" + Check automation.Order = "Namespace;Initialize;Store;Display;Sync;", "New Outlook starts before sync" + client.SendAndReceive True + Check starts = 1 And automation.Displays = 1 And automation.Requests = 2 And automation.ShowProgress, "Explicit retry reuses Outlook and passes progress flag" + Check submits = 1, "Explicit sync never resubmits email" + + ResetCapture + client.SendEmail "ada@example.test", "batch", "body", flushQueue:=False + Check starts = 0 And automation.Requests = 0 And Not client.LastSendSyncRequested, "Batch opt-out does not start Outlook" + + ResetCapture + mismatchStore = True + client.SendEmail "ada@example.test", "different profile", "body" + Check submits = 1 And automation.Requests = 0 And automation.Displays = 0, "Mismatched default store prevents sync and display" + Check Len(client.LastSendSyncError) > 0 And Not client.LastSendSyncRequested, "Store mismatch retained as sync error after successful submission" + + ResetCapture + failCompare = True + On Error Resume Next + client.SendAndReceive + number = Err.Number + On Error GoTo 0 + Check number <> 0 And automation.Requests = 0, "Failed native store comparison prevents sync" + + ResetCapture + automation.FailSync = True + client.SendEmail "ada@example.test", "queued", "body" + Check submits = 1 And automation.Requests = 1 And Len(client.LastSendSyncError) > 0, "Automation failure preserves queued message without retry" + On Error Resume Next + client.SendAndReceive + number = Err.Number + On Error GoTo 0 + Check number <> 0 And submits = 1 And automation.Requests = 2, "Explicit sync failure raises without creating a message" + + ResetCapture + automation.FailInitialize = True + client.SendEmail "ada@example.test", "initialization", "body" + Check submits = 1 And automation.Requests = 0 And Len(client.LastSendSyncError) > 0, "Initialization failure isolated from submission" + ResetCapture + failStart = True + client.SendEmail "ada@example.test", "startup", "body" + Check submits = 1 And automation.Requests = 0 And Len(client.LastSendSyncError) > 0, "Outlook startup failure isolated from submission" + ResetCapture + failStage = 4 + On Error Resume Next + client.SendEmail "ada@example.test", "submit failure", "body" + number = Err.Number + On Error GoTo 0 + Check number <> 0 And starts = 0 And automation.Requests = 0, "Failed submission never starts Outlook" +End Sub + +Public Function GetRunningOutlookFake() As Object + If outlookRunning Then Set GetRunningOutlookFake = automation +End Function + +Public Function StartOutlookFake() As Object + starts = starts + 1 + If failStart Then Err.Raise 429, , "Synthetic Outlook startup failure" + outlookRunning = True + Set StartOutlookFake = automation +End Function + +Public Sub CheckSyncOrder() + If creates > 0 And (messageReleases <> 1 Or folderReleases <> 1) Then failure = "Outlook sync before submitted message release" +End Sub + +Public Function CompareIDsFake(ByVal self As LongPtr, ByVal cb1 As Long, ByVal entry1 As LongPtr, ByVal cb2 As Long, ByVal entry2 As LongPtr, ByVal flags As Long, ByRef same As Long) As Long + If cb1 <> 4 Or cb2 <> 4 Or flags <> 0 Then failure = "CompareEntryIDs arguments" + If LongAt(entry1) <> 99 Or LongAt(entry2) <> 99 Then failure = "CompareEntryIDs store IDs" + If failCompare Then + CompareIDsFake = &H80004005 + ElseIf Not mismatchStore Then + same = 1 + End If +End Function + +Private Sub ResetCapture() + failure = "": failStage = 0: submits = 0: creates = 0 + messageReleases = 0: folderReleases = 0: recipientCount = 0 + recipientTypes = "": recipientAddresses = "": capturedBody = "": capturedSubject = "" + capturedHTML = False + syncMode = 0: syncCalls = 0: syncFlags = 0: syncEntry = 0 + syncFail = False: wrongStatusType = False: statusReleases = 0 + Set automation = New stdOutlookSyncFake + outlookRunning = False: starts = 0: mismatchStore = False: failCompare = False: failStart = False +End Sub + +Private Sub Check(ByVal condition As Boolean, ByVal label As String) + Test.Assert label, condition + If Not condition Then Err.Raise vbObjectError + 2002, "stdOutlookSendCalendarTests", label + assertions = assertions + 1 +End Sub + +Public Function ReleaseFake(ByVal self As LongPtr) As Long + If self = VarPtr(messageObj) Then messageReleases = messageReleases + 1 + If self = VarPtr(folderObj) Then folderReleases = folderReleases + 1 + If self = VarPtr(statusObj) Then statusReleases = statusReleases + 1 +End Function + +Public Function StatusTableFake(ByVal self As LongPtr, ByVal flags As Long, ByRef table As LongPtr) As Long + If flags <> 0 Then failure = "GetStatusTable flags" + If syncMode = 3 Then + StatusTableFake = &H80004005 + Exit Function + End If + statusRowsRead = False + table = VarPtr(statusTableObj) +End Function + +Public Function StatusColumnsFake(ByVal self As LongPtr, ByVal tags As LongPtr, ByVal flags As Long) As Long + If LongAt(tags) <> 3 Then + failure = "Status columns count": StatusColumnsFake = &H80004005 + Exit Function + End If + If LongAt(tags + 4) <> &HFFF0102 Or LongAt(tags + 8) <> &H3E030003 Or LongAt(tags + 12) <> &H3E020003 Then failure = "Status column tags" +End Function + +Public Function StatusRowsFake(ByVal self As LongPtr, ByVal requested As Long, ByVal flags As Long, ByRef rows As LongPtr) As Long + Dim props As LongPtr, entry As LongPtr, row As LongPtr, i As Long, kind As Long, methods As Long + On Error GoTo Failed + If MAPIAllocateBuffer(RO + SR * 2, rows) <> 0 Then GoTo Failed + PutLong rows, 0 + If statusRowsRead Then Exit Function + For i = 0 To 1 + If MAPIAllocateBuffer(SP * 3, props) <> 0 Then GoTo Failed + row = rows + RO + SR * i + PutLong row, 0: PutLong row + 4, 3: PutPtr row + 8, props + PutLong rows, i + 1 + If MAPIAllocateMore(4, props, entry) <> 0 Then GoTo Failed + PutLong entry, i + 1 + PutLong props, &HFFF0102: PutLong props + 8, 4: PutPtr props + 8 + PB, entry + kind = 36: methods = 8 + If syncMode = 0 And i = 1 Then kind = 37 + If syncMode = 2 Then + If i = 0 Then methods = 0 Else kind = 34 + End If + PutLong props + SP, &H3E030003: PutLong props + SP + 8, kind + PutLong props + SP * 2, &H3E020003: PutLong props + SP * 2 + 8, methods + Next + statusRowsRead = True + Exit Function +Failed: + failure = "Status rows callback": StatusRowsFake = &H80004005 +End Function + +Public Function OpenStatusFake(ByVal self As LongPtr, ByVal cb As Long, ByVal entry As LongPtr, ByVal iid As LongPtr, ByVal flags As Long, ByRef kind As Long, ByRef status As LongPtr) As Long + If cb <> 4 Or iid <> 0 Or flags <> 0 Then failure = "OpenEntry status arguments" + syncEntry = LongAt(entry) + kind = 10 + If wrongStatusType Then kind = 3 + status = VarPtr(statusObj) +End Function + +Public Function FlushFake(ByVal self As LongPtr, ByVal hwnd As LongPtr, ByVal cb As Long, ByVal entry As LongPtr, ByVal flags As Long) As Long + syncCalls = syncCalls + 1: syncFlags = flags + If hwnd <> 0 Or cb <> 0 Or entry <> 0 Then failure = "FlushQueues arguments" + If creates > 0 And (messageReleases <> 1 Or folderReleases <> 1) Then failure = "Flush before releasing submitted message" + If syncFail Then FlushFake = &H8004010B 'MAPI_E_BUSY +End Function + +Public Function OneOffFake(ByVal self As LongPtr, ByVal name As LongPtr, ByVal addressType As LongPtr, ByVal address As LongPtr, ByVal flags As Long, ByRef cb As Long, ByRef entry As LongPtr) As Long + On Error GoTo Failed + If TextAt(addressType) <> "SMTP" Or TextAt(address) <> TextAt(name) Or flags <> (&H80000000 Or &H10000) Then failure = "CreateOneOff arguments" + cb = 4 + OneOffFake = MAPIAllocateBuffer(cb, entry) + If OneOffFake = 0 Then PutLong entry, &H12345678 + Exit Function +Failed: + failure = "CreateOneOff callback": OneOffFake = &H80004005 +End Function + +Public Function StorePropertiesFake(ByVal self As LongPtr, ByVal tags As LongPtr, ByVal flags As Long, ByRef count As Long, ByRef props As LongPtr) As Long + Dim entry As LongPtr, i As Long + On Error GoTo Failed + count = LongAt(tags) + If count = 1 And LongAt(tags + 4) = &HFFF0102 Then + If MAPIAllocateBuffer(SP, props) <> 0 Then GoTo Failed + If MAPIAllocateMore(4, props, entry) <> 0 Then GoTo Failed + PutLong entry, 99 + PutLong props, &HFFF0102: PutLong props + 8, 4: PutPtr props + 8 + PB, entry + Exit Function + End If + If count <> 2 Or LongAt(tags + 4) <> &H35E20102 Or LongAt(tags + 8) <> &H35E40102 Then failure = "Outbox/Sent folder properties" + If MAPIAllocateBuffer(SP * 2, props) <> 0 Then GoTo Failed + For i = 0 To 1 + If MAPIAllocateMore(4, props, entry) <> 0 Then GoTo Failed + PutLong entry, i + 1 + PutLong props + i * SP, LongAt(tags + 4 + i * 4) + PutLong props + i * SP + 8, 4 + PutPtr props + i * SP + 8 + PB, entry + Next + Exit Function +Failed: + failure = "Store properties callback": StorePropertiesFake = &H80004005 +End Function + +Public Function OpenOutboxFake(ByVal self As LongPtr, ByVal cb As Long, ByVal entry As LongPtr, ByVal iid As LongPtr, ByVal flags As Long, ByRef kind As Long, ByRef folder As LongPtr) As Long + If cb <> 4 Or LongAt(entry) <> 1 Or iid <> 0 Or flags <> 1 Then failure = "Writable Outbox open" + kind = 3: folder = VarPtr(folderObj) +End Function + +Public Function CreateMessageFake(ByVal self As LongPtr, ByVal iid As LongPtr, ByVal flags As Long, ByRef message As LongPtr) As Long + If iid <> 0 Or flags <> 0 Then failure = "CreateMessage arguments" + creates = creates + 1: message = VarPtr(messageObj) +End Function + +Public Function SetPropertiesFake(ByVal self As LongPtr, ByVal count As Long, ByVal props As LongPtr, ByRef problems As LongPtr) As Long + Dim prop As LongPtr, length As Long, textPointer As LongPtr, chars As Long + On Error GoTo Failed + If count <> 6 Then failure = "Message property count" + If LongAt(props) <> &H1A001F Or TextAt(PtrAt(props + 8)) <> "IPM.Note" Then failure = "Message class" + capturedSubject = TextAt(PtrAt(props + SP + 8)) + prop = props + SP * 2 + capturedHTML = (LongAt(prop) = &H10130102) + If capturedHTML Then + length = LongAt(prop + 8): textPointer = PtrAt(prop + 8 + PB) + If length > 0 Then + chars = MultiByteToWideChar(65001, 8, textPointer, length, 0, 0) + capturedBody = String$(chars, vbNullChar) + MultiByteToWideChar 65001, 8, textPointer, length, StrPtr(capturedBody), chars + End If + Else + If LongAt(prop) <> &H1000001F Then failure = "Plain body tag" + capturedBody = TextAt(PtrAt(prop + 8)) + End If + prop = props + SP * 3 + If LongAt(prop) <> &HE0A0102 Or LongAt(prop + 8) <> 4 Or LongAt(PtrAt(prop + 8 + PB)) <> 2 Then failure = "Sent Items entry ID" + If LongAt(props + SP * 4 + 8) <> 8 Or LongAt(props + SP * 5 + 8) <> 65001 Then failure = "Message flags/code page" + If failStage = 1 Then SetPropertiesFake = &H80004005 + If failStage = 2 Then + If MAPIAllocateBuffer(16, problems) <> 0 Then GoTo Failed + PutLong problems, 1: PutLong problems + 4, 2 + PutLong problems + 8, &H1000001F: PutLong problems + 12, &H80070005 + End If + Exit Function +Failed: + failure = "SetProps callback": SetPropertiesFake = &H80004005 +End Function + +Public Function RecipientsFake(ByVal self As LongPtr, ByVal flags As Long, ByVal list As LongPtr) As Long + Dim row As LongPtr, props As LongPtr, i As Long + On Error GoTo Failed + If flags <> 2 Then failure = "ModifyRecipients flags" + recipientCount = LongAt(list) + For i = 0 To recipientCount - 1 + row = list + RO + i * SR: props = PtrAt(row + 8) + If LongAt(row + 4) <> 5 Then failure = "ADRENTRY property count" + recipientTypes = recipientTypes & LongAt(props + 8) + recipientAddresses = recipientAddresses & TextAt(PtrAt(props + SP * 3 + 8)) & ";" + If LongAt(props + SP * 4) <> &HFFF0102 Or LongAt(PtrAt(props + SP * 4 + 8 + PB)) <> &H12345678 Then failure = "Recipient one-off ID" + Next + If failStage = 3 Then RecipientsFake = &H80004005 + Exit Function +Failed: + failure = "Recipients callback": RecipientsFake = &H80004005 +End Function + +Public Function SubmitFake(ByVal self As LongPtr, ByVal flags As Long) As Long + submits = submits + 1 + If flags <> 0 Then failure = "Submit flags" + If failStage = 4 Then SubmitFake = &H80004005 +End Function + +Public Function NamedIDsFake(ByVal self As LongPtr, ByVal count As Long, ByVal names As LongPtr, ByVal flags As Long, ByRef tags As LongPtr) As Long + Dim name As LongPtr, guid As LongPtr + On Error GoTo Failed + name = PtrAt(names): guid = PtrAt(name) + If count <> 1 Or flags <> 0 Or LongAt(name + PB) <> 0 Or LongAt(name + PB * 2) <> expectedLid Then failure = "MAPINAMEID count/kind/LID/flags" + If LongAt(guid) <> &H62002 Or LongAt(guid + 4) <> 0 Or LongAt(guid + 8) <> &HC0 Or LongAt(guid + 12) <> &H46000000 Then failure = "Appointment GUID" + If MAPIAllocateBuffer(8, tags) <> 0 Then GoTo Failed + PutLong tags, 1 + If missingName Then + PutLong tags + 4, 10: NamedIDsFake = &H40380 + Else + PutLong tags + 4, &H90000000 + End If + Exit Function +Failed: + failure = "NamedIDs callback": NamedIDsFake = &H80004005 +End Function + +Public Function CalendarRestrictionFake(ByVal self As LongPtr, ByVal restriction As LongPtr, ByVal flags As Long) As Long + Dim children As LongPtr, child As LongPtr, prop As LongPtr, i As Long, expected As Variant + On Error GoTo Failed + restrictionCalls = restrictionCalls + 1 + If LongAt(restriction) <> 1 Or LongAt(restriction + RU) <> 3 Or flags <> 0 Then failure = "Calendar OR restriction" + children = PtrAt(restriction + RU + PB) + expected = Array(&H37001F, &H9000001F, &H42001F) + For i = 0 To 2 + child = children + RS * i: prop = PtrAt(child + RU + 8) + If LongAt(child) <> 3 Or LongAt(child + RU) <> &H10001 Or LongAt(child + RU + 4) <> expected(i) Then failure = "Calendar content restriction" + If LongAt(prop) <> expected(i) Or TextAt(PtrAt(prop + 8)) <> "planning" Then failure = "Calendar search value" + Next + Exit Function +Failed: + failure = "Calendar restriction callback": CalendarRestrictionFake = &H80004005 +End Function + +Private Function Address(ByVal pointer As LongPtr) As LongPtr + Address = pointer +End Function + +Public Function StoresTableFake(ByVal self As LongPtr, ByVal flags As Long, ByRef table As LongPtr) As Long + storeRowsRead = False + table = VarPtr(storesTableObj) +End Function + +Public Function StoreColumnsFake(ByVal self As LongPtr, ByVal tags As LongPtr, ByVal flags As Long) As Long + If LongAt(tags) <> 2 Or LongAt(tags + 4) <> &HFFF0102 Or LongAt(tags + 8) <> &H3400000B Then failure = "Default store columns" +End Function + +Public Function StoreRowsFake(ByVal self As LongPtr, ByVal requested As Long, ByVal flags As Long, ByRef rows As LongPtr) As Long + Dim props As LongPtr, entry As LongPtr, yes As Integer + On Error GoTo Failed + If MAPIAllocateBuffer(RO + SR, rows) <> 0 Then GoTo Failed + PutLong rows, 0 + If storeRowsRead Then Exit Function + If MAPIAllocateBuffer(SP * 2, props) <> 0 Then GoTo Failed + PutLong rows, 1: PutLong rows + RO, 0: PutLong rows + RO + 4, 2: PutPtr rows + RO + 8, props + If MAPIAllocateMore(4, props, entry) <> 0 Then GoTo Failed + PutLong entry, 99 + PutLong props, &HFFF0102: PutLong props + 8, 4: PutPtr props + 8 + PB, entry + PutLong props + SP, &H3400000B + yes = 1: CopyMemory ByVal props + SP + 8, yes, 2 + storeRowsRead = True + Exit Function +Failed: + failure = "Stores table callback": StoreRowsFake = &H80004005 +End Function + +Public Function OpenStoreFake(ByVal self As LongPtr, ByVal hwnd As LongPtr, ByVal cb As Long, ByVal entry As LongPtr, ByVal iid As LongPtr, ByVal flags As Long, ByRef store As LongPtr) As Long + If hwnd <> 0 Or cb <> 4 Or LongAt(entry) <> 99 Or iid <> 0 Or flags <> 5 Then failure = "MDB_NO_DIALOG | MDB_WRITE required" + writeOpens = writeOpens + 1 + If denyWrite Then + OpenStoreFake = &H80070005 + Else + store = VarPtr(storeObj) + End If +End Function + +Private Function LongAt(ByVal pointer As LongPtr) As Long + CopyMemory LongAt, ByVal pointer, 4 +End Function + +Private Function PtrAt(ByVal pointer As LongPtr) As LongPtr + CopyMemory PtrAt, ByVal pointer, PB +End Function + +Private Sub PutLong(ByVal pointer As LongPtr, ByVal value As Long) + CopyMemory ByVal pointer, value, 4 +End Sub + +Private Sub PutPtr(ByVal pointer As LongPtr, ByVal value As LongPtr) + CopyMemory ByVal pointer, value, PB +End Sub + +Private Function TextAt(ByVal pointer As LongPtr) As String + Dim length As Long + If pointer = 0 Then Exit Function + length = lstrlenW(pointer) + If length = 0 Then Exit Function + TextAt = String$(length, vbNullChar) + CopyMemory ByVal StrPtr(TextAt), ByVal pointer, length * 2 +End Function diff --git a/tests/harnesses/stdOutlook-tests/stdOutlookSyncFake.cls b/tests/harnesses/stdOutlook-tests/stdOutlookSyncFake.cls new file mode 100644 index 0000000..d528673 --- /dev/null +++ b/tests/harnesses/stdOutlook-tests/stdOutlookSyncFake.cls @@ -0,0 +1,69 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "stdOutlookSyncFake" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +Option Explicit + +'Test-only late-bound stand-in. Never attaches to the real Outlook application. +Public WindowCount As Long +Public Displays As Long +Public Requests As Long +Public ShowProgress As Boolean +Public FailSync As Boolean +Public FailInitialize As Boolean +Public InitializeCalls As Long +Public Order As String + +Public Function GetNamespace(ByVal name As String) As Object + If name <> "MAPI" Then Err.Raise 5, , "Wrong namespace" + Order = Order & "Namespace;" + Set GetNamespace = Me +End Function + +Public Function GetDefaultFolder(ByVal kind As Long) As Object + If kind <> 6 Then Err.Raise 5, , "Wrong initialization folder" + InitializeCalls = InitializeCalls + 1 + If FailInitialize Then Err.Raise 5, , "Synthetic initialization failure" + Order = Order & "Initialize;" + Set GetDefaultFolder = Me +End Function + +Public Property Get DefaultStore() As Object + Order = Order & "Store;" + Set DefaultStore = Me +End Property + +Public Property Get StoreID() As String + StoreID = "63000000" +End Property + +Public Property Get Explorers() As Object + Set Explorers = Me +End Property + +Public Property Get Count() As Long + Count = WindowCount +End Property + +Public Function GetExplorer() As Object + Set GetExplorer = Me +End Function + +Public Sub Display() + Displays = Displays + 1 + WindowCount = WindowCount + 1 + Order = Order & "Display;" +End Sub + +Public Sub SendAndReceive(ByVal showProgressDialog As Boolean) + Requests = Requests + 1 + ShowProgress = showProgressDialog + Order = Order & "Sync;" + stdOutlookSendCalendarTests.CheckSyncOrder + If FailSync Then Err.Raise 5, , "Synthetic synchronization failure" +End Sub diff --git a/tests/manifest.json b/tests/manifest.json index bbf209f..cb3fa31 100644 --- a/tests/manifest.json +++ b/tests/manifest.json @@ -642,6 +642,26 @@ ], "default": false, "requirements": "Excel, pywin32; instrumented IEnumVARIANT source" + }, + { + "id": "stdOutlook", + "kind": "command", + "command": "tests/harnesses/stdOutlook-tests/run.py", + "files": [ + "src/stdOutlook.cls", + "tests/stdOutlookTests.bas", + "tests/harnesses/stdOutlook-tests/stdOutlookSendCalendarTests.bas", + "tests/harnesses/stdOutlook-tests/stdOutlookSyncFake.cls", + "tests/support/Test.cls" + ], + "cases": { + "regressions": "regressions" + }, + "hosts": [ + "Excel" + ], + "default": false, + "requirements": "Windows VBA7, Excel, pywin32 and classic Outlook native MAPI; isolated synthetic transports only; no real sending or synchronization" } ] } diff --git a/tests/native/test_outlook_abi.py b/tests/native/test_outlook_abi.py new file mode 100644 index 0000000..f05f156 --- /dev/null +++ b/tests/native/test_outlook_abi.py @@ -0,0 +1,169 @@ +"""Check vtable slots against Microsoft headers and both native structure layouts. + +python tests/native/test_outlook_abi.py --download +python tests/native/test_outlook_abi.py --headers path/to/MAPIStubLibrary/include +Only --download accesses the network; downloaded blobs are verified by Git SHA. +""" +import argparse +import base64 +import ctypes as c +import hashlib +import json +from pathlib import Path +import re +import urllib.request + +ROOT = Path(__file__).resolve().parents[2] +BLOBS = { + "MAPIDefS.h": "73fd58cd08ea27d3595a94594a7e81b26660be80", + "MAPIX.h": "b7597f57c36e2cfd4273d980b204dbf310cda0df", +} + + +def read_headers(args): + result = {} + for name, sha in BLOBS.items(): + if args.download: + request = urllib.request.Request( + f"https://api.github.com/repos/microsoft/MAPIStubLibrary/git/blobs/{sha}", + headers={"User-Agent": "stdOutlook-ABI-check", "Accept": "application/vnd.github+json"}, + ) + with urllib.request.urlopen(request, timeout=30) as response: + data = base64.b64decode(json.load(response)["content"]) + digest = hashlib.sha1(b"blob " + str(len(data)).encode() + b"\0" + data).hexdigest() + if digest != sha: + raise RuntimeError(f"Git blob verification failed: {name}") + else: + data = (args.headers / name).read_bytes() + result[name] = data.decode("utf-8-sig") + return result + + +def methods(header, macro): + match = re.search(r"#define\s+" + macro + r"\(", header) + if not match: + raise AssertionError(f"Header macro missing: {macro}") + block = header[match.start():].split("#undef", 1)[0] + names = re.findall(r"MAPIMETHOD(?:_\(\w+,\s*|\()(\w+)\)", block) + if not names: + raise AssertionError(f"No methods in {macro}") + return names + + +def verify_slots(headers, source): + defs, ext = headers["MAPIDefS.h"], headers["MAPIX.h"] + unknown = methods(defs, "MAPI_IUNKNOWN_METHODS") + prop = unknown + methods(defs, "MAPI_IMAPIPROP_METHODS") + interfaces = { + "unknown": unknown, + "prop": prop, + "status": prop + methods(defs, "MAPI_IMAPISTATUS_METHODS"), + "message": prop + methods(defs, "MAPI_IMESSAGE_METHODS"), + "folder": prop + methods(defs, "MAPI_IMAPICONTAINER_METHODS") + methods(defs, "MAPI_IMAPIFOLDER_METHODS"), + "session": unknown + methods(ext, "MAPI_IMAPISESSION_METHODS"), + "book": prop + methods(ext, "MAPI_IADDRBOOK_METHODS"), + "container": prop + methods(defs, "MAPI_IMAPICONTAINER_METHODS"), + "store": prop + methods(defs, "MAPI_IMSGSTORE_METHODS"), + "table": unknown + methods(defs, "MAPI_IMAPITABLE_METHODS"), + } + targets = { + "VT_RELEASE": ("unknown", "Release"), + "VT_GET_PROPS": ("prop", "GetProps"), + "VT_SET_PROPS": ("prop", "SetProps"), + "VT_NAMED_IDS": ("prop", "GetIDsFromNames"), + "VT_AB_ONE_OFF": ("book", "CreateOneOff"), + "VT_FOLDER_CREATE_MESSAGE": ("folder", "CreateMessage"), + "VT_MESSAGE_RECIPIENTS": ("message", "ModifyRecipients"), + "VT_MESSAGE_SUBMIT": ("message", "SubmitMessage"), + "VT_SESSION_STORES": ("session", "GetMsgStoresTable"), + "VT_SESSION_OPEN_STORE": ("session", "OpenMsgStore"), + "VT_SESSION_ADDRESS_BOOK": ("session", "OpenAddressBook"), + "VT_SESSION_STATUS_TABLE": ("session", "GetStatusTable"), + "VT_SESSION_OPEN_ENTRY": ("session", "OpenEntry"), + "VT_SESSION_COMPARE_IDS": ("session", "CompareEntryIDs"), + "VT_STATUS_FLUSH": ("status", "FlushQueues"), + "VT_SESSION_IDENTITY": ("session", "QueryIdentity"), + "VT_AB_OPEN_ENTRY": ("book", "OpenEntry"), + "VT_CONTAINER_CONTENTS": ("container", "GetContentsTable"), + "VT_CONTAINER_HIERARCHY": ("container", "GetHierarchyTable"), + "VT_STORE_OPEN_ENTRY": ("store", "OpenEntry"), + "VT_STORE_RECEIVE_FOLDER": ("store", "GetReceiveFolder"), + "VT_TABLE_COLUMNS": ("table", "SetColumns"), + "VT_TABLE_RESTRICT": ("table", "Restrict"), + "VT_TABLE_SORT": ("table", "SortTable"), + "VT_TABLE_ROWS": ("table", "QueryRows"), + } + actual = dict(re.findall(r"Private Const (VT_\w+) As Long = (\d+)", source)) + assert set(actual) == set(targets), "Update ABI coverage when native methods change" + for constant, (interface, method) in targets.items(): + expected = interfaces[interface].index(method) + assert int(actual[constant]) == expected, f"{constant}: {actual[constant]} != {expected}" + print(f"PASS: {len(targets)} vtable slots match Microsoft's MAPI headers") + + +def verify_layouts(source): + # Explicit pointer-width fields let either Python architecture model both + # SDK layouts. This verifies layout, not execution in 32-bit Office. + block = source.split("#If Win64 Then", 1)[1].split("#End If", 1)[0] + for ptr, branch in zip((c.c_uint64, c.c_uint32), block.split("#Else")): + u32 = c.c_uint32 + + class Binary(c.Structure): + _fields_ = [("count", u32), ("pointer", ptr)] + + class Value(c.Union): + _fields_ = [("binary", Binary), ("number", c.c_double)] + + class Prop(c.Structure): + _fields_ = [("tag", u32), ("pad", u32), ("value", Value)] + + class Row(c.Structure): + _fields_ = [("pad", u32), ("count", u32), ("props", ptr)] + + class RowSet(c.Structure): + _fields_ = [("count", u32), ("rows", Row * 1)] + + class PropertyRestriction(c.Structure): + _fields_ = [("relop", u32), ("tag", u32), ("prop", ptr)] + + class CommentRestriction(c.Structure): + _fields_ = [("count", u32), ("restriction", ptr), ("prop", ptr)] + + class RestrictionUnion(c.Union): + _fields_ = [("property", PropertyRestriction), ("comment", CommentRestriction)] + + class Restriction(c.Structure): + _fields_ = [("kind", u32), ("value", RestrictionUnion)] + + class NameID(c.Structure): + _fields_ = [("guid", ptr), ("kind", u32), ("id_or_name", ptr)] + + expected = { + "PTR_BYTES": c.sizeof(ptr), "PROP_BYTES": c.sizeof(Prop), + "ROW_BYTES": c.sizeof(Row), "ROWSET_OFFSET": RowSet.rows.offset, + "RESTRICTION_BYTES": c.sizeof(Restriction), + "RESTRICTION_UNION": Restriction.value.offset, + "BINARY_POINTER_OFFSET": Binary.pointer.offset, + } + actual = {key: int(value) for key, value in re.findall(r"Private Const (\w+) As Long = (\d+)", branch)} + assert actual == expected, f"Native layout mismatch: {actual} != {expected}" + assert Prop.value.offset == 8 and Row.props.offset == 8 + assert PropertyRestriction.prop.offset == 8 + assert c.sizeof(NameID) == c.sizeof(ptr) * 3 + assert NameID.id_or_name.offset == c.sizeof(ptr) * 2 + print(f"PASS: {c.sizeof(ptr) * 8}-bit structure sizes and field offsets") + + +def main(): + parser = argparse.ArgumentParser(description=__doc__) + group = parser.add_mutually_exclusive_group(required=True) + group.add_argument("--download", action="store_true") + group.add_argument("--headers", type=Path) + args = parser.parse_args() + source = (ROOT / "src/stdOutlook.cls").read_text() + verify_slots(read_headers(args), source) + verify_layouts(source) + + +if __name__ == "__main__": + main() diff --git a/tests/stdOutlookTests.bas b/tests/stdOutlookTests.bas new file mode 100644 index 0000000..4bbcfcb --- /dev/null +++ b/tests/stdOutlookTests.bas @@ -0,0 +1,414 @@ +Attribute VB_Name = "stdOutlookTests" +Option Explicit +#Const LIVE_TEST = False + +Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal length As LongPtr) +Private Declare PtrSafe Function MAPIAllocateBuffer Lib "mapi32.dll" (ByVal size As Long, ByRef pointer As LongPtr) As Long +Private Declare PtrSafe Function MAPIAllocateMore Lib "mapi32.dll" (ByVal size As Long, ByVal parent As LongPtr, ByRef pointer As LongPtr) As Long +Private Declare PtrSafe Function MAPIInitialize Lib "mapi32.dll" (ByVal init As LongPtr) As Long +Private Declare PtrSafe Sub MAPIUninitialize Lib "mapi32.dll" () + +#If Win64 Then + Private Const PB As Long = 8 + Private Const SP As Long = 24 + Private Const SR As Long = 16 + Private Const RO As Long = 8 + Private Const RU As Long = 8 +#Else + Private Const PB As Long = 4 + Private Const SP As Long = 16 + Private Const SR As Long = 12 + Private Const RO As Long = 4 + Private Const RU As Long = 4 +#End If + +Private passed As Long +Private nextRow As Long +Private totalRows As Long +Private queryCalls As Long +Private releaseCalls As Long +Private restrictionCalls As Long +Private failQuery As Boolean +Private ansiRestriction As Boolean +Private callbackFailure As String +Private personMode As Long +Private personName As String +Private personSMTP As String +Private personLegacyDN As String +Private proxyAlias As String +Private proxyPrimary As String +Private proxyPointers(0 To 1) As LongPtr + +Public Function RunCase() As String + Dim client As stdOutlook, liveStatus As String, initialized As Boolean + On Error GoTo Failed + Set client = New stdOutlook + passed = 0 + Test.Refresh + Trace "lifecycle" + TestLifecycle client + Trace "properties" + TestProperties client + Trace "tables" + Assert MAPIInitialize(0) >= 0, "MAPI initialized for native allocator tests" + initialized = True + TestTables client + Trace "identity" + TestIdentity client + Trace "send and calendar" + passed = passed + stdOutlookSendCalendarTests.RunTests() + MAPIUninitialize + initialized = False + liveStatus = "not requested" +#If LIVE_TEST Then + liveStatus = LiveSmoke() +#End If + If Test.failures <> 0 Or Test.checks = 0 Then Err.Raise 5, "stdOutlookTests", "Missing or failed assertions: " & Test.lastCheck + RunCase = "{""status"":""passed"",""assertions"":" & passed & ",""live"":""" & EscapeJSON(liveStatus) & """}" + Exit Function +Failed: + RunCase = "{""status"":""failed"",""assertions"":" & passed & ",""error"":""" & EscapeJSON(Err.Source & ": " & Err.description & " (" & Err.Number & ")") & """}" + If initialized Then MAPIUninitialize +End Function + +Private Sub Assert(ByVal condition As Boolean, ByVal label As String) + Test.Assert label, condition + If Not condition Then Err.Raise vbObjectError + 2001, "stdOutlookTests", label + passed = passed + 1 + Trace "PASS " & label +End Sub + +Private Sub Trace(ByVal label As String) + Dim file As Integer, path As String + path = Environ$("STDOUTLOOK_TEST_PROGRESS") + If Len(path) = 0 Then Exit Sub + file = FreeFile + Open path For Append As #file + Print #file, label + Close #file +End Sub + +Private Sub TestLifecycle(ByVal client As stdOutlook) + Dim unused As Collection, number As Long + Assert Not client.IsOpen, "New client must be closed" + client.Disconnect + client.Disconnect + Assert Not client.IsOpen, "Disconnect is idempotent" + On Error Resume Next + Set unused = client.CurrentUser() + number = Err.Number + On Error GoTo 0 + Assert number = 91, "Closed client read fails cleanly" + On Error Resume Next + Set unused = client.SearchContacts(" ") + number = Err.Number + On Error GoTo 0 + Assert number = 5, "Empty search rejected" + On Error Resume Next + Set unused = client.SearchContacts("name", 0) + number = Err.Number + On Error GoTo 0 + Assert number = 5, "Zero limit rejected" + Assert client.TestEntryID("00aB10FF") = "00AB10FF", "Binary entry ID round trip" + On Error Resume Next + client.TestEntryID "1G" + number = Err.Number + On Error GoTo 0 + Assert number = 5, "Nonhex ID rejected" + On Error Resume Next + client.TestEntryID "123" + number = Err.Number + On Error GoTo 0 + Assert number = 5, "Odd ID rejected" +End Sub + +Private Sub TestProperties(ByVal client As stdOutlook) + Dim props(0 To SP * 3 - 1) As Byte, pointer As LongPtr, text As String + Dim ansi() As Byte, value As Variant, record As Collection, errors As Collection + Dim binary(0 To 3) As Byte, small As Integer, fileTime As Currency + Dim pointers(0 To 1) As LongPtr, other As String + pointer = VarPtr(props(0)) + text = "Zo" & ChrW$(&HEB) & " " & ChrW$(&H6771) & ChrW$(&H4EAC) + PutLong pointer, &H3001001F + PutPtr pointer + 8, StrPtr(text) + Assert client.TestDecode(pointer) = text, "Unicode including non-Latin characters" + ansi = StrConv("ANSI text" & vbNullChar, vbFromUnicode) + PutLong pointer, &H3001001E + PutPtr pointer + 8, VarPtr(ansi(0)) + Assert client.TestDecode(pointer) = "ANSI text", "ANSI string conversion" + PutLong pointer, &H3001001F + PutPtr pointer + 8, 0 + Assert client.TestDecode(pointer) = "", "Null string pointer" + PutLong pointer, &H30000003 + PutLong pointer + 8, -123456 + Assert client.TestDecode(pointer) = -123456, "Signed native Long" + PutLong pointer, &HE1B000B + small = 1 + CopyMemory ByVal pointer + 8, small, 2 + Assert client.TestDecode(pointer) = True, "Native boolean width" + binary(0) = 0: binary(1) = 1: binary(2) = 128: binary(3) = 255 + PutLong pointer, &HFFF0102 + PutLong pointer + 8, 4 + PutPtr pointer + 8 + PB, VarPtr(binary(0)) + Assert client.TestDecode(pointer) = "000180FF", "SBinary native pointer alignment" + PutLong pointer, &HE060040 + fileTime = 13348540800000@ '2024-01-01 UTC, raw FILETIME ticks / 10000 + CopyMemory ByVal pointer + 8, fileTime, 8 + Assert client.TestDecode(pointer) = DateSerial(2024, 1, 1), "FILETIME converted as UTC" + other = "SMTP:person@example.test" + pointers(0) = StrPtr(text): pointers(1) = StrPtr(other) + PutLong pointer, &H800F101F + PutLong pointer + 8, 2 + PutPtr pointer + 8 + PB, VarPtr(pointers(0)) + value = client.TestDecode(pointer) + Assert value(0) = text And value(1) = other, "Multivalue string alignment" + PutLong pointer + 8, 0 + value = client.TestDecode(pointer) + Assert IsArray(value), "Empty multivalue property" + PutLong pointer, &H3001001F + PutPtr pointer + 8, StrPtr(text) + PutLong pointer + SP, &H39FE000A + PutLong pointer + SP + 8, &H8004010F + PutLong pointer + SP * 2, &HFFE0003 + PutLong pointer + SP * 2 + 8, 6 + Set record = client.TestProperties(pointer, 3, Array(Array("Name", &H3001001F), Array("SMTP", &H39FE001F), Array("Kind", &HFFE0003))) + Set errors = record("PropertyErrors") + Assert record("Name") = text And record("Kind") = 6, "SPropValue stride" + Assert IsEmpty(record("SMTP")), "Missing property is Empty" + Assert errors("SMTP") = &H8004010F, "Partial property error preserved" +End Sub + +Private Sub TestTables(ByVal client As stdOutlook) + Dim vt(0 To 19) As LongPtr, instance As LongPtr, pointer As LongPtr + Dim rows As Collection, capped As Boolean, row As Collection, number As Long + vt(2) = Address(AddressOf FakeRelease) + vt(7) = Address(AddressOf FakeColumns) + vt(14) = Address(AddressOf FakeRestrict) + vt(19) = Address(AddressOf FakeQueryRows) + instance = VarPtr(vt(0)): pointer = VarPtr(instance) + nextRow = 0: totalRows = 5: queryCalls = 0: failQuery = False: callbackFailure = "" + Set rows = client.TestTable(pointer, 10, capped) + Assert callbackFailure = "", "Native callback: " & callbackFailure + Assert rows.Count = 5 And Not capped, "Pagination continues after short pages" + Assert queryCalls = 4, "QueryRows called until zero rows" + Set row = rows(5) + Assert row("Number") = 4 And row("Text") = "row-4", "Rows copied before native buffers freed" + nextRow = 0: queryCalls = 0 + Set rows = client.TestTable(pointer, 3, capped) + Assert rows.Count = 3 And capped, "Result cap detects an extra row" + nextRow = 0: totalRows = 3 + Set rows = client.TestTable(pointer, 3, capped) + Assert rows.Count = 3 And Not capped, "Exactly full table is not truncated" + nextRow = 0: totalRows = 0 + Set rows = client.TestTable(pointer, 3, capped) + Assert rows.Count = 0 And Not capped, "Empty table" + failQuery = True + On Error Resume Next + Set rows = client.TestTable(pointer, 3, capped) + number = Err.Number + On Error GoTo 0 + Assert number = &H80004005, "Native HRESULT propagated" + failQuery = False + restrictionCalls = 0: ansiRestriction = False + client.TestRestriction pointer, "Ada" + Assert restrictionCalls = 1 And callbackFailure = "", "Unicode ANR native structure" + restrictionCalls = 0: ansiRestriction = True + client.TestRestriction pointer, "Ada" + Assert restrictionCalls = 2 And callbackFailure = "", "ANSI restriction fallback" + releaseCalls = 0 + client.TestRelease pointer + Assert pointer = 0 And releaseCalls = 1, "Release once, zero owned pointer" + client.TestRelease pointer + Assert releaseCalls = 1, "Repeated Release is a no-op" +End Sub + +Private Sub TestIdentity(ByVal client As stdOutlook) + Dim vt(0 To 5) As LongPtr, instance As LongPtr, person As Collection + vt(5) = Address(AddressOf FakeGetProps) + instance = VarPtr(vt(0)) + personName = "Ada Example": personSMTP = "ada@example.test" + personLegacyDN = "/o=Example/ou=People/cn=Ada" + proxyAlias = "smtp:alias@example.test": proxyPrimary = "SMTP:primary@example.test" + proxyPointers(0) = StrPtr(proxyAlias): proxyPointers(1) = StrPtr(proxyPrimary) + personMode = 0 + Set person = client.TestPerson(VarPtr(instance)) + Assert person("Email") = personSMTP, "PR_SMTP_ADDRESS preferred" + personMode = 1 + Set person = client.TestPerson(VarPtr(instance)) + Assert person("Email") = "primary@example.test", "Uppercase primary proxy selected over alias" + personMode = 2 + Set person = client.TestPerson(VarPtr(instance)) + Assert person("Email") = "", "Exchange legacy DN never returned as SMTP" + Assert person("EmailAddress") = personLegacyDN, "Raw Exchange address preserved" + Assert callbackFailure = "", "GetProps ABI and unspecified string tags" +End Sub + +'Native callbacks must not unwind VBA errors across the unmanaged boundary. +Public Function FakeColumns(ByVal self As LongPtr, ByVal tags As LongPtr, ByVal flags As Long) As Long + Trace "FakeColumns tags=" & GetLong(tags) & "; flags=" & flags + If GetLong(tags) <> 2 Or GetLong(tags + 4) <> &H30000003 Or GetLong(tags + 8) <> &H3001001F Or flags <> 0 Then + callbackFailure = "SetColumns argument layout" + FakeColumns = &H80070057 + End If +End Function + +Public Function FakeQueryRows(ByVal self As LongPtr, ByVal requested As Long, ByVal flags As Long, ByRef rows As LongPtr) As Long + Dim count As Long, i As Long, props As LongPtr, row As LongPtr, text As String, buffer As LongPtr + On Error GoTo Failed + queryCalls = queryCalls + 1 + Trace "FakeQueryRows call=" & queryCalls & "; requested=" & requested & "; next=" & nextRow + If queryCalls > 10 Then FakeQueryRows = &H80004005: Exit Function + If failQuery Then FakeQueryRows = &H80004005: Exit Function + count = totalRows - nextRow + If count > 2 Then count = 2 + If count > requested Then count = requested + If MAPIAllocateBuffer(RO + count * SR, rows) <> 0 Then GoTo Failed + PutLong rows, count + For i = 0 To count - 1 + If MAPIAllocateBuffer(SP * 2, props) <> 0 Then GoTo Failed + row = rows + RO + i * SR + PutLong row, 0: PutLong row + 4, 2: PutPtr row + 8, props + PutLong props, &H30000003: PutLong props + 8, nextRow + text = "row-" & CStr(nextRow) + If MAPIAllocateMore((Len(text) + 1) * 2, props, buffer) <> 0 Then GoTo Failed + CopyMemory ByVal buffer, ByVal StrPtr(text), (Len(text) + 1) * 2 + PutLong props + SP, &H3001001F: PutPtr props + SP + 8, buffer + nextRow = nextRow + 1 + Next + Exit Function +Failed: + callbackFailure = "QueryRows allocation/callback failed" + FakeQueryRows = &H80004005 +End Function + +Public Function FakeRestrict(ByVal self As LongPtr, ByVal restriction As LongPtr, ByVal flags As Long) As Long + Dim prop As LongPtr, expectedTag As Long + restrictionCalls = restrictionCalls + 1 + expectedTag = &H360C001F + If ansiRestriction And restrictionCalls = 2 Then expectedTag = &H360C001E + prop = GetPtr(restriction + RU + 8) + If GetLong(restriction) <> 4 Or GetLong(restriction + RU) <> 4 Or GetLong(restriction + RU + 4) <> expectedTag Or GetLong(prop) <> expectedTag Or flags <> 0 Then + callbackFailure = "Restriction layout" + FakeRestrict = &H80070057 + Exit Function + End If + If ansiRestriction And restrictionCalls = 1 Then FakeRestrict = &H80040103 +End Function + +Public Function FakeRelease(ByVal self As LongPtr) As Long + releaseCalls = releaseCalls + 1 + FakeRelease = 0 +End Function + +Public Function FakeGetProps(ByVal self As LongPtr, ByVal tags As LongPtr, ByVal flags As Long, ByRef count As Long, ByRef props As LongPtr) As Long + Dim i As Long, tag As Long, prop As LongPtr, addrType As String + On Error GoTo Failed + count = GetLong(tags) + If count <> 16 Or flags <> &H80000000 Then callbackFailure = "GetProps arguments" + If MAPIAllocateBuffer(count * SP, props) <> 0 Then GoTo Failed + For i = 0 To count - 1 + tag = GetLong(tags + 4 + i * 4) + prop = props + i * SP + PutLong prop, (tag And &HFFFF0000) Or 10 + PutLong prop + 8, &H8004010F + Select Case tag And &HFFFF0000 + Case &H30010000 + If (tag And &HFFFF&) <> 0 Then callbackFailure = "Expected PT_UNSPECIFIED for strings" + PutLong prop, &H3001001F: PutPtr prop + 8, StrPtr(personName) + Case &H30030000 + PutLong prop, &H3003001F: PutPtr prop + 8, StrPtr(personLegacyDN) + Case &H39FE0000 + If personMode = 0 Then PutLong prop, &H39FE001F: PutPtr prop + 8, StrPtr(personSMTP) + Case &H800F0000 + If personMode = 1 Then + PutLong prop, &H800F101F: PutLong prop + 8, 2: PutPtr prop + 8 + PB, VarPtr(proxyPointers(0)) + End If + End Select + Next + FakeGetProps = &H40380 'MAPI_W_ERRORS_RETURNED is success with per-property errors + Exit Function +Failed: + callbackFailure = "GetProps callback failed" + FakeGetProps = &H80004005 +End Function + +Private Function LiveSmoke() As String + Dim client As stdOutlook, other As stdOutlook, person As Collection + Dim books As Collection, matches As Collection, messages As Collection, message As Collection + Dim calendar As Collection, appointment As Collection, calendarMatches As Collection + Dim identityError As Long, id As String, query As String, matchCount As Long + On Error GoTo Unavailable + Set client = stdOutlook.Create() + Set other = stdOutlook.Create() + Assert client.IsOpen And other.IsOpen, "Two native sessions" + other.Disconnect + Assert Not other.IsOpen, "Native session Close actually releases state" + Set books = client.AddressBooks() + On Error Resume Next + Set person = client.CurrentUser() + identityError = Err.Number + On Error GoTo Unavailable + If identityError = 0 Then + Assert Len(client.CurrentUserEmail) > 0, "Live identity supplies an SMTP address" + Assert client.CurrentUserEmail = person("Email"), "CurrentUserEmail agrees with identity record" + query = CStr(person("DisplayName")) + If Len(query) > 0 Then + Set matches = client.SearchContacts(query, 3) + Assert client.SearchWarnings.Count = 0, "Live contact search reported provider failures" + matchCount = matches.Count + Assert matchCount > 0, "Live identity is found by name search" + End If + End If + Set messages = client.Inbox(1) + If messages.Count > 0 Then + Set message = messages(1) + Set message = client.ReadMessage(CStr(message("EntryID"))) + End If + Set calendar = client.SearchCalendar("", 1) + Assert calendar.Count <= 1, "Live calendar limit honored" + If calendar.Count > 0 Then + Set appointment = calendar(1) + Assert appointment("RecurrenceExpanded") = False, "Calendar recurrence semantics explicit" + If Len(CStr(appointment("Subject"))) > 0 Then + Set calendarMatches = client.SearchCalendar(CStr(appointment("Subject")), 3) + Assert calendarMatches.Count > 0, "Live calendar subject search finds stored appointment" + End If + End If + client.Disconnect + Assert Not client.IsOpen, "Close releases native session" + client.OpenProfile + Assert client.IsOpen, "Profile can reopen" + client.Disconnect + LiveSmoke = "passed; address books=" & books.Count & "; contact matches=" & matchCount & "; inbox sample=" & messages.Count & "; calendar sample=" & calendar.Count & "; identity HRESULT=0x" & Hex$(identityError) + Exit Function +Unavailable: + Dim number As Long, description As String + number = Err.Number: description = Err.description + If Not client Is Nothing Then client.Disconnect + If Not other Is Nothing Then other.Disconnect + Err.Raise number, "LiveSmoke", description +End Function + +Private Function Address(ByVal pointer As LongPtr) As LongPtr + Address = pointer +End Function + +Private Sub PutLong(ByVal pointer As LongPtr, ByVal value As Long) + CopyMemory ByVal pointer, value, 4 +End Sub + +Private Sub PutPtr(ByVal pointer As LongPtr, ByVal value As LongPtr) + CopyMemory ByVal pointer, value, PB +End Sub + +Private Function GetLong(ByVal pointer As LongPtr) As Long + CopyMemory GetLong, ByVal pointer, 4 +End Function + +Private Function GetPtr(ByVal pointer As LongPtr) As LongPtr + CopyMemory GetPtr, ByVal pointer, PB +End Function + +Private Function EscapeJSON(ByVal value As String) As String + EscapeJSON = Replace(Replace(Replace(Replace(value, "\", "\\"), """", "\"""), vbCr, "\r"), vbLf, "\n") +End Function From 4b8ca53670d4c4bb93d562a3175272627fe18c5c Mon Sep 17 00:00:00 2001 From: Sancarn Date: Tue, 10 Nov 2026 19:07:09 +0000 Subject: [PATCH 2/5] Reference stdOutlook contribution in changelog --- changelog.md | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/changelog.md b/changelog.md index 43d8eef..48b5ddc 100644 --- a/changelog.md +++ b/changelog.md @@ -485,6 +485,6 @@ The 2025-2026 entries were audited retrospectively against commits through `1bcb - 2026-11-01 `stdLambda` BREAKING - Remove the production test-only protRunVMTests member and its private test helpers. Developers calling stdLambda.protRunVMTests must instead run `python Tools/Testing/run.py --suite stdLambda.vm --test Instructions`; the runner injects tests from tests/support into a disposable class copy. Normal Lambda evaluation APIs, defaults and callback contracts are unchanged. - 2026-11-01 `Tools/Testing` BREAKING - Remove the separate Tools/stdCallback-tests, stdDate-test, stdHTTP-tests, stdImage-tests stdWebSocket-tests and stdEnumerator-tests command folders. Maintainer scripts invoking those paths must migrate to `python Tools/Testing/run.py --suite `: stdCallback.probes, stdDate, stdHTTP.local, stdImage stdWebSocket.local or stdEnumerator.local respectively. Image host selection is now `--host Excel` or `--host Word` through the shared command (formerly `--hosts`). Test bodies and specialized harnesses now live under tests/harnesses. -- 2026-11-10 `stdOutlook` WIP - Add a standalone Windows VBA7 class for classic Outlook profile identity, address-book contact search, Inbox/message reads and default-calendar text search through Extended MAPI. Uses predeclared Create/protInit construction, TThis state and structured documentation; 32-bit execution and provider coverage remain experimental. Existing stdVBA APIs are unchanged. -- 2026-11-10 `stdOutlook` WIP - Add plain-text and UTF-8 HTML submission with To/CC/BCC and Sent Items copies, native queue flushing, and default late-bound Outlook Send/Receive synchronization. Validate matching stores, keep Outlook available for asynchronous transfer, and report sync errors separately without resubmitting queued mail. Live automatic synchronization/delivery is not validated by tests; calendar recurrences are not expanded. -- 2026-11-10 `stdOutlook-tests` DEV - Register isolated Excel regression tests with synthetic native interfaces and Outlook automation, shared assertion reporting, modal-dialog deadlines and exact VBE settings restoration. Add native ABI checks for 25 vtable slots and both pointer widths, plus opt-in read-only live checks. Tests never submit or synchronize real mail. +- 2026-11-10 `stdOutlook` WIP - Add a standalone Windows VBA7 class for classic Outlook profile identity, address-book contact search, Inbox/message reads and default-calendar text search through Extended MAPI. Uses predeclared Create/protInit construction, TThis state and structured documentation; 32-bit execution and provider coverage remain experimental. Existing stdVBA APIs are unchanged. (#189) +- 2026-11-10 `stdOutlook` WIP - Add plain-text and UTF-8 HTML submission with To/CC/BCC and Sent Items copies, native queue flushing, and default late-bound Outlook Send/Receive synchronization. Validate matching stores, keep Outlook available for asynchronous transfer, and report sync errors separately without resubmitting queued mail. Live automatic synchronization/delivery is not validated by tests; calendar recurrences are not expanded. (#189) +- 2026-11-10 `stdOutlook-tests` DEV - Register isolated Excel regression tests with synthetic native interfaces and Outlook automation, shared assertion reporting, modal-dialog deadlines and exact VBE settings restoration. Add native ABI checks for 25 vtable slots and both pointer widths, plus opt-in read-only live checks. Tests never submit or synchronize real mail. (#189) From 90b4bf626acdb1d4dbd1aabd0f081510fc156be7 Mon Sep 17 00:00:00 2001 From: Sancarn Date: Tue, 10 Nov 2026 22:06:50 +0000 Subject: [PATCH 3/5] Remove separate stdOutlook tests changelog entry --- changelog.md | 1 - 1 file changed, 1 deletion(-) diff --git a/changelog.md b/changelog.md index 48b5ddc..c80a8a2 100644 --- a/changelog.md +++ b/changelog.md @@ -487,4 +487,3 @@ The 2025-2026 entries were audited retrospectively against commits through `1bcb - 2026-11-10 `stdOutlook` WIP - Add a standalone Windows VBA7 class for classic Outlook profile identity, address-book contact search, Inbox/message reads and default-calendar text search through Extended MAPI. Uses predeclared Create/protInit construction, TThis state and structured documentation; 32-bit execution and provider coverage remain experimental. Existing stdVBA APIs are unchanged. (#189) - 2026-11-10 `stdOutlook` WIP - Add plain-text and UTF-8 HTML submission with To/CC/BCC and Sent Items copies, native queue flushing, and default late-bound Outlook Send/Receive synchronization. Validate matching stores, keep Outlook available for asynchronous transfer, and report sync errors separately without resubmitting queued mail. Live automatic synchronization/delivery is not validated by tests; calendar recurrences are not expanded. (#189) -- 2026-11-10 `stdOutlook-tests` DEV - Register isolated Excel regression tests with synthetic native interfaces and Outlook automation, shared assertion reporting, modal-dialog deadlines and exact VBE settings restoration. Add native ABI checks for 25 vtable slots and both pointer widths, plus opt-in read-only live checks. Tests never submit or synchronize real mail. (#189) From 778094eeff4246137878729d72cf607309565447 Mon Sep 17 00:00:00 2001 From: Sancarn Date: Tue, 10 Nov 2026 22:07:10 +0000 Subject: [PATCH 4/5] Label stdOutlook additions as features in changelog --- changelog.md | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/changelog.md b/changelog.md index c80a8a2..c990a5c 100644 --- a/changelog.md +++ b/changelog.md @@ -485,5 +485,5 @@ The 2025-2026 entries were audited retrospectively against commits through `1bcb - 2026-11-01 `stdLambda` BREAKING - Remove the production test-only protRunVMTests member and its private test helpers. Developers calling stdLambda.protRunVMTests must instead run `python Tools/Testing/run.py --suite stdLambda.vm --test Instructions`; the runner injects tests from tests/support into a disposable class copy. Normal Lambda evaluation APIs, defaults and callback contracts are unchanged. - 2026-11-01 `Tools/Testing` BREAKING - Remove the separate Tools/stdCallback-tests, stdDate-test, stdHTTP-tests, stdImage-tests stdWebSocket-tests and stdEnumerator-tests command folders. Maintainer scripts invoking those paths must migrate to `python Tools/Testing/run.py --suite `: stdCallback.probes, stdDate, stdHTTP.local, stdImage stdWebSocket.local or stdEnumerator.local respectively. Image host selection is now `--host Excel` or `--host Word` through the shared command (formerly `--hosts`). Test bodies and specialized harnesses now live under tests/harnesses. -- 2026-11-10 `stdOutlook` WIP - Add a standalone Windows VBA7 class for classic Outlook profile identity, address-book contact search, Inbox/message reads and default-calendar text search through Extended MAPI. Uses predeclared Create/protInit construction, TThis state and structured documentation; 32-bit execution and provider coverage remain experimental. Existing stdVBA APIs are unchanged. (#189) -- 2026-11-10 `stdOutlook` WIP - Add plain-text and UTF-8 HTML submission with To/CC/BCC and Sent Items copies, native queue flushing, and default late-bound Outlook Send/Receive synchronization. Validate matching stores, keep Outlook available for asynchronous transfer, and report sync errors separately without resubmitting queued mail. Live automatic synchronization/delivery is not validated by tests; calendar recurrences are not expanded. (#189) +- 2026-11-10 `stdOutlook` FEATURE - Add a standalone Windows VBA7 class for classic Outlook profile identity, address-book contact search, Inbox/message reads and default-calendar text search through Extended MAPI. Uses predeclared Create/protInit construction, TThis state and structured documentation; 32-bit execution and provider coverage remain experimental. Existing stdVBA APIs are unchanged. (#189) +- 2026-11-10 `stdOutlook` FEATURE - Add plain-text and UTF-8 HTML submission with To/CC/BCC and Sent Items copies, native queue flushing, and default late-bound Outlook Send/Receive synchronization. Validate matching stores, keep Outlook available for asynchronous transfer, and report sync errors separately without resubmitting queued mail. Live automatic synchronization/delivery is not validated by tests; calendar recurrences are not expanded. (#189) From c8a8c2d9945358a76236498383a6e59a8f34b536 Mon Sep 17 00:00:00 2001 From: Sancarn Date: Tue, 10 Nov 2026 22:07:56 +0000 Subject: [PATCH 5/5] Condense stdOutlook changelog entry --- changelog.md | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/changelog.md b/changelog.md index c990a5c..72ffc31 100644 --- a/changelog.md +++ b/changelog.md @@ -485,5 +485,4 @@ The 2025-2026 entries were audited retrospectively against commits through `1bcb - 2026-11-01 `stdLambda` BREAKING - Remove the production test-only protRunVMTests member and its private test helpers. Developers calling stdLambda.protRunVMTests must instead run `python Tools/Testing/run.py --suite stdLambda.vm --test Instructions`; the runner injects tests from tests/support into a disposable class copy. Normal Lambda evaluation APIs, defaults and callback contracts are unchanged. - 2026-11-01 `Tools/Testing` BREAKING - Remove the separate Tools/stdCallback-tests, stdDate-test, stdHTTP-tests, stdImage-tests stdWebSocket-tests and stdEnumerator-tests command folders. Maintainer scripts invoking those paths must migrate to `python Tools/Testing/run.py --suite `: stdCallback.probes, stdDate, stdHTTP.local, stdImage stdWebSocket.local or stdEnumerator.local respectively. Image host selection is now `--host Excel` or `--host Word` through the shared command (formerly `--hosts`). Test bodies and specialized harnesses now live under tests/harnesses. -- 2026-11-10 `stdOutlook` FEATURE - Add a standalone Windows VBA7 class for classic Outlook profile identity, address-book contact search, Inbox/message reads and default-calendar text search through Extended MAPI. Uses predeclared Create/protInit construction, TThis state and structured documentation; 32-bit execution and provider coverage remain experimental. Existing stdVBA APIs are unchanged. (#189) -- 2026-11-10 `stdOutlook` FEATURE - Add plain-text and UTF-8 HTML submission with To/CC/BCC and Sent Items copies, native queue flushing, and default late-bound Outlook Send/Receive synchronization. Validate matching stores, keep Outlook available for asynchronous transfer, and report sync errors separately without resubmitting queued mail. Live automatic synchronization/delivery is not validated by tests; calendar recurrences are not expanded. (#189) +- 2026-11-10 `stdOutlook` FEATURE - Add a standalone Windows VBA7 class for classic Outlook identity, contacts, mail and calendar access through Extended MAPI, with plain-text/HTML email submission and Outlook Send/Receive synchronization. (#189)