Announcement

Collapse
No announcement yet.

Assorted COM examples

Collapse
X
  • Filter
  • Time
  • Show
Clear All
new posts

  • Assorted COM examples

    Microsoft COM (Component Object Model) technology in the Microsoft Windows-family of Operating Systems enables software components to communicate. COM is used by developers to create re-usable software components, link components together to build applications, and take advantage of Windows services. COM objects can be created with a variety of programming languages. Object-oriented languages, such as C++, provide programming mechanisms that simplify the implementation of COM objects. The family of COM technologies includes COM+, Distributed COM (DCOM) and ActiveXģ Controls.

    Microsoft provides COM interfaces for many Windows application programming interfaces such as Direct Show, Media Foundation, Packaging API, Windows Animation Manager, Windows Portable Devices, and Microsoft Active Directory (AD).

    COM is used in applications such as the Microsoft Office Family of products. For example COM OLE technology allows Word documents to dynamically link to data in Excel spreadsheets and COM Automation allows users to build scripts in their applications to perform repetitive tasks or control one application from another.
    Forum: http://www.jose.it-berater.org/smfforum/index.php

  • #2
    How to enumerate the Running Object Table (ROT)

    The IRunningObjectTable interface manages access to the Running Object Table (ROT), a globally accessible look-up table on each workstation. A workstation's ROT keeps track of those objects that can be identified by a moniker and that are currently running on the workstation. When a client tries to bind a moniker to an object, the moniker checks the ROT to see if the object is already running; this allows the moniker to bind to the current instance instead of loading a new one.

    The ROT contains entries of the form:

    (pmkObjectName, pUnkObject)

    The pmkObjectName element is a pointer to the moniker that identifies the running object. The pUnkObject element is a pointer to the running object itself. During the binding process, monikers consult the pmkObjectName entries in the Running Object Table to see if an object is already running.

    Objects that can be named by monikers must be registered with the ROT when they are loaded and their registration must be revoked when they are no longer running.

    The following example shows the display names of all the objects currently registered in the Running Object Table (ROT).

    Code:
    ' ########################################################################################
    ' The following example shows the display names of all the objects currently registered in
    ' the Running Object Table (ROT).
    ' ########################################################################################
    
    #COMPILE EXE
    #DIM ALL
    #INCLUDE "windows.inc"
    #INCLUDE "objidl.inc"
    
    ' ========================================================================================
    ' Main
    ' ========================================================================================
    FUNCTION PBMAIN () AS LONG
    
       LOCAL hr AS LONG
       LOCAL pbc AS IBindCtx
       LOCAL pRot AS IRunningObjectTable
       LOCAL pEnumMoniker AS IEnumMoniker
       LOCAL pMoniker AS IMoniker
       LOCAL pceltFetched AS DWORD
       LOCAL pwszDisplayName AS WSTRINGZ PTR
    
       ' // Get a pointer to a bind context
       hr = CreateBindCtx(0, pbc)
       IF hr <> %S_OK THEN EXIT FUNCTION
    
       ' // Get a reference to the Running Object Table (ROT)
       hr = pbc.GetRunningObjectTable(pRot)
       IF hr <> %S_OK THEN EXIT FUNCTION
    
       ' // Get a pointer to the moniker enumerator
       hr = pRot.EnumRunning(pEnumMoniker)
       IF hr <> %S_OK THEN EXIT FUNCTION
    
       ' // Enumerate the monikers and retrieve the display name
       DO
          ' // Fetch the next moniker
          hr = pEnumMoniker.Next(1, pMoniker, pceltFetched)
          IF hr <> %S_OK THEN EXIT DO
          ' // Get the display name
          hr = pMoniker.GetDisplayName(pbc, NOTHING, pwszDisplayName)
          IF hr <> %S_OK THEN EXIT DO
          IF pwszDisplayName THEN
             ' // Display the name
             ? @pwszDisplayName
             ' // Free the server allocated string
             CoTaskMemFree pwszDisplayName
          END IF
          ' // Release the moniker reference
          pMoniker = NOTHING
       LOOP
    
       #IF %DEF(%PB_CC32)
          WAITKEY$
       #ENDIF
    
    END FUNCTION
    ' ========================================================================================
    Forum: http://www.jose.it-berater.org/smfforum/index.php

    Comment


    • #3
      IFileOpenDialog Interface

      The following example demonstrates the use of the IFileOpenDialog interface, introduced in Windows Vista.

      Code:
      #COMPILE EXE
      #DIM ALL
      #INCLUDE "ShObjIdl.inc"
      
      FUNCTION PBMAIN () AS LONG
      
         LOCAL hr AS LONG
      
         ' // Create an instance of the IFileOpenDialog interface
         LOCAL pofd AS IFileOpenDialog
         pofd = NEWCOM CLSID $CLSID_FileOpenDialog
         IF ISNOTHING(pofd) THEN EXIT FUNCTION
      
         DIM rgFileTypes(2) AS COMDLG_FILTERSPEC
         DIM pszNames(2) AS WSTRINGZ * %MAX_PATH
         DIM pszSpecs(2) AS WSTRINGZ * %MAX_PATH
         pszNames(0) = "PB code files"
         pszNames(1) = "Executable files"
         pszNames(2) = "All files"
         pszSpecs(0) = "*.bas;*.inc"
         pszSpecs(1) = "*.exe;*.dll"
         pszSpecs(2) = "*.*"
         rgFileTypes(0).pszName = VARPTR(pszNames(0)) : rgFileTypes(0).pszSpec = VARPTR(pszSpecs(0))
         rgFileTypes(1).pszName = VARPTR(pszNames(1)) : rgFileTypes(1).pszSpec = VARPTR(pszSpecs(1))
         rgFileTypes(2).pszName = VARPTR(pszNames(2)) : rgFileTypes(2).pszSpec = VARPTR(pszSpecs(2))
         hr = pofd.SetFileTypes(3, rgFileTypes(0))
      
         ' // Set the title of the dialog
         hr = pofd.SetTitle("A Single-Selection Dialog")
      
         ' // Display the dialog
         hr = pofd.Show(0)
      
         ' // Get the result
         LOCAL pItem AS IShellItem
         LOCAL pwszName AS WSTRINGZ PTR
         IF SUCCEEDED(hr) THEN
            hr = pofd.GetResult(pItem)
            IF SUCCEEDED(hr) THEN
               hr = pItem.GetDisplayName(%SIGDN_FILESYSPATH, pwszName)
               MSGBOX @pwszName
               CoTaskMemFree(pwszName)
            END IF
         END IF
      
      END FUNCTION
      Forum: http://www.jose.it-berater.org/smfforum/index.php

      Comment


      • #4
        How to implement the IDropTarget interface

        The action of using the mouse to transfer data from one place to another is called drag-and-drop.

        To made an application the target of a drag-and-drop operation we need to implement the IDropTarget interface and register the application window as drop target with a call to the function RegisterDragDrop.

        A drop-target application is responsible for:
        • Determining the effect of the drop on the target application.
        • Incorporating any valid dropped data when the drop occurs.
        • Communicating target feedback to the source so the source application can provide appropriate visual feedback such as setting the cursor.
        • Implementing drag scrolling.
        • Registering and revoking its application windows as drop targets.


        Applications that use drag-and-drop functionality must call the API function OleInitialize before calling any other function of the COM library. Because OLE operations aren't thread safe, OleInitialize specifies the concurrency model as single-thread apartment (STA).

        When your application ends, you must call the API function OleUninitialize as the last COM call to close the COM library.

        Here is the WinMain function of the attached example, showing the call to OleInitialize at the beginning of the function and the call to OleUninitialize at the end:

        Code:
        ' ========================================================================================
        ' Main
        ' ========================================================================================
        FUNCTION WinMain (BYVAL hInstance AS DWORD, BYVAL hPrevInstance AS DWORD, BYVAL lpszCmdLine AS WSTRINGZ PTR, BYVAL nCmdShow AS LONG) AS LONG
        
           ' // Set process DPI aware
        '   SetProcessDPIAware
        
           ' Initialize the COM library
           OleInitialize %NULL
        
           ' // Create an instance of the class
           LOCAL pWindow AS IWindow
           pWindow = CLASS "CWindow"
           IF ISNOTHING(pWindow) THEN EXIT FUNCTION
        
           ' // Create the main window
           ' // Note: CW_USEDEFAULT is used as the default value When passing 0's as the width and height
           pWindow.CreateWindow(%NULL, "IDropTarget Demo", 0, 0, 0, 0, 0, %WS_EX_TOPMOST, CODEPTR(WindowProc))
           ' // Set the client size
           pWindow.SetClientSize 400, 80
           ' // Center the window
           pWindow.CenterWindow
        
           ' // Default message pump (you can replace it with your own)
           pWindow.DoEvents(nCmdShow)
        
           ' Uninitialize the COM library
           OleUninitialize
        
        END FUNCTION
        ' ========================================================================================
        The API function RegisterDragDrop registers the specified window as one that can be the target of an OLE drag-and-drop operation and specifies the IDropTarget instance to use for drop operations.

        In the example, during the processing of the WM_CREATE message in the main window callback function we add a label control, create an instance of our implemented IDropTarget interface and register the label control as a candidate target of an OLE drag-and-drop operation with a call to RegisterDragDrop.

        Code:
              CASE %WM_CREATE
                 ' // Get a reference to the IWindow interface from the CREATESTRUCT structure
                 pWindow = CWindow_GetObjectFromCreateStruct(lParam)
                 ' // Add a label
                 hLabel = pWindow.AddLabel(hwnd, %IDC_LABEL, "Drop a link here...", 20, 30, 360, 20, %WS_VISIBLE OR %WS_CHILD OR %WS_BORDER)
                 IF hLabel THEN
                    ' Create a new instance of our implemented IDropTarget interface
                    pDropTarget = CLASS "CDropTarget"
                    IF ISOBJECT(pDropTarget) THEN
                       ' Sets the handle of the label
                       pDropTarget.SetHwnd hLabel
                       ' Locks the object to ensure that it stays in memory
                       hr = CoLockObjectExternal(pDropTarget, %TRUE, %FALSE)
                       ' Registers the specified window as one that can be the target
                       ' of an OLE drag-and-drop operation and specifies the IDropTarget
                       ' instance to use for drop operations.
                       hr = RegisterDragDrop(hLabel, pDropTarget)
                    END IF
                 END IF
                 EXIT FUNCTION
        RevokeDragDrop revokes the registration of the specified application window as a potential target for OLE drag-and-drop operations.

        In the example, during the processing of the WM_DESTROY message we revoke the registration of the label with a call to RevokeDragDrop and release the instance of our implemented IDropTarget interface.

        Code:
              CASE %WM_DESTROY
                 ' // Revokes the registration of the specified application window as a
                 ' // potential target for OLE drag-and-drop operations.
                 IF hLabel THEN RevokeDragDrop hLabel
                 IF ISOBJECT(pDropTarget) THEN
                    ' // Unlocks our IDropTarget interface
                    hr = CoLockObjectExternal(pDropTarget, %FALSE, %FALSE)
                    ' // Frees the memory used by our IDropTarget interface
                    pDropTarget = NOTHING
                 END IF
                 ' // End the application
                 PostQuitMessage 0
                 EXIT FUNCTION
        The DragEnter method of the IDropTarget interface determines whether a drop can be accepted and its effect if it is accepted. To determine it, we will call the QueryDataObject and DropEffect methods. QueryDataObject checks if the data object contains the kind of data wanted, and DropEffect determines the allowed effect based on the state of the keyboard.

        Code:
              ' ----------------------------------------------------------------------------------
              ' Determines whether a drop can be accepted and its effect if it is accepted
              ' ----------------------------------------------------------------------------------
              METHOD DragEnter ( _                      ' VTable offset = 12
                BYVAL pDataObject AS IDataObject _      ' // Pointer to the interface of the source data object
              , BYVAL grfKeyState AS DWORD _            ' // Current state of keyboard modifier keys
              , BYVAL pt AS POINTL _                    ' // Current cursor coordinates (Must be BYVAL)
              , BYREF pdwEffect AS DWORD _              ' // Pointer to the effect of the drag-and-drop operation
              ) AS LONG                                 ' HRESULT
        
                 pdwEffect = %DROPEFFECT_NONE
                 IF ISFALSE ISOBJECT(pDataObject) THEN
                    METHOD = %E_FAIL
                    EXIT METHOD
                 END IF
        
                 ' Check if the data object contains the data we want
                 bAllowDrop = ME.QueryDataObject(pDataObject)
                 IF bAllowDrop THEN
                    ' Get the dropeffect based on keyboard state
                    pdwEffect = ME.DropEffect(grfKeyState, pt, pdwEffect)
                    ' Bring the window to the foregroung
                    IF hwnd THEN SetForegroundWindow hwnd
                 END IF
        
                 ' Return success
                 METHOD = %S_OK
        
              END METHOD
              ' ----------------------------------------------------------------------------------
        This is our implementation of the QueryDataObject method:

        Code:
              ' ----------------------------------------------------------------------------------
              ' Checks if the data object contains the data we want.
              ' In this example, asks for some CF_TEXT data, stored as a HGLOBAL in the clipboard
              ' ----------------------------------------------------------------------------------
              METHOD QueryDataObject (BYVAL pDataObject AS IDataObject) AS LONG
        
                 LOCAL hr AS LONG
                 LOCAL fmtc AS FORMATETC
                 LOCAL stgmed AS STGMEDIUM
        
                 fmtc.cfFormat = %CF_TEXT
                 fmtc.ptd = %NULL
                 fmtc.dwAspect = %DVASPECT_CONTENT
                 fmtc.lindex = -1
                 fmtc.tymed = %TYMED_HGLOBAL
                 hr = pDataObject.GetData(fmtc, stgmed)
                 IF hr = %S_OK THEN
                    IF stgmed.hGlobal THEN METHOD = %TRUE
                    ReleaseStgMedium stgmed
                 END IF
        
              END METHOD
              ' ----------------------------------------------------------------------------------
        And this is our implementation of the DropEffect method:

        Code:
              ' ----------------------------------------------------------------------------------
              ' Retrieves the allowed drop effect
              ' ----------------------------------------------------------------------------------
              METHOD DropEffect (BYVAL grfKeyState AS DWORD, BYVAL pt AS POINTL, BYVAL dwAllowed AS DWORD) AS DWORD
        
                 LOCAL dwEffect  AS DWORD
        
                 ' 1. Check "pt" -> Is a  drop allowed at the specified coordinates?
                 ' 2. Work out that the drop-effect should be based on grfKeyState
                 IF (grfKeyState AND %MK_CONTROL) THEN
                    dwEffect = dwAllowed AND %DROPEFFECT_COPY
                 ELSEIF (grfKeyState AND %MK_SHIFT) THEN
                    dwEffect = dwAllowed AND %DROPEFFECT_MOVE
                 END IF
        
                 ' 3. No key-modifiers were specified (or drop effect not allowed), so
                 '    base the effect on those allowed by the dropsource
                 IF dwEffect = 0 THEN
                    IF (dwAllowed AND %DROPEFFECT_COPY) THEN dwEffect = %DROPEFFECT_COPY
                    IF (dwAllowed AND %DROPEFFECT_MOVE) THEN dwEffect = %DROPEFFECT_MOVE
                    IF (dwAllowed AND %DROPEFFECT_LINK) THEN dwEffect = %DROPEFFECT_LINK
                 END IF
                 METHOD = dwEffect
        
              END METHOD
              ' ----------------------------------------------------------------------------------
        The DragOver method is called whenever the state of the keyboard modifiers change or when the mouse moves. In our example, we call the DropEffect function to determine which drop effect is allowed and communicate it to the caller though the pdwEffect parameter.

        Code:
              ' ----------------------------------------------------------------------------------
              ' Provides target feedback to the user through the DoDragDrop function
              ' ----------------------------------------------------------------------------------
              METHOD DragOver ( _                       ' VTable offset = 16
                BYVAL grfKeyState AS DWORD _            ' // Current state of keyboard modifier keys
              , BYVAL pt AS POINTL _                    ' // Current cursor coordinates (Must be BYVAL)
              , BYREF pdwEffect AS DWORD _              ' // Pointer to the effect of the drag-and-drop operation
              ) AS LONG                                 ' HRESULT
        
                 IF bAllowDrop THEN
                    ' Get the dropeffect based on keyboard state
                    pdwEffect = ME.DropEffect(grfKeyState, pt, pdwEffect)
                 ELSE
                    pdwEffect = %DROPEFFECT_NONE
                 END IF
                 METHOD = %S_OK
        
              END METHOD
              ' ----------------------------------------------------------------------------------
        The DragLeave function is called whenever the mouse cursor is moved outside of our drop-target window, or the Escape key is pressed which cancels the drag-drop operation. In our example, we will simply return %S_OK.

        Code:
              ' ----------------------------------------------------------------------------------
              ' Causes the drop target to suspend its feedback actions
              ' ----------------------------------------------------------------------------------
              METHOD DragLeave ( _                      ' VTable offset = 20
              ) AS LONG                                 ' HRESULT
        
                 METHOD = %S_OK
        
              END METHOD
              ' ----------------------------------------------------------------------------------
        Finally, in the Drop method we call the GetData method of the caller implementation of the IDataObject interface through the passed pDataObject pointer to retrieve data from the clipboard. In our example, we get the text and show it in the label. The way it has been implemented allows both to drop selected text or an hyperlink.

        Code:
              ' ----------------------------------------------------------------------------------
              ' Drops the data into the target window
              ' ----------------------------------------------------------------------------------
              METHOD Drop ( _                           ' VTable offset = 24
                BYVAL pDataObject AS IDataObject _      ' // Pointer to the interface of the source data object
              , BYVAL grfKeyState AS DWORD _            ' // Current state of keyboard modifier keys
              , BYVAL pt AS POINTL _                    ' // Current cursor coordinates (Must be BYVAL)
              , BYREF pdwEffect AS DWORD _              ' // Pointer to the effect of the drag-and-drop operation
              ) AS LONG                                 ' HRESULT
        
                 pdwEffect = %DROPEFFECT_NONE
                 IF ISFALSE ISOBJECT(pDataObject) THEN
                    METHOD = %E_FAIL
                    EXIT METHOD
                 END IF
        
                 ' Get the dropeffect based on keyboard state
                 pdwEffect = ME.DropEffect(grfKeyState, pt, pdwEffect)
                 '  Ask IDataObject for some CF_TEXT data, stored as a HGLOBAL in the clipboard
                 IF bAllowDrop THEN
                    fmtc.cfFormat = %CF_TEXT
                    fmtc.ptd = %NULL
                    fmtc.dwAspect = %DVASPECT_CONTENT
                    fmtc.lindex = -1
                    fmtc.tymed = %TYMED_HGLOBAL
                    hr = pDataObject.GetData(fmtc, stgmed)
                    IF hr = %S_OK THEN
                       IF stgmed.hGlobal THEN
                          ' Lock the hGlobal handle just in case isn't fixed memory
                          pData = GlobalLock(stgmed.hGlobal)
                          ' Store the data in a string variable
                          strData = @pData
                          ' Show the data in the window
                          IF hwnd THEN SetWindowText hwnd, @pData
                          ' Unlock the global data
                          GlobalUnlock stgmed.hGlobal
                       END IF
                       ' Free the memory used by the STGMEDIUM structure
                       ReleaseStgMedium stgmed
                    END IF
                 END IF
        
                 ' Return success
                 METHOD = %S_OK
        
              END METHOD
              ' ----------------------------------------------------------------------------------
        Full example code (CWindow version)

        Code:
        ' ########################################################################################
        ' This example demostrates how to implement the IDropTarget interface with PowerBASIC
        ' and make a label the target of a drag and drop operation.
        ' Note: Instead of a label you can use any other kind of window.
        ' ########################################################################################
        
        #COMPILE EXE
        #DIM ALL
        
        ' // Include files for external files
        #INCLUDE ONCE "CWindow.inc"   ' // CWindow class
        #INCLUDE ONCE "oleidl.inc"
        
        ' ########################################################################################
        ' *** Custom implementation of the IDropTarget interface.
        ' The IDropTarget interface is one of the interfaces you implement to provide
        ' drag-and-drop operations in your application. It contains methods used in any
        ' application that can be a target for data during a drag-and-drop operation. A
        ' drop-target application is responsible for:
        
        '  * Determining the effect of the drop on the target application.
        '  * Incorporating any valid dropped data when the drop occurs.
        '  * Communicating target feedback to the source so the source application can provide
        '    appropriate visual feedback such as setting the cursor.
        '  * Implementing drag scrolling.
        '  * Registering and revoking its application windows as drop targets.
        
        ' The IDropTarget interface contains methods that handle all these responsibilities except
        ' registering and revoking the application window as a drop target, for which you must
        ' call the RegisterDragDrop and the RevokeDragDrop functions.
        ' You do not call the methods of IDropTarget directly. The DoDragDrop function calls the
        ' IDropTarget methods during the drag-and-drop operation.
        ' ########################################################################################
        
        $CLSID_CDropTarget = GUID$("{F9E4BF70-EFA8-411E-A142-F4B02D89D619}")
        $IID_IDropTarget = GUID$("{00000122-0000-0000-C000-000000000046}")
        
        ' // Need to declare it as common to avoid removal of methods
        CLASS CDropTarget $CLSID_CDropTarget AS COMMON
        
           INSTANCE hr AS LONG
           INSTANCE hwnd AS DWORD
           INSTANCE bAllowDrop AS LONG
           INSTANCE fmtc AS FORMATETC
           INSTANCE stgmed AS STGMEDIUM
           INSTANCE pData AS ASCIIZ PTR
           INSTANCE strData AS STRING
        
           INTERFACE IDropTargetImpl $IID_IDropTarget
        
              INHERIT IUnknown
        
              ' ----------------------------------------------------------------------------------
              ' Determines whether a drop can be accepted and its effect if it is accepted
              ' ----------------------------------------------------------------------------------
              METHOD DragEnter ( _                      ' VTable offset = 12
                BYVAL pDataObject AS IDataObject _      ' // Pointer to the interface of the source data object
              , BYVAL grfKeyState AS DWORD _            ' // Current state of keyboard modifier keys
              , BYVAL pt AS POINTL _                    ' // Current cursor coordinates (Must be BYVAL)
              , BYREF pdwEffect AS DWORD _              ' // Pointer to the effect of the drag-and-drop operation
              ) AS LONG                                 ' HRESULT
        
                 pdwEffect = %DROPEFFECT_NONE
                 IF ISFALSE ISOBJECT(pDataObject) THEN
                    METHOD = %E_FAIL
                    EXIT METHOD
                 END IF
        
                 ' Check if the data object contains the data we want
                 bAllowDrop = ME.QueryDataObject(pDataObject)
                 IF bAllowDrop THEN
                    ' Get the dropeffect based on keyboard state
                    pdwEffect = ME.DropEffect(grfKeyState, pt, pdwEffect)
                    ' Bring the window to the foregroung
                    IF hwnd THEN SetForegroundWindow hwnd
                 END IF
        
                 ' Return success
                 METHOD = %S_OK
        
              END METHOD
              ' ----------------------------------------------------------------------------------
        
              ' ----------------------------------------------------------------------------------
              ' Provides target feedback to the user through the DoDragDrop function
              ' ----------------------------------------------------------------------------------
              METHOD DragOver ( _                       ' VTable offset = 16
                BYVAL grfKeyState AS DWORD _            ' // Current state of keyboard modifier keys
              , BYVAL pt AS POINTL _                    ' // Current cursor coordinates (Must be BYVAL)
              , BYREF pdwEffect AS DWORD _              ' // Pointer to the effect of the drag-and-drop operation
              ) AS LONG                                 ' HRESULT
        
                 IF bAllowDrop THEN
                    ' Get the dropeffect based on keyboard state
                    pdwEffect = ME.DropEffect(grfKeyState, pt, pdwEffect)
                 ELSE
                    pdwEffect = %DROPEFFECT_NONE
                 END IF
                 METHOD = %S_OK
        
              END METHOD
              ' ----------------------------------------------------------------------------------
        
              ' ----------------------------------------------------------------------------------
              ' Causes the drop target to suspend its feedback actions
              ' ----------------------------------------------------------------------------------
              METHOD DragLeave ( _                      ' VTable offset = 20
              ) AS LONG                                 ' HRESULT
        
                 METHOD = %S_OK
        
              END METHOD
              ' ----------------------------------------------------------------------------------
        
              ' ----------------------------------------------------------------------------------
              ' Drops the data into the target window
              ' ----------------------------------------------------------------------------------
              METHOD Drop ( _                           ' VTable offset = 24
                BYVAL pDataObject AS IDataObject _      ' // Pointer to the interface of the source data object
              , BYVAL grfKeyState AS DWORD _            ' // Current state of keyboard modifier keys
              , BYVAL pt AS POINTL _                    ' // Current cursor coordinates (Must be BYVAL)
              , BYREF pdwEffect AS DWORD _              ' // Pointer to the effect of the drag-and-drop operation
              ) AS LONG                                 ' HRESULT
        
                 pdwEffect = %DROPEFFECT_NONE
                 IF ISFALSE ISOBJECT(pDataObject) THEN
                    METHOD = %E_FAIL
                    EXIT METHOD
                 END IF
        
                 ' Get the dropeffect based on keyboard state
                 pdwEffect = ME.DropEffect(grfKeyState, pt, pdwEffect)
                 '  Ask IDataObject for some CF_TEXT data, stored as a HGLOBAL in the clipboard
                 IF bAllowDrop THEN
                    fmtc.cfFormat = %CF_TEXT
                    fmtc.ptd = %NULL
                    fmtc.dwAspect = %DVASPECT_CONTENT
                    fmtc.lindex = -1
                    fmtc.tymed = %TYMED_HGLOBAL
                    hr = pDataObject.GetData(fmtc, stgmed)
                    IF hr = %S_OK THEN
                       IF stgmed.hGlobal THEN
                          ' Lock the hGlobal handle just in case isn't fixed memory
                          pData = GlobalLock(stgmed.hGlobal)
                          ' Store the data in a string variable
                          strData = @pData
                          ' Show the data in the window
                          IF hwnd THEN SetWindowText hwnd, @pData
                          ' Unlock the global data
                          GlobalUnlock stgmed.hGlobal
                       END IF
                       ' Free the memory used by the STGMEDIUM structure
                       ReleaseStgMedium stgmed
                    END IF
                 END IF
        
                 ' Return success
                 METHOD = %S_OK
        
              END METHOD
              ' ----------------------------------------------------------------------------------
        
              ' ==================================================================================
              ' *** We can add custom methods and properties here ***
              ' ==================================================================================
        
              ' ----------------------------------------------------------------------------------
              ' Window handle of the control that has been registered for drag and drop operations
              ' ----------------------------------------------------------------------------------
              METHOD SetHwnd (BYVAL hndl AS DWORD) AS LONG
                 hwnd = hndl
                 METHOD = %S_OK
              END METHOD
              ' ----------------------------------------------------------------------------------
        
              ' ----------------------------------------------------------------------------------
              ' Returns an string containing the text of the dropped link or text
              ' ----------------------------------------------------------------------------------
              METHOD GetData (BYREF pstrData AS STRING) AS LONG
                 pstrData = strData
                 METHOD = %S_OK
              END METHOD
              ' ----------------------------------------------------------------------------------
        
              ' ----------------------------------------------------------------------------------
              ' Retrieves the allowed drop effect
              ' ----------------------------------------------------------------------------------
              METHOD DropEffect (BYVAL grfKeyState AS DWORD, BYVAL pt AS POINTL, BYVAL dwAllowed AS DWORD) AS DWORD
        
                 LOCAL dwEffect  AS DWORD
        
                 ' 1. Check "pt" -> Is a  drop allowed at the specified coordinates?
                 ' 2. Work out that the drop-effect should be based on grfKeyState
                 IF (grfKeyState AND %MK_CONTROL) THEN
                    dwEffect = dwAllowed AND %DROPEFFECT_COPY
                 ELSEIF (grfKeyState AND %MK_SHIFT) THEN
                    dwEffect = dwAllowed AND %DROPEFFECT_MOVE
                 END IF
        
                 ' 3. No key-modifiers were specified (or drop effect not allowed), so
                 '    base the effect on those allowed by the dropsource
                 IF dwEffect = 0 THEN
                    IF (dwAllowed AND %DROPEFFECT_COPY) THEN dwEffect = %DROPEFFECT_COPY
                    IF (dwAllowed AND %DROPEFFECT_MOVE) THEN dwEffect = %DROPEFFECT_MOVE
                    IF (dwAllowed AND %DROPEFFECT_LINK) THEN dwEffect = %DROPEFFECT_LINK
                 END IF
                 METHOD = dwEffect
        
              END METHOD
              ' ----------------------------------------------------------------------------------
        
              ' ----------------------------------------------------------------------------------
              ' Checks if the data object contains the data we want.
              ' In this example, asks for some CF_TEXT data, stored as a HGLOBAL in the clipboard
              ' ----------------------------------------------------------------------------------
              METHOD QueryDataObject (BYVAL pDataObject AS IDataObject) AS LONG
        
                 LOCAL hr AS LONG
                 LOCAL fmtc AS FORMATETC
                 LOCAL stgmed AS STGMEDIUM
        
                 fmtc.cfFormat = %CF_TEXT
                 fmtc.ptd = %NULL
                 fmtc.dwAspect = %DVASPECT_CONTENT
                 fmtc.lindex = -1
                 fmtc.tymed = %TYMED_HGLOBAL
                 hr = pDataObject.GetData(fmtc, stgmed)
                 IF hr = %S_OK THEN
                    IF stgmed.hGlobal THEN METHOD = %TRUE
                    ReleaseStgMedium stgmed
                 END IF
        
              END METHOD
              ' ----------------------------------------------------------------------------------
        
           END INTERFACE
        
        END CLASS
        ' ########################################################################################
        
        
        ' ########################################################################################
        ' Testing code
        ' ########################################################################################
        
        %IDC_LABEL = 1001
        
        ' ========================================================================================
        ' Main
        ' ========================================================================================
        FUNCTION WinMain (BYVAL hInstance AS DWORD, BYVAL hPrevInstance AS DWORD, BYVAL lpszCmdLine AS WSTRINGZ PTR, BYVAL nCmdShow AS LONG) AS LONG
        
           ' // Set process DPI aware
        '   SetProcessDPIAware
        
           ' Initialize the COM library
           OleInitialize %NULL
        
           ' // Create an instance of the class
           LOCAL pWindow AS IWindow
           pWindow = CLASS "CWindow"
           IF ISNOTHING(pWindow) THEN EXIT FUNCTION
        
           ' // Create the main window
           ' // Note: CW_USEDEFAULT is used as the default value When passing 0's as the width and height
           pWindow.CreateWindow(%NULL, "IDropTarget Demo", 0, 0, 0, 0, 0, %WS_EX_TOPMOST, CODEPTR(WindowProc))
           ' // Set the client size
           pWindow.SetClientSize 400, 80
           ' // Center the window
           pWindow.CenterWindow
        
           ' // Default message pump (you can replace it with your own)
           pWindow.DoEvents(nCmdShow)
        
           ' Uninitialize the COM library
           OleUninitialize
        
        END FUNCTION
        ' ========================================================================================
        
        ' ========================================================================================
        ' Main callback function.
        ' ========================================================================================
        FUNCTION WindowProc (BYVAL hwnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG
        
           LOCAL hr AS LONG
           STATIC hLabel AS DWORD
           STATIC pDropTarget AS IDropTargetImpl
           STATIC pWindow AS IWindow
        
           SELECT CASE uMsg
        
              CASE %WM_CREATE
                 ' // Get a reference to the IWindow interface from the CREATESTRUCT structure
                 pWindow = CWindow_GetObjectFromCreateStruct(lParam)
                 ' // Add a label
                 hLabel = pWindow.AddLabel(hwnd, %IDC_LABEL, "Drop a link here...", 20, 30, 360, 20, %WS_VISIBLE OR %WS_CHILD OR %WS_BORDER)
                 IF hLabel THEN
                    ' Create a new instance of our implemented IDropTarget interface
                    pDropTarget = CLASS "CDropTarget"
                    IF ISOBJECT(pDropTarget) THEN
                       ' Sets the handle of the label
                       pDropTarget.SetHwnd hLabel
                       ' Locks the object to ensure that it stays in memory
                       hr = CoLockObjectExternal(pDropTarget, %TRUE, %FALSE)
                       ' Registers the specified window as one that can be the target
                       ' of an OLE drag-and-drop operation and specifies the IDropTarget
                       ' instance to use for drop operations.
                       hr = RegisterDragDrop(hLabel, pDropTarget)
                    END IF
                 END IF
                 EXIT FUNCTION
        
              CASE %WM_COMMAND
                 SELECT CASE LO(WORD, wParam)
                    CASE %IDCANCEL
                       ' // If the Escape key has been pressed...
                       IF HI(WORD, wParam) = %BN_CLICKED THEN
                          ' // ... close the application by sending a WM_CLOSE message
                          SendMessage hwnd, %WM_CLOSE, 0, 0
                          EXIT FUNCTION
                       END IF
                 END SELECT
        
              CASE %WM_DESTROY
                 ' // Revokes the registration of the specified application window as a
                 ' // potential target for OLE drag-and-drop operations.
                 IF hLabel THEN RevokeDragDrop hLabel
                 IF ISOBJECT(pDropTarget) THEN
                    ' // Unlocks our IDropTarget interface
                    hr = CoLockObjectExternal(pDropTarget, %FALSE, %FALSE)
                    ' // Frees the memory used by our IDropTarget interface
                    pDropTarget = NOTHING
                 END IF
                 ' // End the application
                 PostQuitMessage 0
                 EXIT FUNCTION
        
           END SELECT
        
           ' // Pass unprocessed messages to Windows
           FUNCTION = DefWindowProc(hwnd, uMsg, wParam, lParam)
        
        END FUNCTION
        ' ========================================================================================
        Full example code (DDT version)

        Code:
        ' ########################################################################################
        ' This example demostrates how to implement the IDropTarget interface with PowerBASIC
        ' and make a label the target of a drag and drop operation.
        ' Note: Instead of a label you can use any other kind of window.
        ' ########################################################################################
        
        #COMPILE EXE
        #DIM ALL
        
        ' // Include files for external files
        #INCLUDE ONCE "CWindow.inc"   ' // CWindow class
        #INCLUDE ONCE "oleidl.inc"
        
        ' ########################################################################################
        ' *** Custom implementation of the IDropTarget interface.
        ' The IDropTarget interface is one of the interfaces you implement to provide
        ' drag-and-drop operations in your application. It contains methods used in any
        ' application that can be a target for data during a drag-and-drop operation. A
        ' drop-target application is responsible for:
        
        '  * Determining the effect of the drop on the target application.
        '  * Incorporating any valid dropped data when the drop occurs.
        '  * Communicating target feedback to the source so the source application can provide
        '    appropriate visual feedback such as setting the cursor.
        '  * Implementing drag scrolling.
        '  * Registering and revoking its application windows as drop targets.
        
        ' The IDropTarget interface contains methods that handle all these responsibilities except
        ' registering and revoking the application window as a drop target, for which you must
        ' call the RegisterDragDrop and the RevokeDragDrop functions.
        ' You do not call the methods of IDropTarget directly. The DoDragDrop function calls the
        ' IDropTarget methods during the drag-and-drop operation.
        ' ########################################################################################
        
        $CLSID_CDropTarget = GUID$("{F9E4BF70-EFA8-411E-A142-F4B02D89D619}")
        $IID_IDropTarget = GUID$("{00000122-0000-0000-C000-000000000046}")
        
        ' // Need to declare it as common to avoid removal of methods
        CLASS CDropTarget $CLSID_CDropTarget AS COMMON
        
           INSTANCE hr AS LONG
           INSTANCE hwnd AS DWORD
           INSTANCE bAllowDrop AS LONG
           INSTANCE fmtc AS FORMATETC
           INSTANCE stgmed AS STGMEDIUM
           INSTANCE pData AS ASCIIZ PTR
           INSTANCE strData AS STRING
        
           INTERFACE IDropTargetImpl $IID_IDropTarget
        
              INHERIT IUnknown
        
              ' ----------------------------------------------------------------------------------
              ' Determines whether a drop can be accepted and its effect if it is accepted
              ' ----------------------------------------------------------------------------------
              METHOD DragEnter ( _                      ' VTable offset = 12
                BYVAL pDataObject AS IDataObject _      ' // Pointer to the interface of the source data object
              , BYVAL grfKeyState AS DWORD _            ' // Current state of keyboard modifier keys
              , BYVAL pt AS POINTL _                    ' // Current cursor coordinates (Must be BYVAL)
              , BYREF pdwEffect AS DWORD _              ' // Pointer to the effect of the drag-and-drop operation
              ) AS LONG                                 ' HRESULT
        
                 pdwEffect = %DROPEFFECT_NONE
                 IF ISFALSE ISOBJECT(pDataObject) THEN
                    METHOD = %E_FAIL
                    EXIT METHOD
                 END IF
        
                 ' Check if the data object contains the data we want
                 bAllowDrop = ME.QueryDataObject(pDataObject)
                 IF bAllowDrop THEN
                    ' Get the dropeffect based on keyboard state
                    pdwEffect = ME.DropEffect(grfKeyState, pt, pdwEffect)
                    ' Bring the window to the foregroung
                    IF hwnd THEN SetForegroundWindow hwnd
                 END IF
        
                 ' Return success
                 METHOD = %S_OK
        
              END METHOD
              ' ----------------------------------------------------------------------------------
        
              ' ----------------------------------------------------------------------------------
              ' Provides target feedback to the user through the DoDragDrop function
              ' ----------------------------------------------------------------------------------
              METHOD DragOver ( _                       ' VTable offset = 16
                BYVAL grfKeyState AS DWORD _            ' // Current state of keyboard modifier keys
              , BYVAL pt AS POINTL _                    ' // Current cursor coordinates (Must be BYVAL)
              , BYREF pdwEffect AS DWORD _              ' // Pointer to the effect of the drag-and-drop operation
              ) AS LONG                                 ' HRESULT
        
                 IF bAllowDrop THEN
                    ' Get the dropeffect based on keyboard state
                    pdwEffect = ME.DropEffect(grfKeyState, pt, pdwEffect)
                 ELSE
                    pdwEffect = %DROPEFFECT_NONE
                 END IF
                 METHOD = %S_OK
        
              END METHOD
              ' ----------------------------------------------------------------------------------
        
              ' ----------------------------------------------------------------------------------
              ' Causes the drop target to suspend its feedback actions
              ' ----------------------------------------------------------------------------------
              METHOD DragLeave ( _                      ' VTable offset = 20
              ) AS LONG                                 ' HRESULT
        
                 METHOD = %S_OK
        
              END METHOD
              ' ----------------------------------------------------------------------------------
        
              ' ----------------------------------------------------------------------------------
              ' Drops the data into the target window
              ' ----------------------------------------------------------------------------------
              METHOD Drop ( _                           ' VTable offset = 24
                BYVAL pDataObject AS IDataObject _      ' // Pointer to the interface of the source data object
              , BYVAL grfKeyState AS DWORD _            ' // Current state of keyboard modifier keys
              , BYVAL pt AS POINTL _                    ' // Current cursor coordinates (Must be BYVAL)
              , BYREF pdwEffect AS DWORD _              ' // Pointer to the effect of the drag-and-drop operation
              ) AS LONG                                 ' HRESULT
        
                 pdwEffect = %DROPEFFECT_NONE
                 IF ISFALSE ISOBJECT(pDataObject) THEN
                    METHOD = %E_FAIL
                    EXIT METHOD
                 END IF
        
                 ' Get the dropeffect based on keyboard state
                 pdwEffect = ME.DropEffect(grfKeyState, pt, pdwEffect)
                 '  Ask IDataObject for some CF_TEXT data, stored as a HGLOBAL in the clipboard
                 IF bAllowDrop THEN
                    fmtc.cfFormat = %CF_TEXT
                    fmtc.ptd = %NULL
                    fmtc.dwAspect = %DVASPECT_CONTENT
                    fmtc.lindex = -1
                    fmtc.tymed = %TYMED_HGLOBAL
                    hr = pDataObject.GetData(fmtc, stgmed)
                    IF hr = %S_OK THEN
                       IF stgmed.hGlobal THEN
                          ' Lock the hGlobal handle just in case isn't fixed memory
                          pData = GlobalLock(stgmed.hGlobal)
                          ' Store the data in a string variable
                          strData = @pData
                          ' Show the data in the window
                          IF hwnd THEN SetWindowText hwnd, @pData
                          ' Unlock the global data
                          GlobalUnlock stgmed.hGlobal
                       END IF
                       ' Free the memory used by the STGMEDIUM structure
                       ReleaseStgMedium stgmed
                    END IF
                 END IF
        
                 ' Return success
                 METHOD = %S_OK
        
              END METHOD
              ' ----------------------------------------------------------------------------------
        
              ' ==================================================================================
              ' *** We can add custom methods and properties here ***
              ' ==================================================================================
        
              ' ----------------------------------------------------------------------------------
              ' Window handle of the control that has been registered for drag and drop operations
              ' ----------------------------------------------------------------------------------
              METHOD SetHwnd (BYVAL hndl AS DWORD) AS LONG
                 hwnd = hndl
                 METHOD = %S_OK
              END METHOD
              ' ----------------------------------------------------------------------------------
        
              ' ----------------------------------------------------------------------------------
              ' Returns an string containing the text of the dropped link or text
              ' ----------------------------------------------------------------------------------
              METHOD GetData (BYREF pstrData AS STRING) AS LONG
                 pstrData = strData
                 METHOD = %S_OK
              END METHOD
              ' ----------------------------------------------------------------------------------
        
              ' ----------------------------------------------------------------------------------
              ' Retrieves the allowed drop effect
              ' ----------------------------------------------------------------------------------
              METHOD DropEffect (BYVAL grfKeyState AS DWORD, BYVAL pt AS POINTL, BYVAL dwAllowed AS DWORD) AS DWORD
        
                 LOCAL dwEffect  AS DWORD
        
                 ' 1. Check "pt" -> Is a  drop allowed at the specified coordinates?
                 ' 2. Work out that the drop-effect should be based on grfKeyState
                 IF (grfKeyState AND %MK_CONTROL) THEN
                    dwEffect = dwAllowed AND %DROPEFFECT_COPY
                 ELSEIF (grfKeyState AND %MK_SHIFT) THEN
                    dwEffect = dwAllowed AND %DROPEFFECT_MOVE
                 END IF
        
                 ' 3. No key-modifiers were specified (or drop effect not allowed), so
                 '    base the effect on those allowed by the dropsource
                 IF dwEffect = 0 THEN
                    IF (dwAllowed AND %DROPEFFECT_COPY) THEN dwEffect = %DROPEFFECT_COPY
                    IF (dwAllowed AND %DROPEFFECT_MOVE) THEN dwEffect = %DROPEFFECT_MOVE
                    IF (dwAllowed AND %DROPEFFECT_LINK) THEN dwEffect = %DROPEFFECT_LINK
                 END IF
                 METHOD = dwEffect
        
              END METHOD
              ' ----------------------------------------------------------------------------------
        
              ' ----------------------------------------------------------------------------------
              ' Checks if the data object contains the data we want.
              ' In this example, asks for some CF_TEXT data, stored as a HGLOBAL in the clipboard
              ' ----------------------------------------------------------------------------------
              METHOD QueryDataObject (BYVAL pDataObject AS IDataObject) AS LONG
        
                 LOCAL hr AS LONG
                 LOCAL fmtc AS FORMATETC
                 LOCAL stgmed AS STGMEDIUM
        
                 fmtc.cfFormat = %CF_TEXT
                 fmtc.ptd = %NULL
                 fmtc.dwAspect = %DVASPECT_CONTENT
                 fmtc.lindex = -1
                 fmtc.tymed = %TYMED_HGLOBAL
                 hr = pDataObject.GetData(fmtc, stgmed)
                 IF hr = %S_OK THEN
                    IF stgmed.hGlobal THEN METHOD = %TRUE
                    ReleaseStgMedium stgmed
                 END IF
        
              END METHOD
              ' ----------------------------------------------------------------------------------
        
           END INTERFACE
        
        END CLASS
        ' ########################################################################################
        
        
        ' ########################################################################################
        ' Testing code
        ' ########################################################################################
        
        %IDC_LABEL = 1001
        
        ' ========================================================================================
        ' Main
        ' ========================================================================================
        FUNCTION WINMAIN (BYVAL hInstance AS DWORD, BYVAL hPrevInstance AS DWORD, BYVAL lpszCmdLine AS ASCIIZ PTR, BYVAL nCmdShow AS LONG) AS LONG
        
           LOCAL hDlg AS LONG
        
           ' Initialize the COM library
           OleInitialize %NULL
        
           DIALOG NEW PIXELS, 0, "IDropTarget Demo", , , 400, 80, %WS_OVERLAPPED OR %WS_THICKFRAME OR %WS_SYSMENU OR _
           %WS_MINIMIZEBOX OR %WS_MAXIMIZEBOX OR %WS_VISIBLE OR %DS_CENTER, %WS_EX_TOPMOST TO hDlg
           DIALOG SHOW MODAL hDlg, CALL DlgProc
        
           ' Uninitialize the COM library
           OleUninitialize
        
        END FUNCTION
        ' ========================================================================================
        
        ' ========================================================================================
        ' Main Dialog procedure
        ' ========================================================================================
        CALLBACK FUNCTION DlgProc() AS LONG
        
           LOCAL hr AS LONG
           STATIC hLabel AS DWORD
           STATIC pDropTarget AS IDropTargetImpl
        
           SELECT CASE CBMSG
        
              CASE %WM_INITDIALOG
                 '  Creates a label control
                 CONTROL ADD LABEL, CBHNDL, %IDC_LABEL, "Drop a link here...", 20, 30, 360, 20, %WS_VISIBLE OR %WS_CHILD OR %WS_BORDER
                 ' Gets the handle of the label
                 CONTROL HANDLE CBHNDL, %IDC_LABEL to hLabel
                 IF hLabel THEN
                    ' Create a new instance of our implemented IDropTarget interface
                    pDropTarget = CLASS "CDropTarget"
                    IF ISOBJECT(pDropTarget) THEN
                       ' Sets the handle of the label
                       pDropTarget.SetHwnd hLabel
                       ' Locks the object to ensure that it stays in memory
                       hr = CoLockObjectExternal(pDropTarget, %TRUE, %FALSE)
                       ' Registers the specified window as one that can be the target
                       ' of an OLE drag-and-drop operation and specifies the IDropTarget
                       ' instance to use for drop operations.
                       hr = RegisterDragDrop(hLabel, pDropTarget)
                    END IF
                 END IF
        
              CASE %WM_COMMAND
                 SELECT CASE CBCTL
                    CASE %IDCANCEL
                       IF CBCTLMSG = %BN_CLICKED THEN DIALOG END CBHNDL, 0
                 END SELECT
        
              CASE %WM_DESTROY
                 ' // Revokes the registration of the specified application window as a
                 ' // potential target for OLE drag-and-drop operations.
                 IF hLabel THEN RevokeDragDrop hLabel
                 IF ISOBJECT(pDropTarget) THEN
                    ' // Unlocks our IDropTarget interface
                    hr = CoLockObjectExternal(pDropTarget, %FALSE, %FALSE)
                    ' // Frees the memory used by our IDropTarget interface
                    pDropTarget = NOTHING
                 END IF
        
           END SELECT
        
        END FUNCTION
        ' ========================================================================================
        Forum: http://www.jose.it-berater.org/smfforum/index.php

        Comment


        • #5
          How to create a type library programatically

          Demonstrates how to create an OLE Automation type library using the ICreateTypeLib and ICreateTypeInfo interfaces. The type library that is created is called hello.tlb and corresponds to one that would have been built by mktyplib.exe if it had compiled the following .odl file.

          Code:
          [
            uuid(2F6CA420-C641-101A-B826-00DD01103DE1),            // LIBID_Hello
            helpstring("Hello 1.0 Type Library"),
            lcid(0x0409),
            version(1.0)
          ] 
          library Hello
          {
          #ifdef WIN32
              importlib("stdole32.tlb");
          #else
              importlib("stdole.tlb");
          #endif
              
              [
                uuid(2F6CA422-C641-101A-B826-00DD01103DE1),        // IID_IHello
                helpstring("Hello Interface")
              ]
              interface IHello : IUnknown
              {
                  [propput] void HelloMessage([in] BSTR Message);
                  [propget] BSTR HelloMessage(void);
                  void SayHello(void);        
              }
              [
                uuid(2F6CA423-C641-101A-B826-00DD01103DE1),        // IID_DHello
                helpstring("Hello Dispinterface")
              ]  
              dispinterface DHello
              {
                interface IHello;
              }                                         
              
              [
                 uuid(2F6CA421-C641-101A-B826-00DD01103DE1),       // CLSID_Hello
                 helpstring("Hello Class")
              ]                                             
              coclass Hello
              {   
                  dispinterface DHello;
                  interface IHello;
              }
          }
          The following PowerBASIC example is based in the C program TYPEBLD, written by Microsoft Product Support Services, Windows Developer Support (c) Copyright Microsoft Corp. 1995.

          http://support.microsoft.com/kb/131105/EN-US/

          Code:
          ' ========================================================================================
          ' Demonstrates how to build a type library programatically.
          ' Based on the C program TypeBld, written by Microsoft Product Support Services, Windows
          ' Developer Support (c) Copyright Microsoft Corp. 1995.
          ' ========================================================================================
          
          #COMPILE EXE
          #DIM ALL
          #INCLUDE ONCE "OleAuto.inc"
          
          $LIBID_Hello = GUID$("{2F6CA420-C641-101A-B826-00DD01103DE1}")
          $CLSID_Hello = GUID$("{2F6CA421-C641-101A-B826-00DD01103DE1}")
          $IID_IHello = GUID$("{2F6CA422-C641-101A-B826-00DD01103DE1}")
          $IID_DHello = GUID$("{2F6CA423-C641-101A-B826-00DD01103DE1}")
          
          ' ========================================================================================
          ' Create the type infos
          ' ========================================================================================
          FUNCTION CreateTypeInfos (BYVAL pctlib AS ICreateTypeLib) AS LONG
          
             LOCAL hr AS LONG
          
             LOCAL wszText AS WSTRINGZ * 260            ' // General purpose variable
             LOCAL ptlibStdOle AS ITypeLib              ' // ITypeLib reference pointer
             LOCAL ptinfoIUnknown AS ITypeInfo          ' // ITypeInfo reference pointer
             LOCAL ptinfoIDispatch AS ITypeInfo         ' // ITypeInfo reference pointer
             LOCAL pctinfo AS ICreateTypeInfo           ' // ICreateTypeInfo reference pointer
             LOCAL hreftype AS DWORD                    ' // Reference type
          
             wszText = "stdole32.tlb"
             hr = LoadTypeLib(wszText, ptlibStdOle)
             hr = ptlibStdOle.GetTypeInfoOfGuid($IID_IUNKNOWN, ptinfoIUnknown)
             hr = ptlibStdOle.GetTypeInfoOfGuid($IID_IDISPATCH, ptinfoIDispatch)
             ptlibStdOle = NOTHING
          
             wszText = "IHello"
             hr = pctlib.CreateTypeInfo(wszText, %TKIND_INTERFACE, pctinfo)
             hr = pctinfo.SetGuid($IID_IHello)
             wszText = "Hello interface"
             hr = pctinfo.SetDocString(wszText)
          
             ' Save typeinfo of IHello for others who may refer to it.
             LOCAL ptinfoIHello AS ITypeInfo
             ptinfoIHello = pctinfo
          
             ' Output base interface of IHello (IUnknown)
             hr = pctinfo.AddRefTypeInfo(ptinfoIUnknown, hreftype)
             hr = pctinfo.AddImplType(0, hreftype)
          
             LOCAL tfuncdesc AS FUNCDESC
          
             ' Output [propget, id(0)] BSTR HelloMessage(void)
             DIM rgszFuncArgNamesHM(0) AS WSTRING
             rgszFuncArgNamesHM(0) = "HelloMessage"
          
             tfuncdesc.memid = 0
             tfuncdesc.lprgscode = %NULL
             tfuncdesc.lprgelemdescParam = %NULL
             tfuncdesc.funckind = %FUNC_PUREVIRTUAL
             tfuncdesc.invkind = %INVOKE_PROPERTYGET
             tfuncdesc.callconv = %CC_STDCALL
             tfuncdesc.cParams = 0
             tfuncdesc.cParamsOpt = 0
             tfuncdesc.oVft = 0         ' This will be assigned by ICreateTypeInfo.LayOut
             tfuncdesc.cScodes = 0
             tfuncdesc.elemdescFunc.tdesc.vt = %VT_BSTR
             tfuncdesc.elemdescFunc.idldesc.dwReserved = %NULL
             tfuncdesc.elemdescFunc.idldesc.wIDLFlags  = %IDLFLAG_NONE
             tfuncdesc.wFuncFlags = 0
          
             hr = pctinfo.AddFuncDesc(0, tfuncdesc)
             hr = pctinfo.SetFuncAndParamNames(0, rgszFuncArgNamesHM(0), 1)
          
             ' Output [propput, id(0)] void HelloMessage([in] BSTR Message)
             LOCAL telemdesc AS ELEMDESC
          
             telemdesc.tdesc.vt = %VT_BSTR
             telemdesc.idldesc.dwReserved = %NULL
             telemdesc.idldesc.wIDLFlags  = %IDLFLAG_FIN
          
             tfuncdesc.memid = 0
             tfuncdesc.lprgscode = %NULL
             tfuncdesc.lprgelemdescParam = VARPTR(telemdesc)
             tfuncdesc.funckind = %FUNC_PUREVIRTUAL
             tfuncdesc.invkind = %INVOKE_PROPERTYPUT
             tfuncdesc.callconv = %CC_STDCALL
             tfuncdesc.cParams = 1
             tfuncdesc.cParamsOpt = 0
             tfuncdesc.oVft = 0
             tfuncdesc.cScodes = 0
             tfuncdesc.elemdescFunc.tdesc.vt = %VT_VOID
             tfuncdesc.elemdescFunc.idldesc.dwReserved = %NULL
             tfuncdesc.elemdescFunc.idldesc.wIDLFlags = %IDLFLAG_NONE
          
             hr = pctinfo.AddFuncDesc(1, tfuncdesc)
             hr = pctinfo.SetFuncAndParamNames(1, rgszFuncArgNamesHM(0), 1)
          
             ' // pctinfo->SetFuncAndParamNames is supposed to be called
             ' // only once per property. However unless it is called for both
             ' // the propput and propget, an exception will occur in 32 bit when
             ' // ICreateTypeInfo::LayOut is called.
             ' // This problem doesn't exist in 16 bit.
          
             ' // [id(1)] void SayHello(void)
             DIM rgszFuncArgNamesSH(0) AS WSTRING
             rgszFuncArgNamesSH(0) = "SayHello"
          
             tfuncdesc.memid = 1
             tfuncdesc.lprgscode = %NULL
             tfuncdesc.lprgelemdescParam = %NULL
             tfuncdesc.funckind = %FUNC_PUREVIRTUAL
             tfuncdesc.invkind = %INVOKE_FUNC
             tfuncdesc.callconv = %CC_STDCALL
             tfuncdesc.cParams = 0
             tfuncdesc.cParamsOpt = 0
             tfuncdesc.oVft = 0
             tfuncdesc.cScodes = 0
             tfuncdesc.elemdescFunc.tdesc.vt = %VT_VOID
             tfuncdesc.elemdescFunc.idldesc.dwReserved = %NULL
             tfuncdesc.elemdescFunc.idldesc.wIDLFlags  = %IDLFLAG_NONE
             tfuncdesc.wFuncFlags = 0
          
             hr = pctinfo.AddFuncDesc(2, tfuncdesc)
             hr = pctinfo.SetFuncAndParamNames(2, rgszFuncArgNamesSH(0), 1)
          
             hr = pctinfo.LayOut
             pctinfo = NOTHING
          
          '    /*
          '    Generate the typeinfo for the following dispinterface
          
          '    [
          '      uuid(2F6CA423-C641-101A-B826-00DD01103DE1),        // IID_DHello
          '      helpstring("Hello Dispinterface")
          '    ]
          '    dispinterface DHello
          '    {
          '      interface IHello;
          '    }
          '    */
          
             wszText = "DHello"
             hr = pctlib.CreateTypeInfo(wszText, %TKIND_DISPATCH, pctinfo)
             hr = pctinfo.SetGuid($IID_DHello)
             wszText = "Hello Dispinterface"
             hr = pctinfo.SetDocString(wszText)
          
             ' Save typeinfo of IHello for others who may refer to it.
             LOCAL ptinfoDHello AS ITypeInfo
             ptinfoDHello = pctinfo
          
             ' Output base interface of DHello (IDispatch)
             hr = pctinfo.AddRefTypeInfo(ptinfoIDispatch, hreftype)
             hr = pctinfo.AddImplType(0, hreftype)
          
             ' Specify interface IHello that is wrapped by DHello
             hr = pctinfo.AddRefTypeInfo(ptinfoIHello, hreftype)
             hr = pctinfo.AddImplType(1, hreftype)
          
             hr = pctinfo.LayOut
             pctinfo = NOTHING
          
          
          '    /*
          '    Generate the typeinfo for the following coclass
          
          '    [
          '       uuid(2F6CA421-C641-101A-B826-00DD01103DE1),       // CLSID_Hello
          '       helpstring("Hello Class")
          '    ]
          '    coclass Hello
          '    {
          '        dispinterface DHello;
          '        interface IHello;
          '    }
          '   */
          
             wszText = "Hello"
             hr = pctlib.CreateTypeInfo(wszText, %TKIND_COCLASS, pctinfo)
          
             hr = pctinfo.SetGuid($CLSID_Hello)
             wszText = "Hello Class"
             hr = pctinfo.SetDocString(wszText)
          
             ' List DHello & IHello in the coclass
             hr = pctinfo.AddRefTypeInfo(ptinfoDHello, hreftype)
             hr = pctinfo.AddImplType(0, hreftype)
             hr = pctinfo.AddRefTypeInfo(ptinfoIHello, hreftype)
             hr = pctinfo.AddImplType(1, hreftype)
          
             hr = pctinfo.LayOut
             pctinfo = NOTHING
          
             ptinfoIUnknown = NOTHING
             ptinfoIDispatch = NOTHING
             ptinfoIHello = NOTHING
             ptinfoDHello = NOTHING
          
             FUNCTION = %NOERROR
          
          END FUNCTION
          ' ========================================================================================
          
          ' ========================================================================================
          ' Main
          ' ========================================================================================
          FUNCTION PBMAIN () AS LONG
          
          
             LOCAL hr AS LONG
             LOCAL wszText AS WSTRINGZ * 260
             LOCAL pctlib AS ICreateTypeLib
          
             wszText = "hello.tlb"
             hr = CreateTypeLib(%SYS_WIN32, wszText, pctlib)
             IF hr <> %S_OK THEN EXIT FUNCTION
             hr = pctlib.SetLcid(&H409)
             hr = pctlib.SetVersion(1, 0)
             wszText = "Hello"
             hr = pctlib.SetName(wszText)
             hr = pctlib.SetGUID($LIBID_Hello)
             wszText = "Hello 1.0 Type Library"
             hr = pctlib.SetDocString(wszText)
             hr = CreateTypeInfos(pctlib)
             IF hr = %NOERROR THEN hr = pctlib.SaveAllChanges
             pctlib = NOTHING
          
             IF hr = %S_OK THEN MSGBOX "Done" ELSE MSGBOX "Error"
          
          END FUNCTION
          ' ========================================================================================
          Forum: http://www.jose.it-berater.org/smfforum/index.php

          Comment


          • #6
            How to implement the IRichEditOleCallback interface

            Implementing the IRichEditOleCallback interface allows to perform insertion, deletion, cut, copy and paste, and drag operations with objects, such images, in a rich edit control.

            The following example demonstrates how to implement the IRichEditOleCallback interface.

            Code:
            ' ########################################################################################
            ' RichOle demo
            ' ########################################################################################
            
            #DIM ALL
            #COMPILE EXE
            %UNICODE = 1
            %USERICHEDIT = 1
            
            ' // Include files for external files
            #INCLUDE ONCE "CWindow.inc"   ' // CWindow class
            #INCLUDE ONCE "RichOle.inc"
            
            ' Control identifier
            %IDC_RICHEDIT = 1001
            
            ' ========================================================================================
            ' Main
            ' ========================================================================================
            FUNCTION WinMain (BYVAL hInstance AS DWORD, BYVAL hPrevInstance AS DWORD, BYVAL lpszCmdLine AS WSTRINGZ PTR, BYVAL nCmdShow AS LONG) AS LONG
            
               ' // Set process DPI aware
            '   SetProcessDPIAware
            
               ' // Create an instance of the class
               LOCAL pWindow AS IWindow
               pWindow = CLASS "CWindow"
               IF ISNOTHING(pWindow) THEN EXIT FUNCTION
            
               ' // Create the main window
               ' // Note: CW_USEDEFAULT is used as the default value When passing 0's as the width and height
               pWindow.CreateWindow(%NULL, "Rich Ole Demo", 0, 0, 0, 0, 0, 0, CODEPTR(WindowProc))
               ' // Set the client size
               pWindow.SetClientSize 500, 320
               ' // Center the window
               pWindow.CenterWindow
            
               ' // Add a subclassed rich edit control without coordinates (it will be resized in WM_SIZE, below)
               LOCAL hRichEdit AS DWORD
               hRichEdit = pWindow.AddRichEdit(pWindow.hwnd, %IDC_RICHEDIT, "RichEdit box", 0, 0, 0, 0, 0, 0, CODEPTR(RichEditSubclassProc))
               ' // Specify which notifications the control sends to its parent window
               RichEdit_SetEventMask hRichEdit, %ENM_CHANGE
            
               ' // Set the IRichEditOleCallback object.
               ' // The control calls the AddRef function for the object before returning.
               LOCAL pRichEditOleCallback AS IRichEditOleCallbackImpl
               pRichEditOleCallback = CLASS "CRichEditOleCallback"
               RichEdit_SetOleCallback hRichEdit, OBJPTR(pRichEditOleCallback)
            
               ' // Load the file
               RichEdit_LoadRtfFromFile hRichEdit, EXE.Path$ & "Test.rtf"
            
               ' // Default message pump (you can replace it with your own)
               pWindow.DoEvents(nCmdShow)
            
            END FUNCTION
            ' ========================================================================================
            
            ' ========================================================================================
            ' Main window callback
            ' ========================================================================================
            FUNCTION WindowProc (BYVAL hwnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG
            
               LOCAL tlf             AS LOGFONT                  ' font attributes
               LOCAL tcf             AS CHARFORMAT               ' rich edit character formatting information
               LOCAL ptnmhdr         AS NMHDR PTR                ' information about a notification message
               LOCAL ptmmi           AS MINMAXINFO PTR           ' pointer to the maximized and tracking info
               LOCAL hwndChild       AS DWORD                    ' handle of child window
               LOCAL hFont           AS DWORD                    ' handle of font used by form
               LOCAL dwMask          AS DWORD                    ' specifies the attributes of an item to retrieve or set
               LOCAL hDC             AS DWORD                    ' handle of memory device context
               STATIC pWindow        AS IWindow                  ' // Reference to the IWindow interface
            
               SELECT CASE uMsg
            
                  CASE %WM_CREATE
                     ' // Get a reference to the IWindow interface from the CREATESTRUCT structure
                     pWindow = CWindow_GetObjectFromCreateStruct(lParam)
                     EXIT FUNCTION
            
                  CASE %WM_COMMAND
                     SELECT CASE LO(WORD, wParam)
                        CASE %IDCANCEL
                           ' // If the Escape key has been pressed...
                           IF HI(WORD, wParam) = %BN_CLICKED THEN
                              ' // ... close the application by sending a WM_CLOSE message
                              SendMessage hwnd, %WM_CLOSE, 0, 0
                              EXIT FUNCTION
                           END IF
                        CASE %IDC_RICHEDIT
                           IF HI(WORD, wParam) = %EN_CHANGE THEN
                           END IF
                     END SELECT
            
                  CASE %WM_NOTIFY
                     ptnmhdr = lParam
                     SELECT CASE @ptnmhdr.idFrom
                     END SELECT
            
                  CASE %WM_SETFOCUS
                     ' Set the keyboard focus to the first control that is
                     ' visible, not disabled, and has the WS_TABSTOP style
                     SetFocus GetNextDlgTabItem(hwnd, %NULL, %FALSE)
            
                  CASE %WM_DESTROY
                     PostQuitMessage 0
                     EXIT FUNCTION
            
                  CASE %WM_SIZE
                     IF wParam <> %SIZE_MINIMIZED THEN
                        pWindow.MoveWindow GetDlgItem(hwnd, %IDC_RICHEDIT), 10, 10, pWindow.ClientWidth - 20, pWindow.ClientHeight - 20, %TRUE
                     END IF
            
               END SELECT
            
               FUNCTION = DefWindowProc(hwnd, uMsg, wParam, lParam)
            
            END FUNCTION
            ' ========================================================================================
            
            ' ========================================================================================
            ' RichEdit control subclassed procedure
            ' ========================================================================================
            FUNCTION RichEditSubclassProc ( _
               BYVAL hwnd    AS DWORD, _ ' control handle
               BYVAL uMsg    AS DWORD, _ ' type of message
               BYVAL wParam  AS DWORD, _ ' first message parameter
               BYVAL lParam  AS LONG _   ' second message parameter
               ) AS LONG
            
               LOCAL lpOldWndProc AS DWORD    ' address of original window procedure
            
               lpOldWndProc = GetProp(hwnd, "OLDWNDPROC")
            
               SELECT CASE uMsg
                  CASE %WM_DESTROY
                     ' // Remove control subclassing
                     SetWindowLong hwnd, %GWL_WNDPROC, RemoveProp(hwnd, "OLDWNDPROC")
               END SELECT
            
               FUNCTION = CallWindowProc(lpOldWndProc, hwnd, uMsg, wParam, lParam)
            
            END FUNCTION
            ' ========================================================================================
            
            
            ' ########################################################################################
            ' IRichEditOleCallback interface
            ' IID = 00020D03-0000-0000-C000-000000000046
            ' Inherited interface = IUnknown
            ' Custom implementation of the IRichEditOleCallback interface.
            ' Used by the RichEdit to get OLE-related stuff from the application using RichEdit.
            ' Note: Callback interfaces must be declared AS COMMON to avoid code removal.
            ' ########################################################################################
            
            CLASS CRichEditOleCallback AS COMMON
            
            INTERFACE IRichEditOleCallbackImpl $IID_IRichEditOleCallback
            
               INHERIT IUnknown
            
               ' =====================================================================================
               METHOD GetNewStorage ( _                             ' VTable offset = 12
                 BYREF lplpstg AS IStorage _                        ' LPSTORAGE FAR * lplpstg
               ) AS LONG                                            ' HRESULT
            
                 LOCAL hr AS LONG
                 LOCAL pILockBytes AS ILockBytes
                 hr = CreateILockBytesOnHGlobal(%NULL, %TRUE, pILockBytes)
                 IF FAILED(hr) THEN METHOD = hr : EXIT METHOD
                 hr = StgCreateDocfileOnILockBytes(pILockBytes, _
                      %STGM_SHARE_EXCLUSIVE OR %STGM_READWRITE OR %STGM_CREATE, _
                      0, lplpstg)
                 METHOD = hr
            
               END METHOD
               ' =====================================================================================
               METHOD GetInPlaceContext ( _                         ' VTable offset = 16
                 BYREF lplpFrame AS IOleInPlaceFrame _              ' LPOLEINPLACEFRAME FAR * lplpFrame
               , BYREF lplpDoc AS IOleInPlaceUIWindow _             ' LPOLEINPLACEUIWINDOW FAR * lplpDoc
               , BYREF lpFrameInfo AS OLEINPLACEFRAMEINFO _         ' LPOLEINPLACEFRAMEINFO lpFrameInfo
               ) AS LONG                                            ' HRESULT
            
                 METHOD = %E_NOTIMPL
            
               END METHOD
               ' =====================================================================================
               METHOD ShowContainerUI ( _                           ' VTable offset = 20
                 BYVAL fShow AS LONG _                              ' BOOL fShow
               ) AS LONG                                            ' HRESULT
            
                 METHOD = %E_NOTIMPL
            
               END METHOD
               ' =====================================================================================
               METHOD QueryInsertObject ( _                         ' VTable offset = 24
                 BYREF lpclsid As GUID _                            ' LPCLSID lpclsid
               , BYVAL lpstg AS IStorage _                          ' LPSTORAGE lpstg
               , BYVAL cp AS LONG _                                 ' LONG cp
               ) AS LONG                                            ' HRESULT
            
                 METHOD = %S_OK
            
               END METHOD
               ' =====================================================================================
               METHOD DeleteObject ( _                              ' VTable offset = 28
                 BYVAL lpoleobj AS IOleObject _                     ' LPOLEOBJECT lpoleobj
               ) AS LONG                                            ' HRESULT
            
                 METHOD = %S_OK
            
               END METHOD
               ' =====================================================================================
               METHOD QueryAcceptData ( _                           ' VTable offset = 32
                 BYVAL lpdataobj AS IOleObject _                    ' LPDATAOBJECT lpdataobj
               , BYREF lpcfFormat AS DWORD _                        ' CLIPFORMAT FAR * lpcfFormat
               , BYVAL reco AS DWORD _                              ' DWORD reco
               , BYVAL fReally AS LONG _                            ' BOOL fReally
               , BYVAL hMetaPict AS DWORD _                         ' HGLOBAL hMetaPict
               ) AS LONG                                            ' HRESULT
            
                 METHOD = %E_NOTIMPL
            
               END METHOD
               ' =====================================================================================
               METHOD ContextSensitiveHelp ( _                      ' VTable offset = 36
                 BYVAL fEnterMode AS LONG _                         ' BOOL fEnterMode
               ) AS LONG                                            ' HRESULT
            
                 METHOD = %E_NOTIMPL
            
               END METHOD
               ' =====================================================================================
               METHOD GetClipboardData ( _                          ' VTable offset = 40
                 BYREF lpchrg AS CHARRANGE _                        ' CHARRANGE FAR * lpchrg
               , BYVAL reco AS DWORD _                              ' DWORD reco
               , BYREF lplpdataobj AS IOleObject _                  ' LPDATAOBJECT FAR * lplpdataobj
               ) AS LONG                                            ' HRESULT
            
                 METHOD = %E_NOTIMPL
            
               END METHOD
               ' =====================================================================================
               METHOD GetDragDropEffect ( _                         ' VTable offset = 44
                 BYVAL fDrag AS LONG _                              ' BOOL fDrag
               , BYVAL grfKeyState AS DWORD _                       ' DWORD grfKeyState
               , BYREF pdwEffect AS DWORD _                         ' LPDWORD pdwEffect
               ) AS LONG                                            ' HRESULT
            
                 METHOD = %E_NOTIMPL
            
               END METHOD
               ' =====================================================================================
               METHOD GetContextMenu ( _                            ' VTable offset = 48
                 BYVAL seltype AS WORD _                            ' WORD seltype
               , BYVAL lpoleobj AS IOleObject _                     ' LPOLEOBJECT lpoleobj
               , BYREF lpchrg AS CHARRANGE _                        ' CHARRANGE FAR * lpchrg
               , BYREF lphmenu AS DWORD _                           ' HMENU FAR * lphmenu
               ) AS LONG                                            ' HRESULT
            
                 METHOD = %E_NOTIMPL
            
               END METHOD
               ' =====================================================================================
            
            END INTERFACE
            
            END CLASS
            ' ========================================================================================
            Attached Files
            Forum: http://www.jose.it-berater.org/smfforum/index.php

            Comment


            • #7
              CCLRHost Class: Hosting the Common Language Runtime

              CCLRHost is a class designed to host the .NET Common Language Runtime (CLR) in a PowerBASIC application and create and unwrap an instance of a COM visible .NET class whose methods and properties can be called using the PowerBASIC COM Automation statements.

              The folliwing example hosts the .NET 4 runtime in a PowerBASIC application, creates an instance of the System.Collections.Stack collection and calls its Push and Pop methods.

              Code:
              #COMPILE EXE
              #DIM ALL
              #INCLUDE ONCE "windows.inc"
              #INCLUDE ONCE "CCLRHost.inc"
              
              FUNCTION PBMAIN () AS LONG
              
                 LOCAL pCLRHost AS ICLRHost
                 LOCAL oStack AS DISPATCH
                 LOCAL vRes AS VARIANT
                 LOCAL vPrm AS VARIANT
                 LOCAL bstrOutput AS WSTRING
              
                 ' // Create an instance of the CCLRHost class
                 pCLRHost = NewCLR4Host("v4.0.30319")   ' --> change version number if needed
                 IF ISNOTHING(pCLRHost) THEN EXIT FUNCTION
              
                 ' // Create an instance of the Stack collection
                 oStack = pCLRHost.CreateInstance("mscorlib", "System.Collections.Stack")
                 IF ISOBJECT(oStack) THEN
                    ' Push and Pop some strings
                    vPrm = "rocks!"
                    OBJECT CALL oStack.Push(vPrm)
                    vPrm = "PB"
                    OBJECT CALL oStack.Push(vPrm)
                    OBJECT CALL oStack.Pop TO vRes
                    bstrOutput = VARIANT$$(vRes)
                    OBJECT CALL oStack.Pop TO vRes
                    bstrOutput += " " & VARIANT$$(vRes)
                    MSGBOX bstrOutput
                    oStack = NOTHING
                 END IF
              
                 pCLRHost = NOTHING
              
              END FUNCTION
              Same as above, but using the .NET 2 runtime.

              Code:
              #INCLUDE "CCLRHost.inc"
              
              ' ========================================================================================
              ' Main
              ' ========================================================================================
              FUNCTION PBMAIN () AS LONG
              
                 LOCAL pCLRHost AS ICLRHost
                 LOCAL oStack AS DISPATCH
                 LOCAL vRes AS VARIANT
                 LOCAL vPrm AS VARIANT
                 LOCAL bstrOutput AS WSTRING
              
                 ' // Create an instance of the CCLRHost class
                 pCLRHost = NewCLRHost("v2.0.50727", "wks")
                 IF ISNOTHING(pCLRHost) THEN EXIT FUNCTION
              
                 ' // Create an instance of the Stack collection
                 oStack = pCLRHost.CreateInstance("mscorlib", "System.Collections.Stack")
                 IF ISOBJECT(oStack) THEN
                    ' Push and Pop some strings
                    vPrm = "rocks!"
                    OBJECT CALL oStack.Push(vPrm)
                    vPrm = "PB"
                    OBJECT CALL oStack.Push(vPrm)
                    OBJECT CALL oStack.Pop TO vRes
                    bstrOutput = VARIANT$$(vRes)
                    OBJECT CALL oStack.Pop TO vRes
                    bstrOutput += " " & VARIANT$$(vRes)
                    MSGBOX bstrOutput
                    oStack = NOTHING
                 END IF
              
                 pCLRHost = NOTHING
              
              END FUNCTION
              ' ========================================================================================
              The following version allows to use your own domain, instead of the default domain.

              Code:
              #INCLUDE "CCLRHost.inc"
              
              ' ========================================================================================
              ' Main
              ' ========================================================================================
              FUNCTION PBMAIN () AS LONG
              
                 LOCAL pCLRHost AS ICLRHost
                 LOCAL pDomain AS SystemAppDomain
              
                 LOCAL oStack AS DISPATCH
                 LOCAL vRes AS VARIANT
                 LOCAL vPrm AS VARIANT
                 LOCAL bstrOutput AS WSTRING
              
                 ' // Create and instance of the CCLRHost class and initialize it
                 pCLRHost = NewCLRHost("v2.0.50727", "wks")
                 IF ISNOTHING(pCLRHost) THEN EXIT FUNCTION
              
                 ' // Create a custom domain
                 pDomain = pCLRHost.CreateDomain("MyDomain")
              
                 ' // Create an instance of the Stack collection
                 oStack = pCLRHost.CreateInstance2(pDomain, "mscorlib", "System.Collections.Stack")
                 IF ISOBJECT(oStack) THEN
                    ' // Push and Pop some strings
                    vPrm = "rocks!"
                    OBJECT CALL oStack.Push(vPrm)
                    vPrm = "PB"
                    OBJECT CALL oStack.Push(vPrm)
                    OBJECT CALL oStack.Pop TO vRes
                    bstrOutput = VARIANT$$(vRes)
                    OBJECT CALL oStack.Pop TO vRes
                    bstrOutput += " " & VARIANT$$(vRes)
                    MSGBOX bstrOutput
                    oStack = NOTHING
                 END IF
              
                 pCLRHost.UnloadDomain(pDomain)
              
                 pDomain = NOTHING
                 pCLRHost = NOTHING
              
              END FUNCTION
              ' ========================================================================================
              Forum: http://www.jose.it-berater.org/smfforum/index.php

              Comment


              • #8
                Hosting VBScript in your PowerBASIC application

                This example is based i the following Microsoft article:
                http://support.microsoft.com/kb/223139/en-us

                MSDN documentation about the IActiveScriptSite interface:
                http://msdn.microsoft.com/en-us/libr...8VS.94%29.aspx

                Code:
                ' ########################################################################################
                ' Hosting VBScript in your PowerBASIC application
                ' Copyright (c) 2012 Josť Roca. Freeware. Use at your own risk.
                ' THIS CODE AND INFORMATION IS PROVIDED "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER
                ' EXPRESSED OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE IMPLIED WARRANTIES OF
                ' MERCHANTABILITY AND/OR FITNESS FOR A PARTICULAR PURPOSE.
                ' ########################################################################################
                
                ' ========================================================================================
                ' The basic work flow is as follows:
                ' 1. You start the VBScript engine, vbscript.dll, and obtain IActiveScript and
                '    IActiveScriptParse interfaces.
                ' 2. You give the VBScript engine your implementation of IActiveScriptSite, which the
                '    engine uses later to obtain and call to your objects.
                ' 3. You add the objects that you implement and want to make available to scripts by
                '    calling IActiveScript.AddNamedItem().
                ' 4. You provide the script text to execute through IActiveScriptParse.ParseScriptText().
                '    Note that this doesn't actually run the script yet.
                ' 5. The script engine will now call into your IActiveScriptSite.GetItemInfo() for any
                '    objects it doesn't recognize, to get their interface pointers.
                ' 6. You call IActiveScript.SetScriptState() with SCRIPT_STATE_CONNECTED to run the script.
                ' 7. The VBScript engine parses the text in the script for you and when it encounters a
                '    method call or property reference, it delegates the implementation to your provided
                '    interfaces.
                ' ========================================================================================
                
                #COMPILE EXE
                #DIM ALL
                
                '/* header files for imported files */
                #INCLUDE ONCE "ActivScp.inc"
                
                ' ########################################################################################
                ' Class MyObject
                ' Note: We need to declare the class AS COMMON to avoid dead code removal because the
                ' methods aren't called directly by the code but by the ActiveScript engine.
                ' ########################################################################################
                
                $IID_CMyObject = GUID$("{F9E4BF70-EFA8-411E-A142-F4B02D89D621}")
                $IID_IMyObject = GUID$("{F9E4BF70-EFA8-411E-A142-F4B02D89D622}")
                
                CLASS CMyObject $IID_CMyObject AS COMMON
                
                   INTERFACE IMyObject $IID_IMyObject
                
                   INHERIT IDispatch
                
                   METHOD SayHi (BYVAL bstrTo AS WSTRING)
                      ? "Say Hi to " & bstrTo
                   END METHOD
                
                   METHOD Sum (BYVAL a AS LONG, BYVAL b AS LONG)
                      ? STR$(a) & " +" & STR$(b) & " =" & STR$(a + b) & ", isn't it?"
                   END METHOD
                
                   END INTERFACE
                
                END CLASS
                ' ########################################################################################
                
                ' ########################################################################################
                ' Class CMyScriptSite
                ' Note: We need to declare the class AS COMMON to avoid dead code removal because the
                ' methods aren't called directly by the code but by the ActivaScript engine.
                ' ########################################################################################
                
                $IID_CMyScriptSite = GUID$("{F9E4BF70-EFA8-411E-A142-F4B02D89D620}")
                
                CLASS CMyScriptSite $IID_CMyScriptSite AS COMMON
                
                   INSTANCE m_wszObjectName AS WSTRINGZ * 260
                   INSTANCE m_pScriptObjectUnk AS IUnknown
                
                   CLASS METHOD Create
                      ' // Creates an instance of our object
                      m_pScriptObjectUnk = CLASS "CMyObject"
                      m_wszObjectName = "MyObject"
                   END METHOD
                
                   CLASS METHOD Destroy
                      ' // Releases our object
                      m_pScriptObjectUnk = NOTHING
                   END METHOD
                
                   ' =====================================================================================
                   ' Custom implementation of the IActiveScriptSite interface
                   ' =====================================================================================
                   INTERFACE IActiveScriptSiteImpl $IID_IActiveScriptSite
                
                      INHERIT IUnknown
                
                      ' ==================================================================================
                      ' Retrieves the locale identifier associated with the host's user interface.
                      ' ==================================================================================
                      METHOD GetLCID (BYREF plcid AS LONG) AS LONG
                         METHOD = %S_OK
                      END METHOD
                      ' ==================================================================================
                
                      ' ==================================================================================
                      ' Allows the scripting engine to obtain information about an item added with the
                      ' IActiveScript.AddNamedItem method.
                      ' ==================================================================================
                      METHOD GetItemInfo (BYREF wszName AS WSTRINGZ, BYVAL dwReturnMask AS DWORD, BYREF ppiunkItem AS DWORD, BYREF ppti AS DWORD) AS LONG
                
                         LOCAL IID_CMyScriptSite AS GUID
                
                         ' // Is it expecting an ITypeInfo?
                         IF VARPTR(ppti) THEN
                            ' // Default to null
                            ppti = %NULL
                            ' // Return if asking about ITypeInfo...
                            IF (dwReturnMask AND %SCRIPTINFO_ITYPEINFO) = %SCRIPTINFO_ITYPEINFO THEN
                               METHOD = %TYPE_E_ELEMENTNOTFOUND
                               EXIT METHOD
                            END IF
                         END IF
                
                         ' // Is the engine passing an IUnknown buffer?
                         IF VARPTR(ppiunkItem) THEN
                            ' // Default to null
                            ppiunkItem = %NULL
                            ' // Is Script Engine looking for an IUnknown for our object?
                            IF (dwReturnMask AND %SCRIPTINFO_IUNKNOWN) = %SCRIPTINFO_IUNKNOWN THEN
                               ' // Check for our object name...
                               IF wszName = m_wszObjectName THEN
                                  ' // Provide our object.
                                  ppiunkItem = OBJPTR(m_pScriptObjectUnk)
                                  ' // AddRef our object...
                                  m_pScriptObjectUnk.AddRef
                               END IF
                            END IF
                         END IF
                
                         METHOD = %S_OK
                
                      END METHOD
                      ' ==================================================================================
                
                      ' ==================================================================================
                      ' Retrieves a host-defined string that uniquely identifies the current document version.
                      ' ==================================================================================
                      METHOD GetDocVersionString (BYREF bstrVersion AS WSTRING) AS LONG
                         METHOD = %S_OK
                      END METHOD
                      ' ==================================================================================
                
                      ' ==================================================================================
                      ' Informs the host that the script has completed execution.
                      ' ==================================================================================
                      METHOD OnScriptTerminate (BYREF pvarResult AS VARIANT, BYREF pexcepinfo AS EXCEPINFO) AS LONG
                         METHOD = %S_OK
                      END METHOD
                      ' ==================================================================================
                
                      ' ==================================================================================
                      ' Informs the host that the scripting engine has changed states.
                      ' ==================================================================================
                      METHOD OnStateChange (BYVAL ssScriptState AS DWORD) AS LONG
                         METHOD = %S_OK
                      END METHOD
                      ' ==================================================================================
                
                      ' ==================================================================================
                      ' Informs the host that an execution error occurred while the engine was running the script.
                      ' ==================================================================================
                      METHOD OnScriptError (BYVAL pscripterror AS IActiveScriptError) AS LONG
                
                         LOCAL bstrSourceLine AS WSTRING
                         LOCAL ei AS EXCEPINFO
                         LOCAL bstrlen AS LONG
                
                         pscripterror.GetSourceLineText bstrSourceLine
                         ? "IActiveScriptSite.OnScriptError" & $CRLF & _
                            "*** Source line ***" & $CRLF & bstrSourceLine
                
                         LOCAL hr AS LONG
                         LOCAL dwSourceContext AS DWORD
                         LOCAL ulLineNumber AS DWORD
                         LOCAL lCharacterPosition AS LONG
                         hr = pscripterror.GetSourcePosition(dwSourceContext, ulLineNumber, lCharacterPosition)
                         IF hr = %S_OK THEN
                            IF dwSourceContext THEN ? "Source context: " & FORMAT$(dwSourceContext)
                            IF ulLineNumber THEN ? "Line number " & FORMAT$(ulLineNumber)
                            IF lCharacterPosition THEN ? "Character Position: " & FORMAT$(lCharacterPosition)
                         END IF
                
                         ' // Retrieve the error information from EXCEPINFO
                         pscripterror.GetExceptionInfo ei
                         IF ei.sCode THEN
                            ? "Error code: " & FORMAT$(ei.sCode) & " <" & HEX$(ei.scode) & ">"
                         END IF
                         IF ei.bstrSource THEN
                            ? "Error source: " & ei.@bstrSource
                            SysFreeString ei.bstrSource
                         END IF
                         IF ei.bstrDescription THEN
                            ? "Error description: " & ei.@bstrDescription
                            SysFreeString ei.bstrDescription
                         END IF
                         IF ei.bstrHelpFile THEN
                            ? "Help file: " & ei.@bstrHelpFile
                            IF ei.dwHelpContext THEN ? "Help context ID: " & FORMAT$(ei.dwHelpContext)
                            SysFreeString ei.bstrHelpFile
                         END IF
                
                         METHOD = %S_OK
                
                      END METHOD
                      ' ==================================================================================
                
                      ' ==================================================================================
                      ' Informs the host that the scripting engine has begun executing the script code.
                      ' ==================================================================================
                      METHOD OnEnterScript () AS LONG
                         METHOD = %S_OK
                      END METHOD
                      ' ==================================================================================
                
                      ' ==================================================================================
                      ' Informs the host that the scripting engine has returned from executing script code.
                      ' ==================================================================================
                      METHOD OnLeaveScript () AS LONG
                         METHOD = %S_OK
                      END METHOD
                      ' ==================================================================================
                
                   END INTERFACE
                   ' =====================================================================================
                
                END CLASS
                ' ########################################################################################
                
                
                ' ########################################################################################
                ' Main
                ' ########################################################################################
                FUNCTION PBMAIN () AS LONG
                
                   LOCAL hr AS LONG
                   LOCAL pMySite AS IActiveScriptSiteImpl
                   LOCAL wszObjectName AS WSTRINGZ * 260
                   LOCAL wszScript AS WSTRINGZ * 260
                   LOCAL ei AS EXCEPINFO
                
                   ' // Create an instance of our script site
                   pMySite = CLASS "CMyScriptSite"
                   IF ISNOTHING(pMySite) THEN EXIT FUNCTION
                
                   ' // Start inproc script engine, VBSCRIPT.DLL
                   LOCAL pIActiveScript AS IActiveScript
                   pIActiveScript = NEWCOM CLSID $CLSID_VBScript
                   IF ISNOTHING(pIActiveScript) THEN  EXIT FUNCTION
                
                   ' // Get engine's IActiveScriptParse interface
                   LOCAL pIActiveScriptParse AS IActiveScriptParse
                   pIActiveScriptParse = pIActiveScript
                   IF ISNOTHING(pIActiveScriptParse) THEN  EXIT FUNCTION
                
                   ' // Give the engine our IActiveScriptSite interface...
                   hr = pIActiveScript.SetScriptSite(pMySite)
                   ' // Give the engine a chance to initialize itself...
                   hr = pIActiveScriptParse.InitNew
                   ' // Add a root-level item to the engine's name space...
                   wszObjectName = "MyObject"
                   hr = pIActiveScript.AddNamedItem(wszObjectName, %SCRIPTITEM_ISVISIBLE OR %SCRIPTITEM_ISSOURCE)
                   wszScript = "Sum 2,3" & $CRLF & _
                               "SayHi(" & $DQ & "Active Scripting" & $DQ & ")"
                   hr = pIActiveScriptParse.ParseScriptText(wszScript, wszObjectName, _
                        NOTHING, "", 0, 0, 0, BYVAL %NULL, ei)
                   ' // Set the engine state. This line actually triggers the execution of the script.
                   hr = pIActiveScript.SetScriptState(%SCRIPTSTATE_CONNECTED)
                
                   ' // Close script and release interfaces...
                   pIActiveScript.Close
                   pIActiveScriptParse = NOTHING
                   pIActiveScript = NOTHING
                   pMySite = NOTHING
                
                   #IF %DEF(%PB_CC32)
                   WAITKEY$
                   #ENDIF
                
                END FUNCTION
                ' ########################################################################################
                Forum: http://www.jose.it-berater.org/smfforum/index.php

                Comment


                • #9
                  Internet Explorer: How to get IWebBrowser2 from a HWND

                  This article shows how to get the IWebBrowser2 interface from a HWND. If Microsoft Active Accessibility (MSAA) is installed, you can send the WM_HTML_GETOBJECT message to the document's window (with the window class "Internet Explorer_Server") and then pass the result from SendMessageTimeout to an MSAA function, ObjectFromLresult, to get a fully marshaled IHTMLDocument2 pointer. Then you will call the parentWindow property of the IHTMLDocument2 interface to retrieve a reference to the IHTMLWindow2 interface and call the QueryInterface method to retrieve a reference to the IServiceProvider interface. Finally, you will call the QueryService method of the IServiceProvider interface to retrieve a reference to the IWebBrowser2 interface.

                  Code:
                  ' ########################################################################################
                  ' Demonstrates how to get the IWebBrowser2 interface from a HWND. If Microsoft Active
                  ' Accessibility (MSAA) is installed, you can send the WM_HTML_GETOBJECT message to the
                  ' document's window (with the window class "Internet Explorer_Server") and then pass the
                  ' result from SendMessageTimeout to an MSAA function, ObjectFromLresult, to get a fully
                  ' marshaled IHTMLDocument2 pointer. Then you will call the parentWindow property of the
                  ' IHTMLDocument2 interface to retrieve a reference to the IHTMLWindow2 interface and call
                  ' the QueryInterface method to retrieve a reference to the IServiceProvider interface.
                  ' Finally, you will call the QueryService method of the IServiceProvider interface to
                  ' retrieve a reference to the IWebBrowser2 interface.
                  ' ########################################################################################
                  
                  #COMPILE EXE
                  #DIM ALL
                  #INCLUDE "OLEACC.INC"   ' // Accessibility
                  #INCLUDE "EXDISP.INC"   ' // WebBrowser Control
                  #INCLUDE "MSHTML.INC"   ' // MSHTML
                  
                  ' ========================================================================================
                  ' Callback for EnumChildWindows
                  ' ========================================================================================
                  FUNCTION EnumChildProc(BYVAL hwnd AS DWORD, BYVAL lParam AS DWORD PTR) AS LONG
                     LOCAL szClassName AS ASCIIZ * %MAX_PATH
                     GetClassName (hwnd, szClassName, %MAX_PATH)
                     IF szClassName = "Internet Explorer_Server" THEN
                        IF lParam <> %NULL THEN @lParam = hWnd
                        FUNCTION = %FALSE
                     ELSE
                        FUNCTION = %TRUE
                     END IF
                  END FUNCTION
                  ' ========================================================================================
                  
                  ' ========================================================================================
                  ' Main
                  ' ========================================================================================
                  FUNCTION PBMAIN () AS LONG
                  
                     LOCAL hr AS LONG                              ' // HRESULT
                     LOCAL hWndExplorer AS DWORD                   ' // Internet Explorer handle
                     LOCAL hWndChild AS DWORD                      ' // Child window handle
                     LOCAL dwMsg AS DWORD                          ' // Message to send
                     LOCAL lRes AS DWORD                           ' // Result of the message processing
                     LOCAL pIWebBrowser2 AS IWebBrowser2           ' // IWebBrowser2 interface pointer
                     LOCAL pIHTMLDocument2 AS IHTMLDocument2       ' // IHTMLDocument2 interface pointer
                     LOCAL pIHTMLWindow2 AS IHTMLWindow2           ' // IHTMLWindow2 interface pointer
                     LOCAL pIServiceProvider AS IServiceProvider   ' // IServiceProvider interface pointer
                  
                     ' Find the window handle of a running instance of Internet Explorer
                     hWndExplorer = FindWindow("IEFrame", BYVAL %NULL)
                     IF ISFALSE hWndExplorer THEN
                        ? "Internet Explorer isn't running"
                        EXIT FUNCTION
                     END IF
                     ' Enumerate its child windows
                     EnumChildWindows hWndExplorer, CODEPTR(EnumChildProc), VARPTR(hWndChild)
                     IF ISFALSE hWndChild THEN EXIT FUNCTION
                     ' Register the WM_HTML_GETOBJECT message
                     dwMsg = RegisterWindowMessage("WM_HTML_GETOBJECT")
                     IF ISFALSE dwMsg THEN EXIT FUNCTION
                     ' Send a mensage to get an LRESULT
                     SendMessageTimeout hWndChild, dwMsg, 0, 0, %SMTO_ABORTIFHUNG, 1000, lRes
                     IF ISFALSE lRes THEN EXIT FUNCTION
                     ' Retrieve a reference to the IHTMLDocument2 interface from the LRESULT
                     hr = ObjectFromLresult(lRes, $IID_IHTMLDocument2, 0, pIHTMLDocument2)
                     IF ISNOTHING(pIHTMLDocument2) THEN EXIT FUNCTION
                     ' Get a reference to the IHTMLWindow2 interface for the parent window
                     pIHTMLWindow2 = pIHTMLDocument2.parentWindow
                     IF ISNOTHING(pIHTMLWindow2) THEN EXIT FUNCTION
                     ' Retrieve a reference to the IServiceProvider interface
                     pIServiceProvider = pIHTMLWindow2
                     IF ISNOTHING(pIServiceProvider) THEN EXIT FUNCTION
                     ' Retrieve a reference to the IWebBrowser2 interface
                     pIServiceProvider.QueryService($IID_IWebBrowserApp, $IID_IWebBrowser2, pIWebBrowser2)
                     IF ISNOTHING(pIWebBrowser2) THEN EXIT FUNCTION
                     ' ==========================================================================
                     ' Now you can call the methods and properties of the IWebBrowser2 interface.
                     ' ==========================================================================
                     ? "pIWebBrowser2 = " & STR$(OBJPTR(pIWebBrowser2))
                  
                     #IF %DEF(%PB_CC32)
                     WAITKEY$
                     #ENDIF
                  
                  END FUNCTION
                  ' ========================================================================================
                  Forum: http://www.jose.it-berater.org/smfforum/index.php

                  Comment


                  • #10
                    Internet Explorer: How to get IHTMLDocument2 from a HWND

                    Adapted from the Microsoft Knowledge Base article of the same name: http://support.microsoft.com/kb/249232

                    This article shows how to get the IHTMLDocument2 interface from a HWND. If Microsoft Active Accessibility (MSAA) is installed, you can send the WM_HTML_GETOBJECT message to the document's window (with the window class "Internet Explorer_Server") and then pass the result from SendMessageTimeout to an MSAA function, ObjectFromLresult, to get a fully marshaled IHTMLDocument2 pointer.

                    NOTE: Before Internet Explorer 5.5, frames were implemented by hosting a new instance of Shdocvw.dll, and each frame had a separate window associated with it. Internet Explorer 5.5 implements native frames for better performance, and all frames are rendered by the same instance of Shdocvw.dll. Since there will not be a HWND for each frame for Internet Explorer 5.5 and later, the sample code described in this section will work to get to the document of the main window only. You can still get to each frame's document by using the frames collection of the main document.

                    Code:
                    ' ########################################################################################
                    ' Adapted from the following Microsoft Knowledge Base article: http://support.microsoft.com/kb/249232
                    ' Demonstrates how to get the IHTMLDocument2 interface from a HWND. If Microsoft Active
                    ' Accessibility (MSAA) is installed, you can send the WM_HTML_GETOBJECT message to the
                    ' document's window (with the window class "Internet Explorer_Server") and then pass the
                    ' result from SendMessageTimeout to an MSAA function, ObjectFromLresult, to get a fully
                    ' marshaled IHTMLDocument2 pointer.
                    ' ########################################################################################
                    
                    #COMPILE EXE
                    #DIM ALL
                    #INCLUDE "OLEACC.INC"   ' // Accessibility
                    #INCLUDE "EXDISP.INC"   ' // WebBrowser Control
                    #INCLUDE "MSHTML.INC"   ' // MSHTML
                    
                    ' ========================================================================================
                    ' Callback for EnumChildWindows
                    ' ========================================================================================
                    FUNCTION EnumChildProc(BYVAL hwnd AS DWORD, BYVAL lParam AS DWORD PTR) AS LONG
                       LOCAL szClassName AS ASCIIZ * %MAX_PATH
                       GetClassName (hwnd, szClassName, %MAX_PATH)
                       IF szClassName = "Internet Explorer_Server" THEN
                          IF lParam <> %NULL THEN @lParam = hWnd
                          FUNCTION = %FALSE
                       ELSE
                          FUNCTION = %TRUE
                       END IF
                    END FUNCTION
                    ' ========================================================================================
                    
                    ' ========================================================================================
                    ' Main
                    ' ========================================================================================
                    FUNCTION PBMAIN () AS LONG
                    
                       LOCAL hr AS LONG                              ' // HRESULT
                       LOCAL hWndExplorer AS DWORD                   ' // Internet Explorer handle
                       LOCAL hWndChild AS DWORD                      ' // Child window handle
                       LOCAL dwMsg AS DWORD                          ' // Message to send
                       LOCAL lRes AS DWORD                           ' // Result of the message processing
                       LOCAL pIHTMLDocument2 AS IHTMLDocument2       ' // IHTMLDocument2 interface pointer
                    
                       ' Find the window handle of a running instance of Internet Explorer
                       hWndExplorer = FindWindow("IEFrame", BYVAL %NULL)
                       IF ISFALSE hWndExplorer THEN
                          ? "Internet Explorer isn't running"
                          EXIT FUNCTION
                       END IF
                       ' Enumerate its child windows
                       EnumChildWindows hWndExplorer, CODEPTR(EnumChildProc), VARPTR(hWndChild)
                       IF ISFALSE hWndChild THEN EXIT FUNCTION
                       ' Register the WM_HTML_GETOBJECT message
                       dwMsg = RegisterWindowMessage("WM_HTML_GETOBJECT")
                       IF ISFALSE dwMsg THEN EXIT FUNCTION
                       ' Send a mensage to get an LRESULT
                       SendMessageTimeout hWndChild, dwMsg, 0, 0, %SMTO_ABORTIFHUNG, 1000, lRes
                       IF ISFALSE lRes THEN EXIT FUNCTION
                       ' Retrieve a reference to the IHTMLDocument2 interface from the LRESULT
                       hr = ObjectFromLresult(lRes, $IID_IHTMLDocument2, 0, pIHTMLDocument2)
                       IF ISNOTHING(pIHTMLDocument2) THEN EXIT FUNCTION
                       ' Change the background color of the document to red
                       pIHTMLDocument2.bgColor = "red"
                       ' Cleanup
                       pIHTMLDocument2 = NOTHING
                       ? "Web page background color changed to red"
                       #IF %DEF(%PB_CC32)
                       WAITKEY$
                       #ENDIF
                    
                    END FUNCTION
                    ' ========================================================================================
                    Forum: http://www.jose.it-berater.org/smfforum/index.php

                    Comment


                    • #11
                      Hosting Windows Explorer in your application

                      Requires Vista or Windows 7.

                      The Explorer Browser object allows developers to host Windows Explorer in their applications.

                      This is a minimal example. You can also sink to an event class and receive the following events: OnNavigationPending, OnViewCreated, OnNavigationComplete, OnNavigationFailed.

                      You can also add a toolbar or menu and, in the %WM_COMMAND message, perform one of these actions:

                      Code:
                      CASE %IDC_PREVIOUSFOLDER
                         peb.BrowseToIDList(NULL, %SBSP_PARENT)
                      CASE %IDC_BACK
                         peb.BrowseToIDList(NULL, %SBSP_NAVIGATEBACK)
                      CASE %IDC_FORWARD
                         peb.BrowseToIDList(NULL, %SBSP_NAVIGATEFORWARD)
                      There are some more options that I haven't yet explored. See:
                      http://msdn.microsoft.com/en-us/libr...=vs.85%29.aspx

                      The example (DDT Version):

                      This example fills the entire client area of the dialog with Explorer, but you can choose the area where to display it passing the wanted position and size with peb.SetRect.

                      Code:
                      #COMPILE EXE
                      #DIM ALL
                      #COMPILER PBWIN 10
                      
                      ' // Include files for external files
                      #INCLUDE ONCE "ShlObj.inc"
                      #INCLUDE ONCE "ShObjIdl.inc"
                      
                      GLOBAL peb AS IExplorerBrowser
                      
                      ' ========================================================================================
                      ' Main
                      ' ========================================================================================
                      FUNCTION PBMAIN () AS LONG
                      
                         ' // Create the dialog
                         LOCAL hDlg AS DWORD
                         DIALOG NEW PIXELS, 0, "IExplorerBrowser interface test", , , 500, 320, %WS_SYSMENU TO hDlg
                      
                         ' // Create an instance of IExplorerBrowser
                         peb = NEWCOM CLSID $CLSID_ExplorerBrowser
                         IF ISOBJECT(peb) THEN
                            peb.SetOptions(%EBO_SHOWFRAMES)
                            LOCAL fs AS FOLDERSETTINGS
                            fs.ViewMode = %FVM_DETAILS
                            LOCAL rc AS RECT
                            GetClientRect hDlg, rc
                            peb.Initialize(hDlg, rc, fs)
                            ' // Navigate to the Profile folder
                            LOCAL pidlBrowse AS DWORD
                            IF SUCCEEDED(SHGetFolderLocation(%NULL, %CSIDL_PROFILE, %NULL, 0, pidlBrowse)) THEN
                               peb.BrowseToIDList(pidlBrowse, 0)
                               ILFree(pidlBrowse)
                            END IF
                         END IF
                      
                         ' // Display and activate the dialog
                         DIALOG SHOW MODAL hDlg, CALL DlgProc
                      
                         ' // Destroy the instance of the Explorer browser
                         IF ISOBJECT(peb) THEN peb.Destroy
                      
                      END FUNCTION
                      ' ========================================================================================
                      
                      ' ========================================================================================
                      ' Main callback function.
                      ' ========================================================================================
                      CALLBACK FUNCTION DlgProc() AS LONG
                      
                         ' // Process window mesages
                         SELECT CASE CB.MSG
                      
                            CASE %WM_SIZE
                               ' // If the window isn't minimized, resize it
                               IF CB.WPARAM <> %SIZE_MINIMIZED THEN
                                  ' // Resize the explorer browser
                                  LOCAL rc AS RECT
                                  GetClientRect CB.HNDL, rc
                                  IF ISOBJECT(peb) THEN peb.SetRect(BYVAL %NULL, rc)
                               END IF
                      
                         END SELECT
                      
                      END FUNCTION
                      ' ========================================================================================
                      The example (CWindow Version):

                      Code:
                      #COMPILE EXE
                      #DIM ALL
                      %UNICODE = 1
                      
                      ' // Include files for external files
                      #INCLUDE ONCE "CWindow.inc"   ' // CWindow class
                      #INCLUDE ONCE "ShlObj.inc"
                      #INCLUDE ONCE "ShObjIdl.inc"
                      
                      GLOBAL peb AS IExplorerBrowser
                      
                      ' ========================================================================================
                      ' Main
                      ' ========================================================================================
                      FUNCTION WinMain (BYVAL hInstance AS DWORD, BYVAL hPrevInstance AS DWORD, BYVAL lpszCmdLine AS WSTRINGZ PTR, BYVAL nCmdShow AS LONG) AS LONG
                      
                         ' // Set process DPI aware
                         SetProcessDPIAware
                      
                         ' // Create an instance of the class
                         LOCAL pWindow AS IWindow
                         pWindow = CLASS "CWindow"
                         IF ISNOTHING(pWindow) THEN EXIT FUNCTION
                      
                         ' // Create the main window
                         ' // Note: CW_USEDEFAULT is used as the default value When passing 0's as the width and height
                         pWindow.CreateWindow(%NULL, "IExplorerBrowser interface test", 0, 0, 0, 0, 0, 0, CODEPTR(WindowProc))
                         ' // Set the client size
                         pWindow.SetClientSize 500, 320
                         ' // Center the window
                         pWindow.CenterWindow
                      
                         ' // Create an instance of IExplorerBrowser
                         peb = NEWCOM CLSID $CLSID_ExplorerBrowser
                         IF ISOBJECT(peb) THEN
                            peb.SetOptions(%EBO_SHOWFRAMES)
                            LOCAL fs AS FOLDERSETTINGS
                            fs.ViewMode = %FVM_DETAILS
                            LOCAL rc AS RECT
                            GetClientRect pWindow.hwnd, rc
                            peb.Initialize(pWindow.hwnd, rc, fs)
                            ' // Navigate to the Profile folder
                            LOCAL pidlBrowse AS DWORD
                            IF SUCCEEDED(SHGetFolderLocation(%NULL, %CSIDL_PROFILE, %NULL, 0, pidlBrowse)) THEN
                               peb.BrowseToIDList(pidlBrowse, 0)
                               ILFree(pidlBrowse)
                            END IF
                         END IF
                      
                         ' // Default message pump (you can replace it with your own)
                         pWindow.DoEvents(nCmdShow)
                      
                      END FUNCTION
                      ' ========================================================================================
                      
                      ' ========================================================================================
                      ' Main callback function.
                      ' ========================================================================================
                      FUNCTION WindowProc (BYVAL hwnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG
                      
                         ' // Process window mesages
                         SELECT CASE uMsg
                      
                            CASE %WM_COMMAND
                               SELECT CASE LO(WORD, wParam)
                                  CASE %IDCANCEL
                                     ' // If the Escape key has been pressed...
                                     IF HI(WORD, wParam) = %BN_CLICKED THEN
                                        ' // ... close the application by sending a WM_CLOSE message
                                        SendMessage hwnd, %WM_CLOSE, 0, 0
                                        EXIT FUNCTION
                                     END IF
                               END SELECT
                      
                            CASE %WM_SIZE
                               ' // If the window isn't minimized, resize it
                               IF wParam <> %SIZE_MINIMIZED THEN
                                  ' // Resize the explorer browser
                                  LOCAL rc AS RECT
                                  GetClientRect hwnd, rc
                                  IF ISOBJECT(peb) THEN peb.SetRect(BYVAL %NULL, rc)
                               END IF
                      
                            CASE %WM_DESTROY
                               ' // Destroy the instance of the Explorer browser
                               IF ISOBJECT(peb) THEN peb.Destroy
                               ' // End the application
                               PostQuitMessage 0
                               EXIT FUNCTION
                      
                         END SELECT
                      
                         ' // Pass unprocessed messages to Windows
                         FUNCTION = DefWindowProc(hwnd, uMsg, wParam, lParam)
                      
                      END FUNCTION
                      ' ========================================================================================
                      Attached Files
                      Forum: http://www.jose.it-berater.org/smfforum/index.php

                      Comment


                      • #12
                        DirectShow: Enumerating Filters

                        The Filter Graph Manager supports the IFilterGraph.EnumFilters method, which enumerates all the filters in the filter graph. It returns a pointer to the IEnumFilters interface. The IEnumFilters.Next method retrieves IBaseFilter interface pointers.

                        Code:
                        ' ########################################################################################
                        ' DirectShow example.
                        ' Enumerating filters.
                        ' ########################################################################################
                        
                        ' CSED_PBCC - Use the PBCC compiler
                        #COMPILE EXE
                        #DIM ALL
                        #INCLUDE ONCE "dshow.inc"
                        #INCLUDE ONCE "ole2utils.inc"   ' For IUnknown_Release
                        
                        ' ========================================================================================
                        ' The Filter Graph Manager supports the IFilterGraph.EnumFilters method, which enumerates
                        ' all the filters in the filter graph. It returns a pointer to the IEnumFilters interface.
                        ' The IEnumFilters.Next method retrieves IBaseFilter interface pointers.
                        ' ========================================================================================
                        FUNCTION EnumFilters (BYVAL pGraph AS IGraphBuilder) AS LONG
                        
                           LOCAL hr AS LONG                    ' HRESULT
                           LOCAL pEnum AS IEnumFilters         ' IEnumFilters interface
                           LOCAL pFilter AS IBaseFilter        ' IBaseFilter interface
                           LOCAL cFetched AS DWORD             ' Number of filters fetched
                           LOCAL FilterInfo AS FILTER_INFO     ' FILTER_INFO structure
                        
                           hr = pGraph.EnumFilters(pEnum)
                           IF hr <> %S_OK THEN
                              FUNCTION = hr
                              EXIT FUNCTION
                           END IF
                        
                           DO
                              hr = pEnum.Next(1, pFilter, cFetched)
                              IF hr <> %S_OK OR cFetched = 0 THEN EXIT DO
                              RESET FilterInfo
                              hr = pFilter.QueryFilterInfo(FilterInfo)
                              IF hr <> %S_OK THEN
                                 STDOUT "Could not get the filter info"
                              ELSE
                                 STDOUT FilterInfo.achName
                                 ' The FILTER_INFO structure holds a pointer to the Filter Graph
                                 ' Manager, with a reference count that must be released.
                                 IF FilterInfo.pGraph <> %NULL THEN IUnknown_Release FilterInfo.pGraph
                              END IF
                              ' Release the filter
                              pFilter = NOTHING
                           LOOP
                        
                           ' Release the collection
                           pEnum = NOTHING
                        
                           FUNCTION = %S_OK
                        
                        END FUNCTION
                        ' ========================================================================================
                        
                        ' ========================================================================================
                        ' Main
                        ' ========================================================================================
                        FUNCTION PBMAIN
                        
                           LOCAL pGraph AS IGraphBuilder
                           LOCAL wszFile AS WSTRINGZ * %MAX_PATH
                        
                           pGraph = NEWCOM CLSID $CLSID_FilterGraph
                           wszFile = EXE.Path$ & "useglue.wmv"
                           pGraph.RenderFile(wszFile)
                           EnumFilters(pGraph)
                           pGraph = NOTHING
                        
                           WAITKEY$
                        
                        END FUNCTION
                        ' ========================================================================================
                        Forum: http://www.jose.it-berater.org/smfforum/index.php

                        Comment


                        • #13
                          DirectShow: Play Clip

                          Allows to select a video clip and plays it.

                          CWindow version:

                          Code:
                          ' ========================================================================================
                          ' DirectShow example.
                          ' Allows to select a video clip and plays it.
                          ' Based on an example by Vladimir Shulakov posted in the PowerBASIC forums:
                          ' http://www.powerbasic.com/support/pbforums/showthread.php?t=23966
                          ' ========================================================================================
                          
                          ' CSED_PBWIN - Use the PBWIN compiler
                          #COMPILE EXE
                          #DIM ALL
                          %UNICODE = 1
                          
                          #INCLUDE ONCE "CWindow.inc"
                          #INCLUDE ONCE "commdlg.inc"
                          #INCLUDE ONCE "dshow.inc"
                          
                          ' Menu identifiers
                          %ID_FILE_OPENCLIP = 40001
                          %ID_FILE_EXIT     = 40002
                          
                          ' Custom message
                          %WM_GRAPHNOTIFY   = %WM_USER + 13
                          
                          GLOBAL bIsPlaying AS LONG
                          
                          ' Interface pointers
                          GLOBAL pIGraphBuilder AS IGraphBuilder
                          GLOBAL pIMediaControl AS IMediaControl
                          GLOBAL pIMediaEventEx AS IMediaEventEx
                          GLOBAL pIVideoWindow  AS IVideoWindow
                          
                          ' ========================================================================================
                          ' Play the movie inside the window.
                          ' ========================================================================================
                          SUB PlayMovieInWindow (BYVAL hwnd AS DWORD, BYREF wszFileName AS WSTRINGZ)
                          
                             LOCAL hr AS LONG
                          
                             ' If there is a clip loaded, stop it
                             IF ISOBJECT(pIMediaControl) THEN
                                pIMediaControl.Stop
                                pIMediaControl = NOTHING
                                pIVideoWindow = NOTHING
                                pIMediaEventEx = NOTHING
                                pIGraphBuilder = NOTHING
                             END IF
                          
                             ' Create an instance of the IGraphBuilder object
                             pIGraphBuilder = NEWCOM CLSID $CLSID_FilterGraph
                             IF hr <> %S_OK OR ISNOTHING(pIGraphBuilder) THEN EXIT SUB
                          
                             ' Retrieve interafce pointers
                             pIMediaControl = pIGraphBuilder
                             IF ISNOTHING(pIMediaControl) THEN EXIT SUB
                             pIMediaEventEx = pIGraphBuilder
                             IF ISNOTHING(pIMediaEventEx) THEN EXIT SUB
                             pIVideoWindow = pIGraphBuilder
                             IF ISNOTHING(pIVideoWindow) THEN EXIT SUB
                          
                             ' Render the file
                             hr = pIGraphBuilder.RenderFile(wszFileName)
                             IF hr <> %S_OK THEN EXIT SUB
                          
                             ' Set the window owner and style
                             pIVideoWindow.Visible = %OAFALSE
                             pIVideoWindow.Owner = hwnd
                             pIVideoWindow.WindowStyle = %WS_CHILD OR %WS_CLIPSIBLINGS OR %WS_CLIPCHILDREN
                          
                             ' Have the graph signal event via window callbacks for performance
                             pIMediaEventEx.SetNotifyWindow(hwnd, %WM_GRAPHNOTIFY, 0)
                          
                             ' Set the window position
                             LOCAL rc AS RECT
                             GetClientRect hwnd, rc
                             pIVideoWindow.SetWindowPosition(rc.Left, rc.Top, rc.Right, rc.Bottom)
                             ' Make the window visible
                             pIVideoWindow.Visible = %OATRUE
                          
                             ' Run the graph
                             pIMediaControl.Run
                             bIsPlaying = %TRUE
                          
                          END SUB
                          ' ========================================================================================
                          
                          ' ========================================================================================
                          ' Main
                          ' ========================================================================================
                          FUNCTION WinMain (BYVAL hInstance AS DWORD, BYVAL hPrevInstance AS DWORD, BYVAL lpszCmdLine AS WSTRINGZ PTR, BYVAL nCmdShow AS LONG) AS LONG
                          
                             ' // Set process DPI aware
                             SetProcessDPIAware
                          
                             ' // Create an instance of the class
                             LOCAL pWindow AS IWindow
                             pWindow = CLASS "CWindow"
                             IF ISNOTHING(pWindow) THEN EXIT FUNCTION
                          
                             ' // Create the main window
                             ' // Note: CW_USEDEFAULT is used as the default value When passing 0's as the width and height
                             pWindow.CreateWindow(%NULL, "DirectShow Demo", 0, 0, 0, 0, 0, 0, CODEPTR(WindowProc))
                             ' // Set the client size
                             pWindow.SetClientSize 500, 320
                             ' // Center the window
                             pWindow.CenterWindow
                          
                             LOCAL hMenu AS DWORD
                             LOCAL hMenuFile AS DWORD
                             hMenu = CreateMenu
                             hMenuFile = CreatePopUpMenu
                             AppendMenu hMenu, %MF_POPUP OR %MF_ENABLED, hMenuFile, "&File"
                             AppendMenu hMenuFile, %MF_ENABLED, %ID_FILE_OPENCLIP, "&Open clip..."
                             AppendMenu hMenuFile, %MF_ENABLED, %ID_FILE_EXIT, "E&xit"
                             SetMenu pWindow.hwnd, hMenu
                          
                             ' // Default message pump (you can replace it with your own)
                             pWindow.DoEvents(nCmdShow)
                          
                          END FUNCTION
                          ' ========================================================================================
                          
                          ' ========================================================================================
                          ' Main Window procedure
                          ' ========================================================================================
                          FUNCTION WindowProc (BYVAL hwnd AS DWORD, BYVAL wMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG
                          
                             LOCAL hDC AS DWORD
                             LOCAL rc AS RECT
                             LOCAL strFilter AS WSTRING
                             LOCAL strDefExt AS WSTRING
                             LOCAL strFileName AS WSTRING
                          
                             SELECT CASE wMsg
                          
                                CASE %WM_COMMAND
                          
                                   SELECT CASE LO(WORD, wParam)
                          
                                      CASE %IDCANCEL, %ID_FILE_EXIT
                                         IF HI(WORD, wParam) = %BN_CLICKED AND bIsPlaying = 0 THEN
                                            SendMessage hwnd, %WM_CLOSE, 0, 0
                                            FUNCTION = 0
                                            EXIT FUNCTION
                                         END IF
                          
                                      CASE %ID_FILE_OPENCLIP
                                         IF HI(WORD, wParam) = %BN_CLICKED THEN
                                            strFilter = CHR$("Video Files (*.MPG;*MPEG;*.AVI;*.MOV;*.QT;*.WMV)", 0, "*.MPG;*.MPEG;*.AVI;*.MOV;*.QT;*.WMV", 0)
                                            DISPLAY OPENFILE hwnd, 0, 0, "", "", strFilter, "", "", %OFN_EXPLORER OR %OFN_FILEMUSTEXIST TO strFileName
                                            IF LEN(strFileName) THEN PlayMovieInWindow(hwnd, BYCOPY strFileName)
                                         END IF
                          
                                   END SELECT
                          
                                CASE %WM_GRAPHNOTIFY
                          
                                   LOCAL lEventCode AS LONG
                                   LOCAL lParam1 AS LONG
                                   LOCAL lParam2 AS LONG
                          
                                   IF ISOBJECT(pIMediaEventEx) THEN
                                      DO
                                         pIMediaEventEx.GetEvent(lEventCode, lParam1, lParam2, 0)
                                         IF OBJRESULT <> %S_OK THEN EXIT DO
                                         pIMediaEventEx.FreeEventParams(lEventCode, lParam1, lParam2)
                                         IF lEventCode = %EC_COMPLETE THEN
                                            IF ISOBJECT(pIVideoWindow) THEN
                                               pIVideoWindow.Visible = %OAFALSE
                                               pIVideoWindow.Owner = %NULL
                                               pIVideoWindow = NOTHING
                                            END IF
                                            pIMediaControl = NOTHING
                                            pIMediaEventEx = NOTHING
                                            pIGraphBuilder = NOTHING
                                            bIsPlaying = %FALSE
                                            EXIT DO
                                         END IF
                                      LOOP
                                   END IF
                          
                                CASE %WM_SIZE
                                   GetClientRect hwnd, rc
                                   IF ISOBJECT(pIVideoWindow) THEN
                                      pIVideoWindow.SetWindowPosition(rc.Left, rc.Top, rc.Right, rc.Bottom)
                                      RedrawWindow hwnd, rc, 0, %RDW_INVALIDATE OR %RDW_UPDATENOW
                                   END IF
                          
                                CASE %WM_ERASEBKGND
                                   IF bIsPlaying = %FALSE THEN
                                      hDC = wParam
                                      GetClientRect hwnd, rc
                                      FillRect hDC, rc, GetStockObject(%BLACK_BRUSH)
                                      FUNCTION = %TRUE
                                      EXIT FUNCTION
                                   END IF
                          
                                CASE %WM_SYSCOMMAND
                                   ' Capture this message and send a WM_CLOSE message
                                   IF (wParam AND &HFFF0) = %SC_CLOSE THEN
                                      SendMessage hwnd, %WM_CLOSE, 0, 0
                                      EXIT FUNCTION
                                   END IF
                          
                                CASE %WM_DESTROY
                                   IF ISOBJECT(pIMediaControl) THEN
                                      pIMediaControl.Stop
                                      pIMediaControl = NOTHING
                                   END IF
                                   IF ISOBJECT(pIVideoWindow) THEN
                                      pIVideoWindow.Visible = %OAFALSE
                                      pIVideoWindow.Owner = %NULL
                                      pIVideoWindow = NOTHING
                                   END IF
                                   pIMediaEventEx = NOTHING
                                   pIGraphBuilder = NOTHING
                                   PostQuitMessage 0
                                   EXIT FUNCTION
                          
                             END SELECT
                          
                             FUNCTION = DefWindowProc(hwnd, wMsg, wParam, lParam)
                          
                          END FUNCTION
                          ' ========================================================================================
                          Attached Files
                          Forum: http://www.jose.it-berater.org/smfforum/index.php

                          Comment


                          • #14
                            Macromedia Flash Player

                            Demonstrates how to create an instance of the ShockWaveFlash player in a DDT dialog, load and play a movie and setting properties.

                            Code:
                            ' ########################################################################################
                            ' Demonstrates how to create an instance of the ShockWaveFlash player in a DDT dialog,
                            ' load and play a movie and setting properties.
                            ' ########################################################################################
                            
                            #COMPILE EXE
                            #DIM ALL
                            %UNICODE = 1
                            
                            ' // Include files for external files
                            %USEOLECON = 1                ' // Use OLE container
                            #INCLUDE ONCE "CWindow.inc"   ' // CWindow class
                            #INCLUDE ONCE "FLASH9.INC"
                            
                            %IDC_FLASH = 101
                            
                            ' ========================================================================================
                            ' Main
                            ' ========================================================================================
                            FUNCTION PBMAIN () AS LONG
                            
                               ' // Create the dialog
                               LOCAL hDlg AS DWORD
                               DIALOG NEW PIXELS, 0, "Macromedia Flash Player 9", , , 450, 250, %WS_OVERLAPPEDWINDOW TO hDlg
                            
                               ' // Create an instance of the class
                               LOCAL pWindow AS IWindow
                               pWindow = CLASS "CWindow"
                               IF ISNOTHING(pWindow) THEN EXIT FUNCTION
                            
                               ' // Add a MS Calendar control
                               LOCAL nWide, nHigh AS LONG
                               DIALOG GET CLIENT hDlg TO nWide, nHigh
                               LOCAL hCtl AS DWORD
                               hCtl = pWindow.AddOCX(hDlg, %IDC_FLASH, "ShockwaveFlash.ShockwaveFlash", "", 0, 0, nWide, nHigh)
                               CONTROL SET FOCUS hDlg, %IDC_FLASH
                            
                               ' // Get the IDispatch of the control
                               LOCAL pFlash AS IShockwaveFlash
                               pFlash = OC_GetDispatch(hCtl)
                               IF ISOBJECT(pFlash) THEN
                                  ' // Load the flash video - a full qualified path must be used
                                  pFlash.Movie = EXE.Path$ & "choudanse7.swf"
                                  ' // Play the video
                                  pFlash.Play
                                  ' ---------------------------------------------------------------------
                                  ' Example code to set properties
                                  ' ---------------------------------------------------------------------
                                  ' // Rotate the video
                            '            pFlash.SetVariable("_rotation", "10")
                                  ' // Modify the video transparency
                            '            pFlash.SetVariable("_alpha", "50")
                                  ' // Modify the scale and position
                                  pFlash.SetVariable("_xscale", "50")
                                  pFlash.SetVariable("_yscale", "50")
                                  pFlash.SetVariable("_x", "80")
                                  pFlash.SetVariable("_y", "40")
                                  ' ---------------------------------------------------------------------
                                  ' // Release the interface
                                  pFlash = NOTHING
                               END IF
                            
                               ' // Display and activate the dialog
                               DIALOG SHOW MODAL hDlg, CALL DlgProc
                            
                            END FUNCTION
                            ' ========================================================================================
                            
                            ' ========================================================================================
                            ' Main Dialog procedure
                            ' ========================================================================================
                            CALLBACK FUNCTION DlgProc() AS LONG
                            
                               SELECT CASE CBMSG
                            
                                  CASE %WM_COMMAND
                                     SELECT CASE CB.CTL
                                        ' ...
                                        ' ...
                                     END SELECT
                            
                                  CASE %WM_SIZE
                                     IF CB.WPARAM <> %SIZE_MINIMIZED THEN
                                        ' // Resize the control
                                        LOCAL nWide, nHigh AS LONG
                                        DIALOG GET CLIENT CB.HNDL TO nWide, nHigh
                                        CONTROL SET SIZE CB.HNDL, %IDC_FLASH, nWide, nHigh
                                     END IF
                            
                               END SELECT
                            
                            END FUNCTION
                            ' ========================================================================================
                            Attached Files
                            Forum: http://www.jose.it-berater.org/smfforum/index.php

                            Comment


                            • #15
                              Windows Media Pleyer

                              Demonstrates how to embed the Microsoft Windows Media Player control.

                              Code:
                              ' ########################################################################################
                              ' Demonstrates how to embed the Microsoft Windows Media Player control
                              ' ########################################################################################
                              
                              #COMPILE EXE
                              #DIM ALL
                              %UNICODE = 1
                              %USEOLECON = 1
                              
                              ' // Include files for external files
                              #INCLUDE ONCE "CWindow.inc"   ' // CWindow class
                              #INCLUDE ONCE "olecon.inc"    ' // Ole Container
                              #INCLUDE ONCE "WMP.inc"       ' // Windows Media Player
                              
                              ' // Identifier
                              %IDC_WMP = 101
                              
                              ' ########################################################################################
                              ' Main
                              ' ########################################################################################
                              FUNCTION WinMain (BYVAL hInstance AS DWORD, BYVAL hPrevInstance AS DWORD, BYVAL lpszCmdLine AS WSTRINGZ PTR, BYVAL nCmdShow AS LONG) AS LONG
                              
                                 ' // Make the application High DPI aware
                              '   SetProcessDPIAware
                              
                                 ' // Create an instance of the class
                                 LOCAL pWindow AS IWindow
                                 pWindow = CLASS "CWindow"
                                 IF ISNOTHING(pWindow) THEN EXIT FUNCTION
                              
                                 ' // Create the main window
                                 pWindow.CreateWindow(%NULL, "Windows Media Player", 0, 0, 0, 0, 0, 0, CODEPTR(WindowProc))
                                 ' // Set the client size
                                 pWindow.SetClientSize 400, 320
                                 ' // Center the window
                                 pWindow.CenterWindow
                              
                                 ' // Display a Windows Media Player video
                                 LOCAL hWMP AS DWORD
                                 hWMP = pWindow.AddOCX(pWindow.hwnd, %IDC_WMP, "WMPlayer.OCX", "", 0, 0, pWindow.ClientWidth, pWindow.ClientHeight)
                                 ' // Set the focus in the control
                                 SetFocus hWMP
                                 ' // Get a pointer to the IWMPPlayer4 interface
                                 LOCAL pIWMPPlayer4 AS IWMPPlayer4
                                 pIWMPPlayer4 = OC_GetDispatch(hWMP)
                                 ' // Connect events
                                 IF ISOBJECT(pIWMPPlayer4) THEN
                                    LOCAL pWMPOCXEvents AS WMPOCXEventsImpl
                                    pWMPOCXEvents = CLASS "CWMPOCXEvents"
                                    IF ISOBJECT(pWMPOCXEvents) THEN OC_Advise(hWMP, pWMPOCXEvents, GUID$("{6BF52A51-394A-11D3-B153-00C04F79FAA6}"))
                                    ' // Set the URL
                                    pIWMPPlayer4.URL = EXE.Path$ & "Secretarys_***.wmv"
                                    ' // Play the movie
                                    pIWMPPlayer4.controls.play
                                    ' // Release the interface
                                    pIWMPPlayer4 = NOTHING
                                 END IF
                              
                                 ' // Default message pump (you can replace it with your own)
                                 pWindow.DoEvents(nCmdShow)
                              
                              END FUNCTION
                              ' ########################################################################################
                              
                              ' ========================================================================================
                              ' Main callback function.
                              ' ========================================================================================
                              FUNCTION WindowProc (BYVAL hwnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG
                              
                                 STATIC pWindow AS IWindow        ' // Reference to the IWindow interface
                              
                                 SELECT CASE uMsg
                              
                                    CASE %WM_CREATE
                                       ' // Get a reference to the IWindow interface from the CREATESTRUCT structure
                                       pWindow = CWindow_GetObjectFromCreateStruct(lParam)
                                       EXIT FUNCTION
                              
                                    CASE %WM_SYSCOMMAND
                                       ' // Capture this message and send a WM_CLOSE message
                                       ' // Note: Needed with some OCXs, that otherwise remain in memory
                                       IF (wParam AND &HFFF0) = %SC_CLOSE THEN
                                          SendMessage hwnd, %WM_CLOSE, 0, 0
                                          EXIT FUNCTION
                                       END IF
                              
                                    CASE %WM_COMMAND
                                       SELECT CASE LO(WORD, wParam)
                                          CASE %IDCANCEL
                                             ' // If the Escape key has been pressed...
                                             IF HI(WORD, wParam) = %BN_CLICKED THEN
                                                ' // ... close the application by sending a WM_CLOSE message
                                                SendMessage hwnd, %WM_CLOSE, 0, 0
                                                EXIT FUNCTION
                                             END IF
                                       END SELECT
                              
                                    CASE %WM_SIZE
                                       IF wParam <> %SIZE_MINIMIZED THEN
                                          ' // Resize the control
                                          pWindow.MoveWindow GetDlgItem(hwnd, %IDC_WMP), 0, 0, pWindow.ClientWidth, pWindow.ClientHeight, %TRUE
                                       END IF
                              
                                    CASE %WM_DESTROY
                                       ' // End the application
                                       PostQuitMessage 0
                                       EXIT FUNCTION
                              
                                 END SELECT
                              
                                 ' // Pass unprocessed messages to Windows
                                 FUNCTION = DefWindowProc(hwnd, uMsg, wParam, lParam)
                              
                              END FUNCTION
                              ' ========================================================================================
                              
                              ' ########################################################################################
                              ' Class CWMPOCXEvents
                              ' Interface name = _WMPOCXEvents
                              ' IID = {6BF52A51-394A-11D3-B153-00C04F79FAA6}
                              ' _WMPOCXEvents: Public interface.
                              ' Attributes = 4112 [&H1010] [Hidden] [Dispatchable]
                              ' Code generated by the TypeLib Browser 4.0.13 (c) 2008 by Josť Roca
                              ' Date: 17 dic 2008   Time: 04:21:06
                              ' ########################################################################################
                              
                              CLASS CWMPOCXEvents GUID$("{E0D086A3-4900-47A6-A2C9-E806B39CD878}") AS EVENT
                              
                              INTERFACE WMPOCXEventsImpl GUID$("{6BF52A51-394A-11D3-B153-00C04F79FAA6}") AS EVENT
                              
                                INHERIT IDispatch
                              
                                 ' =====================================================================================
                                 METHOD OpenStateChange <5001> ( _
                                   BYVAL NewState AS LONG _                           ' [in] NewState VT_I4 <Long>
                                 )                                                    ' VOID
                              
                                   ' *** Insert your code here ***
                                   OutputDebugString FUNCNAME$
                              
                                 END METHOD
                                 ' =====================================================================================
                              
                                 ' =====================================================================================
                                 METHOD PlayStateChange <5101> ( _
                                   BYVAL NewState AS LONG _                           ' [in] NewState VT_I4 <Long>
                                 )                                                    ' VOID
                              
                                   ' *** Insert your code here ***
                                   OutputDebugString FUNCNAME$
                              
                                 END METHOD
                                 ' =====================================================================================
                              
                                 ' =====================================================================================
                                 METHOD AudioLanguageChange <5102> ( _
                                   BYVAL LangID AS LONG _                             ' [in] LangID VT_I4 <Long>
                                 )                                                    ' VOID
                              
                                   ' *** Insert your code here ***
                                   OutputDebugString FUNCNAME$
                              
                                 END METHOD
                                 ' =====================================================================================
                              
                                 ' =====================================================================================
                                 METHOD StatusChange <5002>
                              
                                   ' *** Insert your code here ***
                                   OutputDebugString FUNCNAME$
                              
                                 END METHOD
                                 ' =====================================================================================
                              
                                 ' =====================================================================================
                                 METHOD ScriptCommand <5301> ( _
                                   BYVAL scType AS STRING _                           ' [in] scType VT_BSTR
                                 , BYVAL Param AS STRING _                            ' [in] Param VT_BSTR
                                 )                                                    ' VOID
                              
                                   ' *** Insert your code here ***
                                   OutputDebugString FUNCNAME$
                              
                                 END METHOD
                                 ' =====================================================================================
                              
                                 ' =====================================================================================
                                 METHOD NewStream <5403>
                              
                                   ' *** Insert your code here ***
                                   OutputDebugString FUNCNAME$
                              
                                 END METHOD
                                 ' =====================================================================================
                              
                                 ' =====================================================================================
                                 METHOD Disconnect <5401> ( _
                                   BYVAL Result AS LONG _                             ' [in] Result VT_I4 <Long>
                                 )                                                    ' VOID
                              
                                   ' *** Insert your code here ***
                                   OutputDebugString FUNCNAME$
                              
                                 END METHOD
                                 ' =====================================================================================
                              
                                 ' =====================================================================================
                                 METHOD Buffering <5402> ( _
                                   BYVAL Start AS INTEGER _                           ' [in] Start VT_BOOL <Integer>
                                 )                                                    ' VOID
                              
                                   ' *** Insert your code here ***
                                   OutputDebugString FUNCNAME$
                              
                                 END METHOD
                                 ' =====================================================================================
                              
                                 ' =====================================================================================
                                 METHOD Error <5501>
                              
                                   ' *** Insert your code here ***
                                   OutputDebugString FUNCNAME$
                              
                                 END METHOD
                                 ' =====================================================================================
                              
                                 ' =====================================================================================
                                 METHOD Warning <5601> ( _
                                   BYVAL WarningType AS LONG _                        ' [in] WarningType VT_I4 <Long>
                                 , BYVAL Param AS LONG _                              ' [in] Param VT_I4 <Long>
                                 , BYVAL Description AS STRING _                      ' [in] Description VT_BSTR
                                 )                                                    ' VOID
                              
                                   ' *** Insert your code here ***
                                   OutputDebugString FUNCNAME$
                              
                                 END METHOD
                                 ' =====================================================================================
                              
                                 ' =====================================================================================
                                 METHOD EndOfStream <5201> ( _
                                   BYVAL Result AS LONG _                             ' [in] Result VT_I4 <Long>
                                 )                                                    ' VOID
                              
                                   ' *** Insert your code here ***
                                   OutputDebugString FUNCNAME$
                              
                                 END METHOD
                                 ' =====================================================================================
                              
                                 ' =====================================================================================
                                 METHOD PositionChange <5202> ( _
                                   BYVAL oldPosition AS DOUBLE _                      ' [in] oldPosition VT_R8 <Double>
                                 , BYVAL newPosition AS DOUBLE _                      ' [in] newPosition VT_R8 <Double>
                                 )                                                    ' VOID
                              
                                   ' *** Insert your code here ***
                                   OutputDebugString FUNCNAME$
                              
                                 END METHOD
                                 ' =====================================================================================
                              
                                 ' =====================================================================================
                                 METHOD MarkerHit <5203> ( _
                                   BYVAL MarkerNum AS LONG _                          ' [in] MarkerNum VT_I4 <Long>
                                 )                                                    ' VOID
                              
                                   ' *** Insert your code here ***
                                   OutputDebugString FUNCNAME$
                              
                                 END METHOD
                                 ' =====================================================================================
                              
                                 ' =====================================================================================
                                 METHOD DurationUnitChange <5204> ( _
                                   BYVAL NewDurationUnit AS LONG _                    ' [in] NewDurationUnit VT_I4 <Long>
                                 )                                                    ' VOID
                              
                                   ' *** Insert your code here ***
                                   OutputDebugString FUNCNAME$
                              
                                 END METHOD
                                 ' =====================================================================================
                              
                                 ' =====================================================================================
                                 METHOD CdromMediaChange <5701> ( _
                                   BYVAL CdromNum AS LONG _                           ' [in] CdromNum VT_I4 <Long>
                                 )                                                    ' VOID
                              
                                   ' *** Insert your code here ***
                                   OutputDebugString FUNCNAME$
                              
                                 END METHOD
                                 ' =====================================================================================
                              
                                 ' =====================================================================================
                                 METHOD PlaylistChange <5801> ( _
                                   BYVAL Playlist AS IDispatch _                      ' [in] *Playlist VT_DISPATCH <IDispatch>
                                 , BYVAL change AS LONG _                             ' [in] change WMPPlaylistChangeEventType <enum>
                                 )                                                    ' VOID
                              
                                   ' *** Insert your code here ***
                                   OutputDebugString FUNCNAME$
                              
                                 END METHOD
                                 ' =====================================================================================
                              
                                 ' =====================================================================================
                                 METHOD CurrentPlaylistChange <5804> ( _
                                   BYVAL change AS LONG _                             ' [in] change WMPPlaylistChangeEventType <enum>
                                 )                                                    ' VOID
                              
                                   ' *** Insert your code here ***
                                   OutputDebugString FUNCNAME$
                              
                                 END METHOD
                                 ' =====================================================================================
                              
                                 ' =====================================================================================
                                 METHOD CurrentPlaylistItemAvailable <5805> ( _
                                   BYVAL bstrItemName AS STRING _                     ' [in] bstrItemName VT_BSTR
                                 )                                                    ' VOID
                              
                                   ' *** Insert your code here ***
                                   OutputDebugString FUNCNAME$
                              
                                 END METHOD
                                 ' =====================================================================================
                              
                                 ' =====================================================================================
                                 METHOD MediaChange <5802> ( _
                                   BYVAL Item AS IDispatch _                          ' [in] *Item VT_DISPATCH <IDispatch>
                                 )                                                    ' VOID
                              
                                   ' *** Insert your code here ***
                                   OutputDebugString FUNCNAME$
                              
                                 END METHOD
                                 ' =====================================================================================
                              
                                 ' =====================================================================================
                                 METHOD CurrentMediaItemAvailable <5803> ( _
                                   BYVAL bstrItemName AS STRING _                     ' [in] bstrItemName VT_BSTR
                                 )                                                    ' VOID
                              
                                   ' *** Insert your code here ***
                                   OutputDebugString FUNCNAME$
                              
                                 END METHOD
                                 ' =====================================================================================
                              
                                 ' =====================================================================================
                                 METHOD CurrentItemChange <5806> ( _
                                   BYVAL pdispMedia AS IDispatch _                    ' [in] *pdispMedia VT_DISPATCH <IDispatch>
                                 )                                                    ' VOID
                              
                                   ' *** Insert your code here ***
                                   OutputDebugString FUNCNAME$
                              
                                 END METHOD
                                 ' =====================================================================================
                              
                                 ' =====================================================================================
                                 METHOD MediaCollectionChange <5807>
                              
                                   ' *** Insert your code here ***
                                   OutputDebugString FUNCNAME$
                              
                                 END METHOD
                                 ' =====================================================================================
                              
                                 ' =====================================================================================
                                 METHOD MediaCollectionAttributeStringAdded <5808> ( _
                                   BYVAL bstrAttribName AS STRING _                   ' [in] bstrAttribName VT_BSTR
                                 , BYVAL bstrAttribVal AS STRING _                    ' [in] bstrAttribVal VT_BSTR
                                 )                                                    ' VOID
                              
                                   ' *** Insert your code here ***
                                   OutputDebugString FUNCNAME$
                              
                                 END METHOD
                                 ' =====================================================================================
                              
                                 ' =====================================================================================
                                 METHOD MediaCollectionAttributeStringRemoved <5809> ( _
                                   BYVAL bstrAttribName AS STRING _                   ' [in] bstrAttribName VT_BSTR
                                 , BYVAL bstrAttribVal AS STRING _                    ' [in] bstrAttribVal VT_BSTR
                                 )                                                    ' VOID
                              
                                   ' *** Insert your code here ***
                                   OutputDebugString FUNCNAME$
                              
                                 END METHOD
                                 ' =====================================================================================
                              
                                 ' =====================================================================================
                                 METHOD MediaCollectionAttributeStringChanged <5820> ( _
                                   BYVAL bstrAttribName AS STRING _                   ' [in] bstrAttribName VT_BSTR
                                 , BYVAL bstrOldAttribVal AS STRING _                 ' [in] bstrOldAttribVal VT_BSTR
                                 , BYVAL bstrNewAttribVal AS STRING _                 ' [in] bstrNewAttribVal VT_BSTR
                                 )                                                    ' VOID
                              
                                   ' *** Insert your code here ***
                                   OutputDebugString FUNCNAME$
                              
                                 END METHOD
                                 ' =====================================================================================
                              
                                 ' =====================================================================================
                                 METHOD PlaylistCollectionChange <5810>
                              
                                   ' *** Insert your code here ***
                                   OutputDebugString FUNCNAME$
                              
                                 END METHOD
                                 ' =====================================================================================
                              
                                 ' =====================================================================================
                                 METHOD PlaylistCollectionPlaylistAdded <5811> ( _
                                   BYVAL bstrPlaylistName AS STRING _                 ' [in] bstrPlaylistName VT_BSTR
                                 )                                                    ' VOID
                              
                                   ' *** Insert your code here ***
                                   OutputDebugString FUNCNAME$
                              
                                 END METHOD
                                 ' =====================================================================================
                              
                                 ' =====================================================================================
                                 METHOD PlaylistCollectionPlaylistRemoved <5812> ( _
                                   BYVAL bstrPlaylistName AS STRING _                 ' [in] bstrPlaylistName VT_BSTR
                                 )                                                    ' VOID
                              
                                   ' *** Insert your code here ***
                                   OutputDebugString FUNCNAME$
                              
                                 END METHOD
                                 ' =====================================================================================
                              
                                 ' =====================================================================================
                                 METHOD PlaylistCollectionPlaylistSetAsDeleted <5818> ( _
                                   BYVAL bstrPlaylistName AS STRING _                 ' [in] bstrPlaylistName VT_BSTR
                                 , BYVAL varfIsDeleted AS INTEGER _                   ' [in] varfIsDeleted VT_BOOL <Integer>
                                 )                                                    ' VOID
                              
                                   ' *** Insert your code here ***
                                   OutputDebugString FUNCNAME$
                              
                                 END METHOD
                                 ' =====================================================================================
                              
                                 ' =====================================================================================
                                 METHOD ModeChange <5819> ( _
                                   BYVAL ModeName AS STRING _                         ' [in] ModeName VT_BSTR
                                 , BYVAL NewValue AS INTEGER _                        ' [in] NewValue VT_BOOL <Integer>
                                 )                                                    ' VOID
                              
                                   ' *** Insert your code here ***
                                   OutputDebugString FUNCNAME$
                              
                                 END METHOD
                                 ' =====================================================================================
                              
                                 ' =====================================================================================
                                 METHOD MediaError <5821> ( _
                                   BYVAL pMediaObject AS IDispatch _                  ' [in] *pMediaObject VT_DISPATCH <IDispatch>
                                 )                                                    ' VOID
                              
                                   ' *** Insert your code here ***
                                   OutputDebugString FUNCNAME$
                              
                                 END METHOD
                                 ' =====================================================================================
                              
                                 ' =====================================================================================
                                 METHOD OpenPlaylistSwitch <5823> ( _
                                   BYVAL pItem AS IDispatch _                         ' [in] *pItem VT_DISPATCH <IDispatch>
                                 )                                                    ' VOID
                              
                                   ' *** Insert your code here ***
                                   OutputDebugString FUNCNAME$
                              
                                 END METHOD
                                 ' =====================================================================================
                              
                                 ' =====================================================================================
                                 METHOD DomainChange <5822> ( _
                                   BYVAL strDomain AS STRING _                        ' [in] strDomain VT_BSTR
                                 )                                                    ' VOID
                              
                                   ' *** Insert your code here ***
                                   OutputDebugString FUNCNAME$
                              
                                 END METHOD
                                 ' =====================================================================================
                              
                                 ' =====================================================================================
                                 METHOD SwitchedToPlayerApplication <6501>
                              
                                   ' *** Insert your code here ***
                                   OutputDebugString FUNCNAME$
                              
                                 END METHOD
                                 ' =====================================================================================
                              
                                 ' =====================================================================================
                                 METHOD SwitchedToControl <6502>
                              
                                   ' *** Insert your code here ***
                                   OutputDebugString FUNCNAME$
                              
                                 END METHOD
                                 ' =====================================================================================
                              
                                 ' =====================================================================================
                                 METHOD PlayerDockedStateChange <6503>
                              
                                   ' *** Insert your code here ***
                                   OutputDebugString FUNCNAME$
                              
                                 END METHOD
                                 ' =====================================================================================
                              
                                 ' =====================================================================================
                                 METHOD PlayerReconnect <6504>
                              
                                   ' *** Insert your code here ***
                                   OutputDebugString FUNCNAME$
                              
                                 END METHOD
                                 ' =====================================================================================
                              
                                 ' =====================================================================================
                                 METHOD Click <6505> ( _
                                   BYVAL nButton AS INTEGER _                         ' [in] nButton VT_I2 <Integer>
                                 , BYVAL nShiftState AS INTEGER _                     ' [in] nShiftState VT_I2 <Integer>
                                 , BYVAL fX AS LONG _                                 ' [in] fX VT_I4 <Long>
                                 , BYVAL fY AS LONG _                                 ' [in] fY VT_I4 <Long>
                                 )                                                    ' VOID
                              
                                   ' *** Insert your code here ***
                                   OutputDebugString FUNCNAME$
                              
                                 END METHOD
                                 ' =====================================================================================
                              
                                 ' =====================================================================================
                                 METHOD DoubleClick <6506> ( _
                                   BYVAL nButton AS INTEGER _                         ' [in] nButton VT_I2 <Integer>
                                 , BYVAL nShiftState AS INTEGER _                     ' [in] nShiftState VT_I2 <Integer>
                                 , BYVAL fX AS LONG _                                 ' [in] fX VT_I4 <Long>
                                 , BYVAL fY AS LONG _                                 ' [in] fY VT_I4 <Long>
                                 )                                                    ' VOID
                              
                                   ' *** Insert your code here ***
                                   OutputDebugString FUNCNAME$
                              
                                 END METHOD
                                 ' =====================================================================================
                              
                                 ' =====================================================================================
                                 METHOD KeyDown <6507> ( _
                                   BYVAL nKeyCode AS INTEGER _                        ' [in] nKeyCode VT_I2 <Integer>
                                 , BYVAL nShiftState AS INTEGER _                     ' [in] nShiftState VT_I2 <Integer>
                                 )                                                    ' VOID
                              
                                   ' *** Insert your code here ***
                                   OutputDebugString FUNCNAME$
                              
                                 END METHOD
                                 ' =====================================================================================
                              
                                 ' =====================================================================================
                                 METHOD KeyPress <6508> ( _
                                   BYVAL nKeyAscii AS INTEGER _                       ' [in] nKeyAscii VT_I2 <Integer>
                                 )                                                    ' VOID
                              
                                   ' *** Insert your code here ***
                                   OutputDebugString FUNCNAME$
                              
                                 END METHOD
                                 ' =====================================================================================
                              
                                 ' =====================================================================================
                                 METHOD KeyUp <6509> ( _
                                   BYVAL nKeyCode AS INTEGER _                        ' [in] nKeyCode VT_I2 <Integer>
                                 , BYVAL nShiftState AS INTEGER _                     ' [in] nShiftState VT_I2 <Integer>
                                 )                                                    ' VOID
                              
                                   ' *** Insert your code here ***
                                   OutputDebugString FUNCNAME$
                              
                                 END METHOD
                                 ' =====================================================================================
                              
                                 ' =====================================================================================
                                 METHOD MouseDown <6510> ( _
                                   BYVAL nButton AS INTEGER _                         ' [in] nButton VT_I2 <Integer>
                                 , BYVAL nShiftState AS INTEGER _                     ' [in] nShiftState VT_I2 <Integer>
                                 , BYVAL fX AS LONG _                                 ' [in] fX VT_I4 <Long>
                                 , BYVAL fY AS LONG _                                 ' [in] fY VT_I4 <Long>
                                 )                                                    ' VOID
                              
                                   ' *** Insert your code here ***
                                   OutputDebugString FUNCNAME$
                              
                                 END METHOD
                                 ' =====================================================================================
                              
                                 ' =====================================================================================
                                 METHOD MouseMove <6511> ( _
                                   BYVAL nButton AS INTEGER _                         ' [in] nButton VT_I2 <Integer>
                                 , BYVAL nShiftState AS INTEGER _                     ' [in] nShiftState VT_I2 <Integer>
                                 , BYVAL fX AS LONG _                                 ' [in] fX VT_I4 <Long>
                                 , BYVAL fY AS LONG _                                 ' [in] fY VT_I4 <Long>
                                 )                                                    ' VOID
                              
                                   ' *** Insert your code here ***
                                   OutputDebugString FUNCNAME$
                              
                                 END METHOD
                                 ' =====================================================================================
                              
                                 ' =====================================================================================
                                 METHOD MouseUp <6512> ( _
                                   BYVAL nButton AS INTEGER _                         ' [in] nButton VT_I2 <Integer>
                                 , BYVAL nShiftState AS INTEGER _                     ' [in] nShiftState VT_I2 <Integer>
                                 , BYVAL fX AS LONG _                                 ' [in] fX VT_I4 <Long>
                                 , BYVAL fY AS LONG _                                 ' [in] fY VT_I4 <Long>
                                 )                                                    ' VOID
                              
                                   ' *** Insert your code here ***
                                   OutputDebugString FUNCNAME$
                              
                                 END METHOD
                                 ' =====================================================================================
                              
                                 ' =====================================================================================
                                 METHOD DeviceConnect <6513> ( _
                                   BYVAL pDevice AS IWMPSyncDevice _                  ' [in] *pDevice IWMPSyncDevice <interface>
                                 )                                                    ' VOID
                              
                                   ' *** Insert your code here ***
                                   OutputDebugString FUNCNAME$
                              
                                 END METHOD
                                 ' =====================================================================================
                              
                                 ' =====================================================================================
                                 METHOD DeviceDisconnect <6514> ( _
                                   BYVAL pDevice AS IWMPSyncDevice _                  ' [in] *pDevice IWMPSyncDevice <interface>
                                 )                                                    ' VOID
                              
                                   ' *** Insert your code here ***
                                   OutputDebugString FUNCNAME$
                              
                                 END METHOD
                                 ' =====================================================================================
                              
                                 ' =====================================================================================
                                 METHOD DeviceStatusChange <6515> ( _
                                   BYVAL pDevice AS IWMPSyncDevice _                  ' [in] *pDevice IWMPSyncDevice <interface>
                                 , BYVAL NewStatus AS LONG _                          ' [in] NewStatus WMPDeviceStatus <enum>
                                 )                                                    ' VOID
                              
                                   ' *** Insert your code here ***
                                   OutputDebugString FUNCNAME$
                              
                                 END METHOD
                                 ' =====================================================================================
                              
                                 ' =====================================================================================
                                 METHOD DeviceSyncStateChange <6516> ( _
                                   BYVAL pDevice AS IWMPSyncDevice _                  ' [in] *pDevice IWMPSyncDevice <interface>
                                 , BYVAL NewState AS LONG _                           ' [in] NewState WMPSyncState <enum>
                                 )                                                    ' VOID
                              
                                   ' *** Insert your code here ***
                                   OutputDebugString FUNCNAME$
                              
                                 END METHOD
                                 ' =====================================================================================
                              
                                 ' =====================================================================================
                                 METHOD DeviceSyncError <6517> ( _
                                   BYVAL pDevice AS IWMPSyncDevice _                  ' [in] *pDevice IWMPSyncDevice <interface>
                                 , BYVAL pMedia AS IDispatch _                        ' [in] *pMedia VT_DISPATCH <IDispatch>
                                 )                                                    ' VOID
                              
                                   ' *** Insert your code here ***
                                   OutputDebugString FUNCNAME$
                              
                                 END METHOD
                                 ' =====================================================================================
                              
                                 ' =====================================================================================
                                 METHOD CreatePartnershipComplete <6518> ( _
                                   BYVAL pDevice AS IWMPSyncDevice _                  ' [in] *pDevice IWMPSyncDevice <interface>
                                 , BYVAL hrResult AS LONG _                           ' [in] hrResult VT_HRESULT <Long>
                                 )                                                    ' VOID
                              
                                   ' *** Insert your code here ***
                                   OutputDebugString FUNCNAME$
                              
                                 END METHOD
                                 ' =====================================================================================
                              
                                 ' =====================================================================================
                                 METHOD CdromRipStateChange <6519> ( _
                                   BYVAL pCdromRip AS IWMPCdromRip _                  ' [in] *pCdromRip IWMPCdromRip <interface>
                                 , BYVAL wmprs AS LONG _                              ' [in] wmprs WMPRipState <enum>
                                 )                                                    ' VOID
                              
                                   ' *** Insert your code here ***
                                   OutputDebugString FUNCNAME$
                              
                                 END METHOD
                                 ' =====================================================================================
                              
                                 ' =====================================================================================
                                 METHOD CdromRipMediaError <6520> ( _
                                   BYVAL pCdromRip AS IWMPCdromRip _                  ' [in] *pCdromRip IWMPCdromRip <interface>
                                 , BYVAL pMedia AS IDispatch _                        ' [in] *pMedia VT_DISPATCH <IDispatch>
                                 )                                                    ' VOID
                              
                                   ' *** Insert your code here ***
                                   OutputDebugString FUNCNAME$
                              
                                 END METHOD
                                 ' =====================================================================================
                              
                                 ' =====================================================================================
                                 METHOD CdromBurnStateChange <6521> ( _
                                   BYVAL pCdromBurn AS IWMPCdromBurn _                ' [in] *pCdromBurn IWMPCdromBurn <interface>
                                 , BYVAL wmpbs AS LONG _                              ' [in] wmpbs WMPBurnState <enum>
                                 )                                                    ' VOID
                              
                                   ' *** Insert your code here ***
                                   OutputDebugString FUNCNAME$
                              
                                 END METHOD
                                 ' =====================================================================================
                              
                                 ' =====================================================================================
                                 METHOD CdromBurnMediaError <6522> ( _
                                   BYVAL pCdromBurn AS IWMPCdromBurn _                ' [in] *pCdromBurn IWMPCdromBurn <interface>
                                 , BYVAL pMedia AS IDispatch _                        ' [in] *pMedia VT_DISPATCH <IDispatch>
                                 )                                                    ' VOID
                              
                                   ' *** Insert your code here ***
                                   OutputDebugString FUNCNAME$
                              
                                 END METHOD
                                 ' =====================================================================================
                              
                                 ' =====================================================================================
                                 METHOD CdromBurnError <6523> ( _
                                   BYVAL pCdromBurn AS IWMPCdromBurn _                ' [in] *pCdromBurn IWMPCdromBurn <interface>
                                 , BYVAL hrError AS LONG _                            ' [in] hrError VT_HRESULT <Long>
                                 )                                                    ' VOID
                              
                                   ' *** Insert your code here ***
                                   OutputDebugString FUNCNAME$
                              
                                 END METHOD
                                 ' =====================================================================================
                              
                                 ' =====================================================================================
                                 METHOD LibraryConnect <6524> ( _
                                   BYVAL pLibrary AS IWMPLibrary _                    ' [in] *pLibrary IWMPLibrary <interface>
                                 )                                                    ' VOID
                              
                                   ' *** Insert your code here ***
                                   OutputDebugString FUNCNAME$
                              
                                 END METHOD
                                 ' =====================================================================================
                              
                                 ' =====================================================================================
                                 METHOD LibraryDisconnect <6525> ( _
                                   BYVAL pLibrary AS IWMPLibrary _                    ' [in] *pLibrary IWMPLibrary <interface>
                                 )                                                    ' VOID
                              
                                   ' *** Insert your code here ***
                                   OutputDebugString FUNCNAME$
                              
                                 END METHOD
                                 ' =====================================================================================
                              
                                 ' =====================================================================================
                                 METHOD FolderScanStateChange <6526> ( _
                                   BYVAL wmpfss AS LONG _                             ' [in] wmpfss WMPFolderScanState <enum>
                                 )                                                    ' VOID
                              
                                   ' *** Insert your code here ***
                                   OutputDebugString FUNCNAME$
                              
                                 END METHOD
                                 ' =====================================================================================
                              
                                 ' =====================================================================================
                                 METHOD StringCollectionChange <5824> ( _
                                   BYVAL pdispStringCollection AS IDispatch _         ' [in] *pdispStringCollection VT_DISPATCH <IDispatch>
                                 , BYVAL change AS LONG _                             ' [in] change WMPStringCollectionChangeEventType <enum>
                                 , BYVAL lCollectionIndex AS LONG _                   ' [in] lCollectionIndex VT_I4 <Long>
                                 )                                                    ' VOID
                              
                                   ' *** Insert your code here ***
                                   OutputDebugString FUNCNAME$
                              
                                 END METHOD
                                 ' =====================================================================================
                              
                                 ' =====================================================================================
                                 METHOD MediaCollectionMediaAdded <5825> ( _
                                   BYVAL pdispMedia AS IDispatch _                    ' [in] *pdispMedia VT_DISPATCH <IDispatch>
                                 )                                                    ' VOID
                              
                                   ' *** Insert your code here ***
                                   OutputDebugString FUNCNAME$
                              
                                 END METHOD
                                 ' =====================================================================================
                              
                                 ' =====================================================================================
                                 METHOD MediaCollectionMediaRemoved <5826> ( _
                                   BYVAL pdispMedia AS IDispatch _                    ' [in] *pdispMedia VT_DISPATCH <IDispatch>
                                 )                                                    ' VOID
                              
                                   ' *** Insert your code here ***
                                   OutputDebugString FUNCNAME$
                              
                                 END METHOD
                                 ' =====================================================================================
                              
                              END INTERFACE
                              
                              END CLASS
                              Attached Files
                              Forum: http://www.jose.it-berater.org/smfforum/index.php

                              Comment


                              • #16
                                Outlook View Control

                                Demonstrates how to embed an instance of the Microsoft Office Outlook View Control.

                                Code:
                                ' ########################################################################################
                                ' Demonstrates how to embed an instance of the Microsoft Office Outlook View Control
                                ' ########################################################################################
                                
                                #COMPILE EXE
                                #DIM ALL
                                %UNICODE = 1
                                %USEOLECON = 1
                                
                                #INCLUDE "CWindow.inc"            ' // CWindow class
                                #INCLUDE "olecon.inc"             ' // OLE Container
                                #INCLUDE "commctrl.inc"           ' // Common controls constants and declares
                                #INCLUDE "outlctl.inc"            ' // Microsoft View Control include file
                                #INCLUDE "ToolbarCtrl.inc"        ' // Toolbar wrapper functions
                                #INCLUDE "CAfxImageList.inc"      ' // Image List class
                                #RESOURCE RES, "EX_OVC_01.RES"    ' // Resource file
                                
                                ' Control identifiers
                                %IDC_TOOLBAR         = 1001
                                %IDC_OVC             = 1002
                                
                                %IDM_CALENDAR        = 28000
                                %IDM_CONTACTS        = 28001
                                %IDM_DELETED         = 28002
                                %IDM_DRAFTS          = 28003
                                %IDM_INBOX           = 28004
                                %IDM_NOTES           = 28005
                                %IDM_OUTBOX          = 28006
                                %IDM_SENT            = 28007
                                %IDM_TASKS           = 28009
                                
                                ' Icon identifiers
                                %IDI_CALENDAR        = 100
                                %IDI_CONTACTS        = 101
                                %IDI_DELETED         = 102
                                %IDI_DRAFTS          = 103
                                %IDI_INBOX           = 104
                                %IDI_JOURNAL         = 105
                                %IDI_NOTES           = 106
                                %IDI_OUTBOX          = 107
                                %IDI_OUTLOOK         = 108
                                %IDI_PERSONALFOLDERS = 109
                                %IDI_SENT            = 110
                                %IDI_TASKS           = 111
                                
                                ' ========================================================================================
                                ' Creates the toolbar
                                ' ========================================================================================
                                FUNCTION OvcCreateToolbar (BYVAL pWindow AS IWindow) AS DWORD
                                
                                   LOCAL hToolBar AS DWORD
                                   LOCAL cx, cy AS LONG
                                
                                   ' // Create the ToolBar Window.
                                   hToolBar = pWindow.AddToolBar(pWindow.hwnd, %IDC_TOOLBAR, "", 0, 0, 0, 0, _
                                              %WS_CHILD OR %WS_VISIBLE OR %TBSTYLE_TOOLTIPS OR %TBSTYLE_FLAT)
                                   ' // Set the extended style
                                   ToolBar_SetExtendedStyle hToolbar, %TBSTYLE_EX_DRAWDDARROWS
                                
                                   ' // Set the size of the bitmapped images
                                   ToolBar_SetBitmapSize(hToolbar, 24, 24)
                                
                                   ' // Add buttons to the toolbar
                                   Toolbar_AddButton hToolBar, 0, %IDM_CALENDAR
                                   Toolbar_AddButton hToolBar, 1, %IDM_CONTACTS
                                   Toolbar_AddButton hToolBar, 2, %IDM_DELETED
                                   Toolbar_AddButton hToolBar, 3, %IDM_DRAFTS
                                   Toolbar_AddButton hToolBar, 4, %IDM_INBOX
                                   Toolbar_AddButton hToolBar, 5, %IDM_NOTES
                                   Toolbar_AddButton hToolBar, 6, %IDM_OUTBOX
                                   Toolbar_AddButton hToolBar, 7, %IDM_SENT
                                   Toolbar_AddButton hToolBar, 8, %IDM_TASKS
                                
                                   ' // Update the size of the toolbar
                                   ToolBar_AutoSize(hToolbar)
                                
                                   ' // Create the image list
                                   LOCAL pAfxImageList AS IAfxImageList
                                   pAfxImageList = CLASS "CAfxImageList"
                                   IF ISNOTHING(pAfxImageList) THEN EXIT FUNCTION
                                
                                   ' // Desired icon size width and height
                                   cx = GetSystemMetrics(%SM_CXSMICON)
                                   cy = GetSystemMetrics(%SM_CYSMICON)
                                   ' // Create the image list
                                   pAfxImageList.CreateImageList(cx, cy, %ILC_COLOR32 OR %ILC_MASK, 9)
                                
                                   ' // Give a name to the image list
                                   pAfxImageList.Name = "Toolbar image list"
                                
                                   ' // Add the bitmaps from the resource file
                                   pAfxImageList.LoadResBitmapMasked(%IDI_CALENDAR, cx, cy)
                                   pAfxImageList.LoadResBitmapMasked(%IDI_CONTACTS, cx, cy)
                                   pAfxImageList.LoadResBitmapMasked(%IDI_DELETED, cx, cy)
                                   pAfxImageList.LoadResBitmapMasked(%IDI_DRAFTS, cx, cy)
                                   pAfxImageList.LoadResBitmapMasked(%IDI_INBOX, cx, cy)
                                   pAfxImageList.LoadResBitmapMasked(%IDI_NOTES, cx, cy)
                                   pAfxImageList.LoadResBitmapMasked(%IDI_OUTBOX, cx, cy)
                                   pAfxImageList.LoadResBitmapMasked(%IDI_SENT, cx, cy)
                                   pAfxImageList.LoadResBitmapMasked(%IDI_TASKS, cx, cy)
                                
                                   ' // Set the image list
                                   ToolBar_SetImageList(hToolbar, pAfxImageList.hImageList)
                                
                                   ' // Register the image list class in the collection
                                   pWindow.AddObject "Toolbar image list", pAfxImageList
                                
                                   ' // Return the handle of the toolbar
                                   FUNCTION = hToolbar
                                
                                END FUNCTION
                                ' ========================================================================================
                                
                                ' ========================================================================================
                                ' Main
                                ' ========================================================================================
                                FUNCTION WinMain (BYVAL hInstance AS DWORD, BYVAL hPrevInstance AS DWORD, BYVAL lpszCmdLine AS WSTRINGZ PTR, BYVAL nCmdShow AS LONG) AS LONG
                                
                                   ' // Set process DPI aware
                                   IF AfxGetWindowsVersion => 6.00 THEN SetProcessDPIAware
                                
                                   ' // Create an instance of the class
                                   LOCAL pWindow AS IWindow
                                   pWindow = CLASS "CWindow"
                                   IF ISNOTHING(pWindow) THEN EXIT FUNCTION
                                
                                   ' // Create the main window
                                   pWindow.CreateWindow(%NULL, "Microsoft Outlook View Control Demo", 0, 0, 0, 0, 0, 0, CODEPTR(WindowProc))
                                   ' // Disable background erasing
                                   pWindow.ClassStyle = %CS_DBLCLKS
                                   ' // Set the client siz
                                   pWindow.SetClientSize 600, 350
                                   ' // Center the window
                                   pWindow.CenterWindow
                                
                                   ' // Create the View Control window container
                                   LOCAL hCtl AS DWORD
                                   hCtl = pWindow.AddOCX(pWindow.hwnd, %IDC_OVC, "OVCtl.OVCtl", "", 0, 0, 0, 0)
                                   ' // Get a reference to the control
                                   LOCAL pOvc AS OVCtl_IViewCtl
                                   pOvc = OC_GetDispatch(hCtl)
                                   IF ISOBJECT(pOvc) THEN
                                      ' // Choose the Calendar view
                                      pOvc.Folder = "Inbox"
                                      ' // Release the reference
                                      pOvc = NOTHING
                                   END IF
                                
                                   ' // Add the toolbar
                                   OvcCreateToolBar pWindow
                                
                                   ' // Default message pump (you can replace it with your own)
                                   pWindow.DoEvents(nCmdShow)
                                
                                END FUNCTION
                                ' ========================================================================================
                                
                                ' ========================================================================================
                                ' Main callback function.
                                ' ========================================================================================
                                FUNCTION WindowProc (BYVAL hwnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG
                                
                                   LOCAL  hCtl       AS DWORD
                                   LOCAL  rc         AS RECT
                                   LOCAL  pOvc       AS OVCtl_IViewCtl
                                   LOCAL  pTOOLTIP   AS TOOLTIPTEXT PTR
                                   LOCAL  lpNmh      AS NMHDR  PTR
                                   STATIC pWindow    AS IWindow        ' // Reference to the IWindow interface
                                   STATIC wszTipText AS WSTRINGZ * 64
                                
                                   ' // Process window mesages
                                   SELECT CASE uMsg
                                
                                      CASE %WM_CREATE
                                         ' // Get a reference to the IWindow interface from the CREATESTRUCT structure
                                         pWindow = CWindow_GetObjectFromCreateStruct(lParam)
                                         EXIT FUNCTION
                                
                                      CASE %WM_SYSCOMMAND
                                        ' Capture this message and send a %WM_CLOSE message
                                        IF (wParam AND &HFFF0) = %SC_CLOSE THEN
                                           SendMessage hWnd, %WM_CLOSE, 0, 0
                                           EXIT FUNCTION
                                        END IF
                                
                                      CASE %WM_COMMAND
                                
                                         SELECT CASE LO(WORD, wParam)
                                
                                            CASE %IDCANCEL
                                               ' // If the Escape key has been pressed...
                                               IF HI(WORD, wParam) = %BN_CLICKED THEN
                                                  ' // ... close the application by sending a WM_CLOSE message
                                                  SendMessage hwnd, %WM_CLOSE, 0, 0
                                                  EXIT FUNCTION
                                               END IF
                                
                                            CASE %IDM_CALENDAR, %IDM_CONTACTS, %IDM_DRAFTS, %IDM_DELETED, %IDM_INBOX, _
                                                 %IDM_NOTES, %IDM_OUTBOX, %IDM_SENT, %IDM_TASKS
                                               IF HI(WORD, wParam) = %BN_CLICKED THEN
                                                  hCtl = GetDlgItem(hwnd, %IDC_OVC)
                                                  pOvc = OC_GetDispatch(hCtl)
                                                  IF ISOBJECT(pOvc) THEN
                                                     ' Choose the view
                                                     SELECT CASE LO(WORD, wParam)
                                                        CASE %IDM_CALENDAR : pOvc.Folder = "Calendar"
                                                        CASE %IDM_CONTACTS : pOvc.Folder = "Contacts"
                                                        CASE %IDM_DRAFTS   : pOvc.Folder = "Drafts"
                                                        CASE %IDM_DELETED  : pOvc.Folder = "Deleted Items"
                                                        CASE %IDM_INBOX    : pOvc.Folder = "Inbox"
                                                        CASE %IDM_NOTES    : pOvc.Folder = "Notes"
                                                        CASE %IDM_OUTBOX   : pOvc.Folder = "Outbox"
                                                        CASE %IDM_SENT     : pOvc.Folder = "Sent Items"
                                                        CASE %IDM_TASKS    : pOvc.Folder = "Tasks"
                                                     END SELECT
                                                     ' Release the reference
                                                     pOvc = NOTHING
                                                  END IF
                                                  EXIT FUNCTION
                                               END IF
                                
                                         END SELECT
                                
                                      CASE %WM_NOTIFY
                                         lpNmh = lParam
                                         SELECT CASE @lpNmh.Code
                                         CASE %TTN_NEEDTEXT ' ToolTips
                                            pTOOLTIP = lParam
                                            wszTipText = ""
                                            IF @pTOOLTIP.hdr.code = %TTN_NEEDTEXT THEN
                                               SELECT CASE @pTOOLTIP.hdr.idFrom
                                                  CASE %IDM_CALENDAR : wszTipText = " Calendar "
                                                  CASE %IDM_CONTACTS : wszTipText = " Contacts "
                                                  CASE %IDM_DELETED  : wszTipText = " Deleted Items "
                                                  CASE %IDM_DRAFTS   : wszTipText = " Drafts "
                                                  CASE %IDM_INBOX    : wszTipText = " Inbox "
                                                  CASE %IDM_NOTES    : wszTipText = " Notes "
                                                  CASE %IDM_OUTBOX   : wszTipText = " Outbox "
                                                  CASE %IDM_SENT     : wszTipText = " Sent Items "
                                                  CASE %IDM_TASKS    : wszTipText = " Tasks "
                                               END SELECT
                                               IF wszTipText <> "" THEN
                                                  @pTOOLTIP.lpszText = VARPTR(wszTipText)
                                                  EXIT FUNCTION
                                               END IF
                                            END IF
                                         END SELECT
                                
                                      CASE %WM_SIZE
                                         ' // If the window isn't minimized, resize it
                                         IF wParam <> %SIZE_MINIMIZED THEN
                                            ' // Resize the toolbar
                                            LOCAL hToolBar AS DWORD
                                            hToolBar = GetDlgItem(hwnd, %IDC_TOOLBAR)
                                            SendMessage hToolBar, uMsg, wParam, lParam
                                            ' // Calculate the size of the toolbar
                                            LOCAL ToolBarHeight AS DWORD
                                            pWindow.GetControlWindowRect hToolbar, rc
                                            ToolBarHeight = rc.Bottom - rc.Top
                                            ' // Resize the outlook view control
                                            pWindow.MoveWindow GetDlgItem(hwnd, %IDC_OVC), 0, ToolBarHeight, pWindow.ClientWidth, pWindow.ClientHeight - ToolBarHeight, %TRUE
                                         END IF
                                
                                      CASE %WM_DESTROY
                                         ' // End the application
                                         PostQuitMessage 0
                                         EXIT FUNCTION
                                
                                   END SELECT
                                
                                   ' // Pass unprocessed messages to Windows
                                   FUNCTION = DefWindowProc(hwnd, uMsg, wParam, lParam)
                                
                                END FUNCTION
                                ' ========================================================================================
                                Attached Files
                                Forum: http://www.jose.it-berater.org/smfforum/index.php

                                Comment

                                Working...
                                X