You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
58 lines
1.9 KiB
58 lines
1.9 KiB
#lang racket
|
|
(require ffi/com)
|
|
|
|
(provide (create-wrapped-instance get-active-wrapped-com-obj))
|
|
|
|
(define com-obj-prefix (make-parameter "COM"))
|
|
(define com-progid (make-parameter (void>)))
|
|
|
|
(define (create-wco)
|
|
(wrap-com-obj (com-create-instance (com-progid))))
|
|
|
|
(define (get-active-wco)
|
|
(wrap-com-obj (com-get-active-obj (com-progid))))
|
|
|
|
(define (wrapped-com-obj? x)
|
|
(with-handlers ([exn? (lambda(_) #f)])
|
|
(com-object? (x 'com-obj))))
|
|
|
|
(define (wrap-com-obj com-obj)
|
|
(read-case-sensitive #f)
|
|
(let-values ([(get-props set-props methods) (gather-members com-obj)])
|
|
(let ([print-repr
|
|
(format
|
|
"#<~A/~A:~A>"
|
|
(com-obj-prefix)
|
|
(com-object-type com-obj)
|
|
(com-get-property
|
|
com-obj
|
|
(cond
|
|
[(member "name" get-props) "name"]
|
|
[(member "objectid" get-props) "objectid"]
|
|
[else ""])))])
|
|
(lambda (msg . args)
|
|
(let* ([msg (symbol->string msg)]
|
|
[result
|
|
(case msg
|
|
[("com-obj") com-obj]
|
|
[("get-props") get-props]
|
|
[("set-props") set-props]
|
|
[("methods") methods]
|
|
[("print-repr") print-repr]
|
|
[else
|
|
(cond
|
|
[(and (member msg set-props)
|
|
(equal? (length args) 1))
|
|
(com-set-property! com-obj msg (first args))]
|
|
[(member msg get-props) (com-get-property com-obj msg)]
|
|
[(member msg methods)
|
|
(apply com-invoke com-obj msg args)])])])
|
|
(if (and (com-object? result)
|
|
(not (eq? result com-obj)))
|
|
(wrap-com-obj result)
|
|
result))))))
|
|
|
|
(define (gather-members com-obj)
|
|
(apply values (map (lambda(get-func) (map string-downcase (get-func com-obj)))
|
|
(list com-get-properties com-set-properties com-methods))))
|