;; @module winscript
;; @description Embedded VBScript/JScript in newLISP.
;; @version 0.21
;; @author m35
;;
;; @location http://www.autohotkey.net/~easycom/winscript.lsp
;;
;; 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.
;;
;; Tested with newlisp 9.2.0.
;;
;; 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
;; Sets up the scripting environment. Must be called before any other
;; functions can be used.
(define (Initialize (sLanguage "VBScript") , iCoInit iScriptCtrl xLangRet iScriptErr)
; initialize COM
(setq iCoInit (_CoInitialize))
(if (failed? iCoInit)
(throw-error (last (setq __LastResult__
(err-msg iCoInit)
)))
)
; create a scripting control
(setq iScriptCtrl (__CreateObjectClsId CLSID_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)
)
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.
(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 , sErrorDesc iErrNum 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__ 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 , sErrorDesc iErrNum varReturn lspRet)
; 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 lspRet (__UnpackVARIANT (ret-val varReturn)))
; regardless of success, pack the 'error' stack into __LastResult__
(setq __LastResult__
(join-err varReturn lspRet)
)
; now if it was successful...
(if (success? lspRet)
; return the result
(ret-val lspRet) ; return
; or throw an error
(throw-error (last __LastResult__))
)
)
; [else]
(begin
(HandleError varReturn)
; __LastResult__ 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__))
)
)
)
(define (HandleError varReturn , sErrorDesc iErrNum )
; try to get the error description
; TODO: should only do this if there was an HRESULT error in IScriptControl.ExecuteStatement / IScriptControl.Eval
(setq sErrorDesc (IScriptError.Description __iScriptErrorObj__))
; if the returned error description is an empty string, or a null string
; or if getting the error description failed...
(if (or (= "" (ret-val sErrorDesc))
(nil? (ret-val sErrorDesc))
(failed? sErrorDesc))
; [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
(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))
)
) ;/begin
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 last operation
;; threw and 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))
(list ; return
(>= iErr 0) ; success?
nil ; never a return value
(list (string "CoInitialize " iErr)) ; error result
)
)
; == Tier 2 COM Internals ======================================================
; Creates an object from a Class ID
; (e.g. "{00000000-0000-0000-C000-000000000046}")
; @return (success? ret-val errmsg)
(define (__CreateObjectClsId sClsId sIId , sbinClsId sbinIId iObjPtr)
(catch (begin
; convert the class id to its binary form
(setq sbinClsId (__CLSIDFromString sClsId))
(if (failed? sbinClsId)
(throw (list
nil
nil
(err-msg sbinClassId)
))
)
; convert the interface id to its binary form
(setq sbinIId (__IIDFromString sIId))
(if (failed? sbinIId)
(throw (list
nil
nil
(join-err sbinClsId sbinIId)
))
)
; create the object
(setq iObjPtr (__CreateInstance (ret-val sbinClsId) (ret-val sbinIId)))
; return
(list
(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)))
(list
(>= iErr 0)
(if (>= iErr 0) iObjPtr nil)
(list (string "CoCreateInstance " iErr))
)
)
(import "ole32.dll" "CLSIDFromString")
; Converts a string Class ID to a binary Class ID
; @return (success? ret-val errmsg)
(define (__CLSIDFromString sClassId , wsClassId sbinClassId iErr)
(catch (begin
; convert the class id string to unicode
(setq wsClassId (__ANSI2Unicode sClassId))
(if (failed? wsClassId)
(throw (list
nil
nil
(err-msg wsClassId)
))
)
; convert it to binary
(setq sbinClassId (dup " " 16))
(setq iErr (CLSIDFromString (ret-val wsClassId) sbinClassId))
; return
(list
(>= iErr 0) ; success?
(if (>= iErr 0) sbinClassId nil) ; return value
(join-err wsClassId (string "CLSIDFromString " 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 (list
nil
nil
(err-msg wsIId)
))
)
; convert it to binary
(setq sbinIId (dup " " 16))
(setq iErr (IIDFromString (ret-val wsIId) sbinIId))
; return
(list
(>= 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
;
; Note: Changing the scripting language seems to reset the environment
; @return (success? ret-val errmsg)
(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 (list ; return
nil
nil
(err-msg bstrLang)
))
)
; put the language
(setq iErr
((ptr-to-fn (__VTable ppvScriptControl 8)) ppvScriptControl
(ret-val bstrLang)))
(SysFreeString (ret-val bstrLang))
; return
(list
(>= iErr 0)
nil
(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)
; return
(throw (list
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
(list
(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)))
(list
(>= iErr 0)
(if (>= iErr 0) ppvScriptError nil)
(list (string "IScriptControl.Error " iErr))
)
)
; @return (success? ret-val errmsg)
(define (IScriptControl.Eval ppvScriptControl sExpression
, bstrExpression VarRet iErr)
(catch (begin
; convert code to BSTR
(setq bstrExpression (__SysAllocStringA sExpression))
(if (failed? bstrExpression)
(throw (list ; return
nil
nil
(err-msg bstrExpression)
))
)
; execute the code
(setq VarRet (dup " " 16))
(setq iErr ((ptr-to-fn (__VTable ppvScriptControl 27)) ppvScriptControl
(ret-val bstrExpression)
VarRet))
; free the BSTR
(SysFreeString (ret-val bstrExpression))
(list ; return
(>= iErr 0)
(if (>= iErr 0) VarRet 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 (list ; return
nil
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))
(list ; 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]
(list ; return
true
(first (unpack "ld" (address iNum))) ; make signed int
(list (string "IScriptError.Number " iErr))
)
;[else]
(list ; return
nil
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 (list
nil
nil
(list (string "IScriptError.Description " iErr))
))
)
; if BSTR is null
(if (zero? bstrDescription)
; then
(list ; return
true ; successful
nil ; but no description
(list (string "IScriptError.Description " iErr))
)
; else
(begin
; convert to newlisp string
(setq sAnsi (__Unicode2ANSI bstrDescription))
; free BSTR
(SysFreeString bstrDescription)
(list ; 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
(list
(>= 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 ppv iid , biniid ppvNewInterface iErr)
(catch (begin
; convert interface id string to binary
(setq biniid (__IIDFromString iid))
(if (failed? biniid)
(throw (list ; return
nil
nil
(err-msg biniid)
))
)
; call QueryInterface
(setq ppvNewInterface 0)
(setq iErr ((ptr-to-fn (__VTable ppv 0)) ppv
(ret-val biniid) (address ppvNewInterface)))
(list ; return
(>= iErr 0)
(if (>= iErr 0) ppvNewInterface nil)
(join-err biniid (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 ppv idx)
(get-int (+ (get-int ppv) (* 4 idx)))
)
; Helper function to convert a pointer to a function
(define (ptr-to-fn ptr , foo)
; get function template
(set 'foo import)
; change type to library import and OS calling conventions
(cpymem (pack "ld" 265) (first (dump foo)) 4) ; Win32 stdcall
; set code pointer
(cpymem (pack "ld" ptr) (+ (first (dump foo)) 12) 4)
foo
)
(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 (list ; return
nil
nil
(err-msg sUnicode)
))
)
; convert to BSTR
(setq iBstrPtr (SysAllocString (ret-val sUnicode)))
(if (zero? iBstrPtr)
;[then]
(list ; return
nil ; failed
nil
(join-err sUnicode (string "SysAllocString fail"))
)
;[else]
(list ; return
true ; success
iBstrPtr
(join-err sUnicode (string "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)
(list true (ret-val s) (err-msg s))
(list nil nil (err-msg s))
)
)
(0x4008
(setq s (__Unicode2ANSI (get-int (get-int pData))))
(VariantClear sVariantStruct)
(if (success? s)
(list true (ret-val s) (err-msg s))
(list nil nil (err-msg s))
)
)
; VT_EMPTY
(0x0000 (list true '() '()))
; VT_UI1
(0x0011 (list true (get-char pData) '()))
(0x4011 (list true (get-char (get-int pData)) '()))
; VT_I2
(0x0002 (list true (get-short pData) '()))
(0x4002 (list true (get-short (get-int pData)) '()))
; VT_I4
(0x0003 (list true (get-int pData) '()))
(0x4003 (list true (get-int (get-int pData)) '()))
; VT_R4
(0x0004 (list true (get-single pData) '()))
(0x4004 (list true (get-single (get-int pData)) '()))
; VT_R8
(0x0005 (list true (get-float pData) '()))
(0x4005 (list true (get-float (get-int pData)) '()))
; VT_BOOL
(0x000B (list true (!= 0 (get-short pData)) '()))
(0x400B (list true (!= 0 (get-short (get-int pData))) '()))
; VT_ERROR
(0x000A (list true (get-int pData) '()))
(0x400A (list true (get-int (get-int pData)) '()))
; VT_DISPATCH
(0x0009 (list true (get-int pData) '()))
(0x4009 (list true (get-int (get-int pData)) '()))
; VT_UNKNOWN
(0x000D (list true (get-int pData) '()))
(0x400D (list true (get-int (get-int pData)) '()))
(true
; Unhandled VARIANT types:
; Array, Currency, Date, VARIANT*, and DECIMAL*
(VariantClear sVariantStruct)
(list 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
(setq iSize (MultiByteToWideChar
0 ; from CP_ACP (ANSI)
0 ; no flags
sAnsi
-1 ; until NULL
0 ; NULL
0))
(if (< iSize 1) (throw
(list ; return
nil
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
(list ; return
nil
nil
(list (string "MultiByteToWideChar failed to convert string " sAnsi))
)
))
; return
(list
true
sUtf16
(list "MultiByteToWideChar ok")
)
))
)
(import "kernel32.dll" "WideCharToMultiByte")
; @return (success? ret-val errmsg)
(define (__Unicode2ANSI s|pUtf16 , iSize sAnsi)
(catch (begin
(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
(list ; 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
(list ; return
nil
nil
(list (string "WideCharToMultiByte failed to convert string " s|pUtf16))
)
))
; return
(list
true
(get-string sAnsi)
(list "WideCharToMultiByte ok")
)
))
)
(define (failed? lst)
(not (lst 0))
)
(define (success? lst)
(lst 0)
)
(define (ret-val lst)
(lst 1)
)
(define (err-msg lst)
(lst 2)
)
(define (join-err)
(apply
append
(map
(fn (x)
(if (list? x) (err-msg x) (list x))
)
(args)
)
)
)
(define (dbg x)
(println x)
x
)
(context 'MAIN)
syntax highlighting with newLISP and newLISPdoc