;; @module winscript
;; @description Embedded VBScript/JScript in newLISP.
;; @version 0.23
;; @author m35
;;
;; @location http://www.autohotkey.net/~easycom/winscript.lsp
;;
;; http://www.autohotkey.net/~easycom/winscript.lsp
;; This module uses the COM/OLE Microsoft Scripting Control object to execute
;; VBScript or JScript. Most computers have it installed by default. It can
;; also be downloaded directly from Microsoft.
;;
;; http://www.microsoft.com/downloads/details.aspx?FamilyId=D7E31492-2595-49E6-8C02-1426FEC693AC
;;
;; Change log:
;;
;; 0.10 - Initial release.
;;
;; 0.11 - Fixed memory leak when unhandled type is returned.
;; Improved get-short and get-single functions.
;;
;; 0.12 - Fixed handling of automation errors.
;;
;; 0.20 - Large internal changes to properly handle errors. This fixes
;; memory leaks and provides more comprehensive error information.
;; Added '(WINSCRIPT:LastResult)' function to return the results of
;; win32api calls.
;;
;; 0.21 - Added missing cleanup if failure during initialization.
;;
;; 0.22 - Minor documentation improvements.
;; Added check at initialization if already initialized.
;; Fixed error handling when the error doesn't come from the script control.
;; Lots of internal cleaning and comments.
;;
;; 0.23 - changed import type constant 265 to 2312 as required since 10.4.0 , L.M.
;;
;; Tested with newLISP 9.2.0 and 9.4.3.
;;
;; Contact me (m35) in the newLISP Fan Club forum
;; @link http://www.alh.net/newlisp/phpbb/viewtopic.php?t=1983
;; http://www.alh.net/newlisp/phpbb/viewtopic.php?t=1983
;;
;; A good list of automation error descriptions can be found in
;; @link http://support.microsoft.com/kb/186063 KB186063
;; @example
;; > (WINSCRIPT:Initialize)
;; true
;; > (WINSCRIPT:Exec {foo = "bar"})
;; true
;; > (WINSCRIPT:Eval {foo})
;; "bar"
;; > (WINSCRIPT:Uninitialize)
;; true
;; @example
;; > (WINSCRIPT:Initialize "VBScript")
;; true
;; > (WINSCRIPT:Exec {Set oSp = CreateObject("SAPI.SpVoice")})
;; true
;; > (WINSCRIPT:Exec {oSp.Speak "newLISP: Puts the fun back in LISP"})
;; true
;; @example
;; ; this example requires Microsoft Excel to be installed.
;; > (WINSCRIPT:Initialize)
;; true
;; > (WINSCRIPT:Exec {Set xl = CreateObject("Excel.Application")})
;; true
;; > (WINSCRIPT:Exec {xl.Visible = True})
;; true
;; > (WINSCRIPT:Exec {Set rng = xl.Workbooks.Add().Worksheets(1).Cells(1, 1)})
;; true
;; > (WINSCRIPT:Exec {rng.Value = 1.2345})
;; true
;; > (WINSCRIPT:Eval {rng.Value})
;; 1.2345
;; > (WINSCRIPT:Exec {xl.DisplayAlerts = False})
;; true
;; > (WINSCRIPT:Exec {xl.Quit})
;; true
;; > (WINSCRIPT:Uninitialize)
;; true
(context 'WINSCRIPT)
(constant 'IID_IDispatch "{00020400-0000-0000-C000-000000000046}" )
(constant 'IID_IUnknown "{00000000-0000-0000-C000-000000000046}" )
(constant 'ProgId_ScriptControl "MSScriptControl.ScriptControl" )
(constant 'CLSID_ScriptControl "{0E59F1D5-1FBE-11D0-8FF2-00A0D10038BC}" )
(constant 'IID_ScriptControl "{0E59F1D3-1FBE-11D0-8FF2-00A0D10038BC}" )
(constant 'CLSCTX_INPROC_SERVER 1 )
(constant 'CLSCTX_INPROC_HANDLER 2 )
(constant 'CLSCTX_LOCAL_SERVER 4 )
(constant 'CLSCTX_INPROC_SERVER16 8 )
(constant 'CLSCTX_REMOTE_SERVER 16 )
(define __iScriptControlObj__ nil)
(define __iScriptErrorObj__ nil)
(define __sScriptLanguage__ nil)
(define __LastResult__ '())
;; @syntax (WINSCRIPT:Initialize [<str-language>="VBScript"])
;; @param <str-language> either '"VBScript"' or '"JScript"'
;; @return true on success, '(throw-error)' on error
;; Initializes the scripting environment. Must be called before any other
;; functions can be used.
;;
;; If the scripting environment has already been initialized,
;; this function does nothing.
(define (Initialize (sLanguage "VBScript")
, @iCoInit @iScriptCtrl @iScriptErr @xLangRet)
; Check if already initialized
(if (not (and (integer? __iScriptControlObj__) (!= __iScriptControlObj__ 0)))
(begin
; initialize COM
(setq @iCoInit (_CoInitialize))
(if (failed? @iCoInit)
(throw-error (last (setq __LastResult__
(err-msg @iCoInit)
)))
)
; create a scripting control
(setq @iScriptCtrl (__CreateObjectProgId ProgId_ScriptControl IID_ScriptControl))
(if (failed? @iScriptCtrl) (begin
(Uninitialize)
(throw-error (last (setq __LastResult__
(join-err @iCoInit @iScriptCtrl)
)))
))
; save it
(setq __iScriptControlObj__ (ret-val @iScriptCtrl))
; get the scripting error object
(setq @iScriptErr (IScriptControl.Error __iScriptControlObj__))
(if (failed? @iScriptErr) (begin
(Uninitialize)
(throw-error (last (setq __LastResult__
(join-err @iCoInit @iScriptCtrl @iScriptErr)
)))
))
; save it
(setq __iScriptErrorObj__ (ret-val @iScriptErr))
; set the scripting language
(setq @xLangRet (IScriptControl.Language __iScriptControlObj__ sLanguage))
(if (failed? @xLangRet) (begin
(Uninitialize)
(throw-error (last (setq __LastResult__
(join-err @iCoInit @iScriptCtrl @iScriptErr @xLangRet)
)))
))
; save it
(setq __sScriptLanguage__ sLanguage)
; save the result stack
(setq __LastResult__
(join-err @iCoInit @iScriptCtrl @iScriptErr @xLangRet)
)
));/if not already initialized
true ; no error occured
)
(import "ole32.dll" "CoUninitialize")
;; @syntax (WINSCRIPT:Uninitialize)
;; @return 'true'
;; Releases memory for scripting environment. Does not have to be called before
;; exiting the program, but it is good practice.
;;
;; If the scripting environment is not initialized, this function does nothing.
(define (Uninitialize)
(if (and (integer? __iScriptErrorObj__) (!= __iScriptErrorObj__ 0))
(IUnknown.Release __iScriptErrorObj__)
)
(if (and (integer? __iScriptControlObj__) (!= __iScriptControlObj__ 0))
(IUnknown.Release __iScriptControlObj__)
)
(CoUninitialize)
(setq __iScriptControlObj__ nil)
(setq __iScriptErrorObj__ nil)
(setq __sScriptLanguage__ nil)
(setq __LastResult__ '())
true ; return
)
;; @syntax (WINSCRIPT:Exec <str-code>)
;; @param <str-code> code to execute
;; @return 'true' on success, '(throw-error)' on error.
;; Executes the scripting code.
(define (Exec sCode , @varReturn)
; make sure WINSCRIPT has been initialized
(if (nil? __iScriptControlObj__)
(throw-error "Windows scripting has not been initialized")
)
; try to execute the code
(setq @varReturn (IScriptControl.ExecuteStatement __iScriptControlObj__ sCode))
; was it successful?
(if (success? @varReturn)
; then
(begin
; set __LastResult__ to the returned stack of 'errors'
(setq __LastResult__ (err-msg @varReturn))
true ; return
)
; else
(begin
(_HandleError @varReturn)
; __LastResult__ now holds all the 'errors' up to this point
; clear the scripting error
(IScriptError.Clear __iScriptErrorObj__)
; throw-error only the top-most error on the stack
(throw-error (last __LastResult__))
) ;/begin
)
)
;; @syntax (WINSCRIPT:Eval <str-code>)
;; @param <str-code> code to evaluate
;; @return resulting value on success, '(throw-error)' on error.
;; Evaluates the scripting code and returns the result. Returned types can be
;; String, Byte, Integer, Long, Float, Double, Boolean ('true' or 'nil'),
;; or object pointer. Uninitialized variables ("Empty") are returned as an
;; empty list. The remaining types (Arrays, Currency, Date, VARIANT*, and
;; DECIMAL*) are not handled and will cause an error if returned. Convert these
;; unhandled types to handled type (such as String) to return the value.
;;
;; @example
;; > (WINSCRIPT:Initialize)
;; true
;; > (WINSCRIPT:Eval "Now()")
;; user error : Unhandled variant type
;; called from user defined function WINSCRIPT:Eval
;; > (WINSCRIPT:Eval "CStr(Now())")
;; "1/9/2008 10:07:10 PM"
(define (Eval sCode , @varReturn @nlRet)
; make sure WINSCRIPT has been initialized
(if (nil? __iScriptControlObj__)
(throw-error "Windows scripting has not been initialized")
)
; try to evaluate the code
(setq @varReturn (IScriptControl.Eval __iScriptControlObj__ sCode))
; was it successful?
(if (success? @varReturn)
; [then]
(begin
; try to convert the return VARIANT to a newlisp variable
(setq @nlRet (__UnpackVARIANT (ret-val @varReturn)))
; regardless of success, pack the 'error' stack into __LastResult__
(setq __LastResult__
(join-err @varReturn @nlRet)
)
; now if it was actually successful...
(if (success? @nlRet)
; return the result
(ret-val @nlRet) ; return
; or throw an error
(throw-error (last __LastResult__))
)
)
; [else]
(begin
(_HandleError @varReturn)
; __LastResult__ now holds all the 'errors' up to this point
; clear the scripting error
(IScriptError.Clear __iScriptErrorObj__)
; throw-error only the top-most error on the stack
(throw-error (last __LastResult__))
)
)
)
; Sets __LastResult__ with all the 'errors' found.
(define (_HandleError @varReturn , @sErrorDesc @iErrNum )
; If there was an error calling
; IScriptControl.ExecuteStatement or IScriptControl.Eval
; (this is kinda sloppy, but it'll work)
(if (starts-with (last (err-msg @varReturn)) "IScriptControl.E")
; [then]
(begin
; try to get the error description
(setq @sErrorDesc (IScriptError.Description __iScriptErrorObj__))
(if (or (= "" (ret-val @sErrorDesc)) ; if we got an empty string
(nil? (ret-val @sErrorDesc)) ; or a null string
(failed? @sErrorDesc)) ; or failed to get anything
; [then]
(begin
; try to get the error number instead
(setq @iErrNum (IScriptError.Number __iScriptErrorObj__))
; did we get the number?
(if (success? @iErrNum)
; [then]
; set __LastResult__ to the stack of 'errors'
; from all the calls up to this point,
; including the automation error
(setq __LastResult__
(join-err @varReturn @sErrorDesc @iErrNum
(string "Automation error " (ret-val @iErrNum))
)
)
; [else]
; set __LastResult__ to the stack of 'errors'
; from all the calls up to this point
; (if we've reached this point, there has been a
; major failure somewhere)
(setq __LastResult__
(join-err @varReturn @sErrorDesc @iErrNum)
)
)
)
; [else]
; we got an error description, set __LastResult__ to the stack
; of 'errors' from previous calls, including the error description.
(setq __LastResult__
(join-err @varReturn @sErrorDesc (ret-val @sErrorDesc))
)
) ;/if we didn't get any error message
)
; [else]
(begin
(setq __LastResult__ @varReturn)
)
)
nil ; this is a void function
)
;; @syntax (WINSCRIPT:LastResult)
;; @return list of win32api function results during the last WINSCRIPT call.
;; The returned list of strings will hold the results of all win32api functions
;; that could have failed during the last operation. If the most recent
;; operation threw an error, the last item in the list will be the error message
;; thrown.
;;
;; @example
;; > (WINSCRIPT:Initialize)
;; true
;; > (WINSCRIPT:Exec "#$@#$$^$&*&&")
;; user error : Expected statement
;; called from user defined function WINSCRIPT:Exec
;; > (WINSCRIPT:LastResult)
;; ("MultiByteToWideChar ok" "SysAllocString ok"
;; "IScriptControl.ExecuteStatement -2146827264"
;; "IScriptError.Description 0" "WideCharToMultiByte ok" "Expected statement")
(define (LastResult)
__LastResult__
)
;###############################################################################
; == Tier 1 COM Internals ======================================================
(import "ole32.dll" "CoInitialize")
; Initializes COM
; @return (success? ret-val errmsg)
(define (_CoInitialize , iErr)
(setq iErr (CoInitialize 0))
(return
(>= iErr 0) ; success?
nil ; never a return value
(list (string "CoInitialize " iErr)) ; error result
)
)
; == Tier 2 COM Internals ======================================================
; Creates an object from a Prog ID
; (e.g. "Excel.Application")
; @return (success? ret-val errmsg)
(define (__CreateObjectProgId sProgId sIId , @sbinClsId @sbinIId @iObjPtr)
(catch (begin
; get the binary class id from the prog id
(setq @sbinClsId (__CLSIDFromProgID sProgId))
(if (failed? @sbinClsId) (throw
(return
nil ; fail
nil
(err-msg @sbinClsId)
)
))
; convert the interface id to its binary form
(setq @sbinIId (__IIDFromString sIId))
(if (failed? @sbinIId) (throw
(return
nil ; fail
nil
(join-err @sbinClsId @sbinIId)
)
))
; create the object
(setq @iObjPtr (__CreateInstance (ret-val @sbinClsId) (ret-val @sbinIId)))
(return
(success? @iObjPtr)
(ret-val @iObjPtr)
(join-err @sbinClsId @sbinIId @iObjPtr)
)
))
)
; == Tier 3 COM Internals ======================================================
(import "ole32.dll" "CoCreateInstance")
; Creates an object from the binary form of its Class ID and Interface ID
; @return (success? ret-val errmsg)
(define (__CreateInstance sbinClassId sbinIId , iObjPtr iErr)
(setq iObjPtr 0)
(setq iErr (CoCreateInstance
sbinClassId
0
(| CLSCTX_INPROC_SERVER CLSCTX_LOCAL_SERVER)
sbinIId
(address iObjPtr)))
(return
(>= iErr 0)
(if (>= iErr 0) iObjPtr nil)
(list (string "CoCreateInstance " iErr))
)
)
(import "ole32.dll" "CLSIDFromProgID")
; Looks up the binary Class ID of a Program ID
(define (__CLSIDFromProgID sProgId , @wsProgId sbinClassId iErr)
(catch (begin
; convert the progid to unicode
(setq @wsProgId (__ANSI2Unicode sProgId))
(if (failed? @wsProgId) (throw
(return
nil ; fail
nil
(err-msg @wsProgId)
))
)
; get the binary class id for the prog id
(setq sbinClassId (dup " " 16))
(setq iErr (CLSIDFromProgID (ret-val @wsProgId) sbinClassId))
(return
(>= iErr 0) ; success?
(if (>= iErr 0) sbinClassId nil) ; return value
(join-err @wsProgId (string "CLSIDFromProgID " iErr)) ; error
)
))
)
(import "ole32.dll" "IIDFromString")
; Converts a string Interface ID to a binary Interface ID
; (I really don't see why Win API has a separate function to do this)
; @return (success? ret-val errmsg)
(define (__IIDFromString sIId , @wsIId sbinIId iErr)
(catch (begin
; convert the interface id to unicode
(setq @wsIId (__ANSI2Unicode sIId))
(if (failed? @wsIId) (throw
(return
nil ; fail
nil
(err-msg @wsIId)
)
))
; convert it to binary
(setq sbinIId (dup " " 16))
(setq iErr (IIDFromString (ret-val @wsIId) sbinIId))
(return
(>= iErr 0) ; success?
(if (>= iErr 0) sbinIId nil) ; return
(join-err @wsIId (string "IIDFromString " iErr)) ; error
)
))
)
; ## IScriptControl ############################################################
; The entire IScriptControl Vtable (only the * members are implemented)
; 0 call_QueryInterface - Returns a pointer to a specified interface on an
; object to which a client currently holds an
; interface pointer
; 1 call_AddRef - Increments the reference count for an interface
; on an object
; 2 call_Release - Decrements the reference count for the calling
; interface on a object
; 3 call_GetTypeInfoCount - Retrieves the number of type information
; interfaces that an object provides (either 0 or 1)
; 4 call_GetTypeInfo - Retrieves the type information for an object
; 5 call_GetIDsOfNames - Maps a single member and an optional set of
; argument names to a corresponding set of integer
; DISPIDs
; 6 call_Invoke - Provides access to properties and methods exposed
; by an object.
; 7 * get_Language - Language engine to use
; 8 * put_Language - Language engine to use
; 9 get_State - State of the control
;10 put_State - State of the control
;11 put_SitehWnd - hWnd used as a parent for displaying UI
;12 get_SitehWnd - hWnd used as a parent for displaying UI
;13 get_Timeout - Length of time in milliseconds that a script can
; execute before being considered hung
;14 put_Timeout - Length of time in milliseconds that a script can
; execute before being considered hung
;15 get_AllowUI - Enable or disable display of the UI
;16 put_AllowUI - Enable or disable display of the UI
;17 get_UseSafeSubset - Force script to execute in safe mode and disallow
; potentially harmful actions
;18 put_UseSafeSubset - Force script to execute in safe mode and disallow
; potentially harmful actions
;19 get_Modules - Collection of modules for the ScriptControl
;20 * get_Error - The last error reported by the scripting engine
;21 get_CodeObject - Object exposed by the scripting engine that
; contains methods and properties defined in the
; code added to the global module
;22 get_Procedures - Collection of procedures that are defined in the
; global module
;23 call__AboutBox -
;24 call_AddObject - Add an object to the global namespace of the
; scripting engine
;25 call_Reset - Reset the scripting engine to a newly created
; state
;26 call_AddCode - Add code to the global module
;27 * call_Eval - Evaluate an expression within the context of the
; global module
;28 * call_ExecuteStatement - Execute a statement within the context of the
; global module
;29 call_Run - Call a procedure defined in the global module
;
; @syntax (IScriptControl.Language [sLanguage])
; @param <ppvScriptControl> (int) Pointer to script control object
; @param <sLanguage> (optional string) Scripting language (VBScript or JScript)
; @return (success? ret-val errmsg)
;
; If sLanguage is provided, sets the scripting language. Otherwise returns the
; currenet scripting language.
; Note: Changing the scripting language seems to reset the environment
(define (IScriptControl.Language ppvScriptControl (sLanguage nil)
, @bstrLang iErr)
(catch
(if sLanguage
; [then] Put language
(begin
; convert string to BSTR
(setq @bstrLang (__SysAllocStringA sLanguage))
(if (failed? @bstrLang) (throw
(return
nil ; fail
nil
(err-msg @bstrLang)
)
))
; put the language
(setq iErr
((ptr-to-fn (__VTable ppvScriptControl 8)) ppvScriptControl
(ret-val @bstrLang)))
(SysFreeString (ret-val @bstrLang))
; return
(return
(>= iErr 0)
nil ; fail
(join-err
@bstrLang
(string "IScriptControl.Language put " iErr)
)
)
)
; [else] Get language
(begin
; get the language
(setq @bstrLang 0)
(setq iErr
((ptr-to-fn (__VTable ppvScriptControl 7)) ppvScriptControl
(address @bstrLang)))
(if (< iErr 0) (throw
(return
nil ; failed
nil ; no return value
(list (string "IScriptControl.Language get " iErr)) ; error
)
))
; convert the BSTR language to string
(setq sLanguage (__Unicode2ANSI @bstrLang))
(SysFreeString @bstrLang) ; free the BSTR
(return
(success? sLanguage)
(if (success? sLanguage) (ret-val sLanguage) nil)
(join-err
(string "IScriptControl.Language get " iErr)
sLanguage
)
)
)
);/if
);/catch
)
; Pointer to Error object
; @return (success? ret-val errmsg)
(define (IScriptControl.Error ppvScriptControl , ppvScriptError iErr)
(setq ppvScriptError 0)
(setq iErr ((ptr-to-fn (__VTable ppvScriptControl 20)) ppvScriptControl
(address ppvScriptError)))
(return
(>= iErr 0)
(if (>= iErr 0) ppvScriptError nil)
(list (string "IScriptControl.Error " iErr))
)
)
; @return (success? ret-val errmsg)
(define (IScriptControl.Eval ppvScriptControl sExpression
, @bstrExpression VariantRet iErr)
(catch (begin
; convert code to BSTR
(setq @bstrExpression (__SysAllocStringA sExpression))
(if (failed? @bstrExpression) (throw
(return
nil
nil
(err-msg @bstrExpression)
)
))
; execute the code
(setq VariantRet (dup " " 16))
(setq iErr ((ptr-to-fn (__VTable ppvScriptControl 27)) ppvScriptControl
(ret-val @bstrExpression)
VariantRet))
; free the BSTR
(SysFreeString (ret-val @bstrExpression))
(return
(>= iErr 0)
(if (>= iErr 0) VariantRet nil)
(join-err @bstrExpression (string "IScriptControl.Eval " iErr))
)
))
)
; @return (success? ret-val errmsg)
(define (IScriptControl.ExecuteStatement ppvScriptControl sStatement
, @bstrExpression iErr)
(catch (begin
; convert code to BSTR
(setq @bstrExpression (__SysAllocStringA sStatement))
(if (failed? @bstrExpression) (throw
(return
nil ; fail
nil
(err-msg @bstrExpression)
)
))
; execute the code
(setq iErr ((ptr-to-fn (__VTable ppvScriptControl 28)) ppvScriptControl
(ret-val @bstrExpression)))
; free the BSTR
(SysFreeString (ret-val @bstrExpression))
(return
(>= iErr 0)
nil
(join-err @bstrExpression (string "IScriptControl.ExecuteStatement " iErr))
)
))
)
; ## IScriptError ##############################################################
;The entire IScriptError Vtable (only the * members are implemented)
; 0 call_QueryInterface - Returns a pointer to a specified interface on an
; object to which a client currently holds an
; interface pointer
; 1 call_AddRef - Increments the reference count for an interface
; on an object
; 2 call_Release - Decrements the reference count for the calling
; interface on a object
; 3 call_GetTypeInfoCount - Retrieves the number of type information
; interfaces that an object provides (either 0 or 1)
; 4 call_GetTypeInfo - Retrieves the type information for an object
; 5 call_GetIDsOfNames - Maps a single member and an optional set of
; argument names to a corresponding set of
; integer DISPIDs
; 6 call_Invoke - Provides access to properties and methods
; exposed by an object.
; 7 * get_Number - Error number
; 8 get_Source - Source of the error
; 9 * get_Description - Friendly description of error
;10 get_HelpFile - File in which help for the error can be found
;11 get_HelpContext - Context ID for the topic with information on
; the error
;12 get_Text - Line of source code on which the error occurred
;13 get_Line - Source code line number where the error occurred
;14 get_Column - Source code column position where the
; error occurred
;15 * call_Clear - Clear the script error
; @return (success? ret-val errmsg)
(define (IScriptError.Number ppvScriptError , iNum iErr)
(setq iNum 0)
(setq iErr ((ptr-to-fn (__VTable ppvScriptError 7)) ppvScriptError
(address iNum)))
(if (>= iErr 0)
; [then]
(return
true ; success
(first (unpack "ld" (address iNum))) ; make signed int
(list (string "IScriptError.Number " iErr))
)
; [else]
(return
nil ; fail
nil
(list (string "IScriptError.Number " iErr))
)
)
)
; Returns either an error string, or nil if there is no error string.
; @return (success? ret-val errmsg)
(define (IScriptError.Description ppvScriptError , bstrDescription sAnsi iErr)
(catch (begin
(setq bstrDescription 0)
(setq iErr ((ptr-to-fn (__VTable ppvScriptError 9)) ppvScriptError
(address bstrDescription)))
(if (< iErr 0) (throw
(return
nil ; fail
nil
(list (string "IScriptError.Description " iErr))
)
))
; if BSTR is null
(if (zero? bstrDescription)
; then
(return
true ; success
nil ; but no description
(list (string "IScriptError.Description " iErr))
)
; else
(begin
; convert to newlisp string
(setq sAnsi (__Unicode2ANSI bstrDescription))
; free BSTR
(SysFreeString bstrDescription)
(return
(success? sAnsi)
(ret-val sAnsi)
(join-err (string "IScriptError.Description " iErr) sAnsi)
)
)
)
))
)
; @return (success? ret-val errmsg)
(define (IScriptError.Clear ppvScriptError , iErr)
(setq iErr ((ptr-to-fn (__VTable ppvScriptError 15)) ppvScriptError))
(return
(>= iErr 0)
nil
(list (string "IScriptError.Clear " iErr))
)
)
; ## IUnknown ##################################################################
;The entire IUnknown Vtable (all members are implemented)
; 0 call_QueryInterface - Returns a pointer to a specified interface on an
; object to which a client currently holds an
; interface pointer
; 1 call_AddRef - Increments the reference count for an interface
; on an object
; 2 call_Release - Decrements the reference count for the calling
; interface on a object
; @return (success? ret-val errmsg)
(define (IUnknown.QueryInterface ppVtbl sInterfaceId
, @binInterfaceId ppvNewInterface iErr)
(catch (begin
; convert interface id string to binary
(setq @binInterfaceId (__IIDFromString sInterfaceId))
(if (failed? @binInterfaceId) (throw
(return
nil ; failed
nil
(err-msg @binInterfaceId)
)
))
; call QueryInterface
(setq ppvNewInterface 0)
(setq iErr ((ptr-to-fn (__VTable ppVtbl 0)) ppVtbl
(ret-val @binInterfaceId) (address ppvNewInterface)))
(return
(>= iErr 0)
(if (>= iErr 0) ppvNewInterface nil)
(join-err @binInterfaceId (string "IUnknown.QueryInterface " iErr))
)
))
)
; @return number of references that remain
(define (IUnknown.Release ppv)
((ptr-to-fn (__VTable ppv 2)) ppv) ; return
)
; ## Helper functions ##########################################################
(define (__VTable ppVtbl iIdx)
(get-int (+ (get-int ppVtbl) (* 4 iIdx)))
)
; Helper function to convert a pointer to a function
(define (ptr-to-fn iPtr , fnFuncPtr)
; get function template
(set 'fnFuncPtr import)
; change type to library import and OS calling conventions
(cpymem (pack "ld" 2312) (first (dump fnFuncPtr)) 4) ; Win32 stdcall
; set code pointer
(cpymem (pack "ld" iPtr) (+ (first (dump fnFuncPtr)) 12) 4)
fnFuncPtr
)
(import "oleaut32" "VariantInit")
(import "oleaut32" "VariantClear")
(import "oleaut32" "SysFreeString")
(import "oleaut32" "SysAllocString")
; @return (success? ret-val errmsg)
(define (__SysAllocStringA sAnsi , @sUnicode iBstrPtr)
(catch (begin
; convert string to unicode
(setq @sUnicode (__ANSI2Unicode sAnsi))
(if (failed? @sUnicode) (throw
(return
nil ; failed
nil
(err-msg @sUnicode)
)
))
; convert to BSTR
(setq iBstrPtr (SysAllocString (ret-val @sUnicode)))
(if (zero? iBstrPtr)
; [then]
(return
nil ; failed
nil
(join-err @sUnicode "SysAllocString fail")
)
; [else]
(return
true ; success
iBstrPtr
(join-err @sUnicode "SysAllocString ok")
)
)
))
)
; Converts a VARIANT structure to a normal AHK variable.
; Not all VARIANT types are handled.
; @return (success? ret-val errmsg)
(define (__UnpackVARIANT sVariantStruct , iVariantType pData s)
(setq iVariantType (get-short (address sVariantStruct)))
(setq pData (+ (address sVariantStruct) 8))
(case iVariantType
; VT_BSTR
(0x0008
(setq s (__Unicode2ANSI (get-int pData)))
(VariantClear sVariantStruct)
(if (success? s)
(return true (ret-val s) (err-msg s))
(return nil nil (err-msg s))
)
)
(0x4008
(setq s (__Unicode2ANSI (get-int (get-int pData))))
(VariantClear sVariantStruct)
(if (success? s)
(return true (ret-val s) (err-msg s))
(return nil nil (err-msg s))
)
)
; VT_EMPTY
(0x0000 (return true '() '()))
; VT_UI1
(0x0011 (return true (get-char pData) '()))
(0x4011 (return true (get-char (get-int pData)) '()))
; VT_I2
(0x0002 (return true (get-short pData) '()))
(0x4002 (return true (get-short (get-int pData)) '()))
; VT_I4
(0x0003 (return true (get-int pData) '()))
(0x4003 (return true (get-int (get-int pData)) '()))
; VT_R4
(0x0004 (return true (get-single pData) '()))
(0x4004 (return true (get-single (get-int pData)) '()))
; VT_R8
(0x0005 (return true (get-float pData) '()))
(0x4005 (return true (get-float (get-int pData)) '()))
; VT_BOOL
(0x000B (return true (!= 0 (get-short pData)) '()))
(0x400B (return true (!= 0 (get-short (get-int pData))) '()))
; VT_ERROR
(0x000A (return true (get-int pData) '()))
(0x400A (return true (get-int (get-int pData)) '()))
; VT_DISPATCH
(0x0009 (return true (get-int pData) '()))
(0x4009 (return true (get-int (get-int pData)) '()))
; VT_UNKNOWN
(0x000D (return true (get-int pData) '()))
(0x400D (return true (get-int (get-int pData)) '()))
(true
; Unhandled VARIANT types:
; Array, Currency, Date, VARIANT*, and DECIMAL*
(VariantClear sVariantStruct)
(return nil nil '("Unhandled variant type"))
)
)
)
(define (get-short int-address)
(first (unpack "d" int-address))
)
(define (get-single int-address)
(first (unpack "f" int-address))
)
(import "kernel32.dll" "MultiByteToWideChar")
; @return (success? ret-val errmsg)
(define (__ANSI2Unicode sAnsi , iSize sUtf16)
(catch (begin
; TODO: Maybe check if this is utf8 enabled newLISP and convert from utf8 instead of ANSI
(setq iSize (MultiByteToWideChar
0 ; from CP_ACP (ANSI)
0 ; no flags
sAnsi
-1 ; until NULL
0 ; NULL
0))
(if (< iSize 1) (throw
(return
nil ; fail
nil
(list (string "MultiByteToWideChar failed to convert string " sAnsi))
)
))
(setq sUtf16 (dup " " (* iSize 2)))
(setq iSize (MultiByteToWideChar
0 ; from CP_ACP (ANSI)
0 ; no flags
sAnsi
-1 ; until NULL
sUtf16
iSize))
(if (< iSize 1) (throw
(return
nil ; fail
nil
(list (string "MultiByteToWideChar failed to convert string " sAnsi))
)
))
(return
true ; success
sUtf16
(list "MultiByteToWideChar ok")
)
))
)
(import "kernel32.dll" "WideCharToMultiByte")
; @param s|pUtf16 Can pass either a string or integer-pointer to utf16 string.
; @return (success? ret-val errmsg)
(define (__Unicode2ANSI s|pUtf16 , iSize sAnsi)
(catch (begin
; TODO: Maybe check if this is utf8 enabled newLISP and convert to utf8 instead of ANSI
(setq iSize (WideCharToMultiByte
0 ; to CP_API (ANSI)
0 ; no flags
s|pUtf16
-1 ; until NULL
0 ; NULL
0 ; Just find length
0 ; NULL
0) ; NULL
)
(if (< iSize 1) (throw
(return
nil
nil
(list (string "WideCharToMultiByte failed to convert string " s|pUtf16))
)
))
(setq sAnsi (dup " " (+ iSize 1)))
(setq iSize (WideCharToMultiByte
0 ; to CP_API (ANSI)
0 ; no flags
s|pUtf16
-1 ; until NULL
sAnsi
iSize
0 ; NULL
0) ; NULL
)
(if (< iSize 1) (throw
(return
nil ; fail
nil
(list (string "WideCharToMultiByte failed to convert string " s|pUtf16))
)
))
(return
true ; success
(get-string sAnsi)
(list "WideCharToMultiByte ok")
)
))
)
;-------------------------------------------------------------------------------
; The following functions help with error handling.
;
; Most functions return a three item list:
; item 0 success?: true = function succeeded, false = function failed
; item 1 ret-val : on success, the actual return value. on failure, nil
; item 2 err-msg : a list of strings describing results of all win32 api calls
;
; Variables that hold this special type of list are prefixed with
; an at (@) symbol, followed by hungarian notaion of the
; data type found in the second item of the list.
(define return list)
(define (failed? lst)
(not (lst 0))
)
(define (success? lst)
(lst 0)
)
(define (ret-val lst)
(lst 1)
)
(define (err-msg lst)
(lst 2)
)
; joins all arguments into a list
; if an argument is a list, it is assume to be the
; (success? ret-val err-msg) format, so it only takes the 3rd item in the list.
; Otherwise it just uses the argument as is.
(define (join-err)
(apply
append
(map
(fn (x)
(if (list? x) (err-msg x) (list x))
)
(args)
)
)
)
;-------------------------------------------------------------------------------
(context 'MAIN)
syntax highlighting with newLISP and newLISPdoc