calcvba: #164410# improve VBA compatibility implementation in various areas: Excel symbols, MSForms symbols, document and forms event handling

3 files changed, 133 insertions, 60 deletions

diff --git a/basic/source/classes/sb.cxx b/basic/source/classes/sb.cxx
index f8ffa46d48a5..bf7b00e2a633 100644
--- a/basic/source/classes/sb.cxx
+++ b/basic/source/classes/sb.cxx
@@ -42,6 +42,7 @@
 #include <tools/shl.hxx>
 #include <tools/rc.hxx>
 #include <vcl/svapp.hxx>
+#include <comphelper/processfactory.hxx>
 #include "sbunoobj.hxx"
 #include "sbjsmeth.hxx"
 #include "sbjsmod.hxx"
@@ -136,6 +137,7 @@ void DocBasicItem::startListening()
     Any aThisComp;
     mrDocBasic.GetUNOConstant( "ThisComponent", aThisComp );
     Reference< util::XCloseBroadcaster > xCloseBC( aThisComp, UNO_QUERY );
+    mbDisposed = !xCloseBC.is();
     if( xCloseBC.is() )
         try { xCloseBC->addCloseListener( this ); } catch( uno::Exception& ) {}
 }
@@ -437,7 +439,20 @@ SbxObject* SbiFactory::CreateObject( const String& rClass )
         return new BasicCollection( aCollectionName );
     }
     else
-        return NULL;
+    if( rClass.EqualsIgnoreCaseAscii( "FileSystemObject" ) )
+    {
+        try
+        {
+            Reference< XMultiServiceFactory > xFactory( comphelper::getProcessServiceFactory(), UNO_SET_THROW );
+            ::rtl::OUString aServiceName( RTL_CONSTASCII_USTRINGPARAM( "ooo.vba.FileSystemObject" ) );
+            Reference< XInterface > xInterface( xFactory->createInstance( aServiceName ), UNO_SET_THROW );
+            return new SbUnoObject( aServiceName, uno::makeAny( xInterface ) );
+        }
+        catch( Exception& )
+        {}
+    }
+
+    return NULL;
 }
 
 
@@ -934,8 +949,14 @@ void StarBASIC::SetModified( sal_Bool b )
     SbxBase::SetModified( b );
 }
 
+extern void lcl_closeTraceFile();
+
 StarBASIC::~StarBASIC()
 {
+#ifdef DBG_TRACE_BASIC
+    lcl_closeTraceFile();
+#endif
+
     // Needs to be first action as it can trigger events
     disposeComVariablesForBasic( this );
 
@@ -2273,7 +2294,22 @@ void BasicCollection::CollRemove( SbxArray* pPar_ )
     SbxVariable* p = pPar_->Get( 1 );
     sal_Int32 nIndex = implGetIndex( p );
     if( nIndex >= 0 && nIndex < (sal_Int32)xItemArray->Count32() )
+    {
         xItemArray->Remove32( nIndex );
+
+        // Correct for stack if necessary
+        SbiInstance* pInst = pINST;
+        SbiRuntime* pRT = pInst ? pInst->pRun : NULL;
+        if( pRT )
+        {
+            SbiForStack* pStack = pRT->FindForStackItemForCollection( this );
+            if( pStack != NULL )
+            {
+                if( pStack->nCurCollectionIndex >= nIndex )
+                    --pStack->nCurCollectionIndex;
+            }
+        }
+    }
     else
         SetError( SbERR_BAD_ARGUMENT );
 }
diff --git a/basic/source/classes/sbunoobj.cxx b/basic/source/classes/sbunoobj.cxx
index 13ae406cb305..6f20a68a274f 100755
--- a/basic/source/classes/sbunoobj.cxx
+++ b/basic/source/classes/sbunoobj.cxx
@@ -1722,8 +1722,7 @@ String getBasicObjectTypeName( SbxObject* pObj )
     return aName;
 }
 
-bool checkUnoObjectType( SbUnoObject* pUnoObj,
-    const String& aClass )
+bool checkUnoObjectType( SbUnoObject* pUnoObj, const ::rtl::OUString& rClass )
 {
     Any aToInspectObj = pUnoObj->getUnoAny();
     TypeClass eType = aToInspectObj.getValueType().getTypeClass();
@@ -1740,6 +1739,21 @@ bool checkUnoObjectType( SbUnoObject* pUnoObj,
     Reference< XTypeProvider > xTypeProvider( x, UNO_QUERY );
     if( xTypeProvider.is() )
     {
+        /*  Although interfaces in the ooo.vba namespace obey the IDL rules and
+            have a leading 'X', in Basic we want to be able to do something
+            like 'Dim wb As Workbooks' or 'Dim lb As MSForms.Label'. Here we
+            add a leading 'X' to the class name and a leading dot to the entire
+            type name. This results e.g. in '.XWorkbooks' or '.MSForms.XLabel'
+            which matches the interface names 'ooo.vba.excel.XWorkbooks' or
+            'ooo.vba.msforms.XLabel'.
+         */
+        ::rtl::OUString aClassName( sal_Unicode( '.' ) );
+        sal_Int32 nClassNameDot = rClass.lastIndexOf( '.' );
+        if( nClassNameDot >= 0 )
+            aClassName += rClass.copy( 0, nClassNameDot + 1 ) + ::rtl::OUString( sal_Unicode( 'X' ) ) + rClass.copy( nClassNameDot + 1 );
+        else
+            aClassName += ::rtl::OUString( sal_Unicode( 'X' ) ) + rClass;
+
         Sequence< Type > aTypeSeq = xTypeProvider->getTypes();
         const Type* pTypeArray = aTypeSeq.getConstArray();
         sal_uInt32 nIfaceCount = aTypeSeq.getLength();
@@ -1753,8 +1767,8 @@ bool checkUnoObjectType( SbUnoObject* pUnoObj,
                 DBG_ERROR("failed to get XIdlClass for type");
                 break;
             }
-            ::rtl::OUString sClassName = xClass->getName();
-            if ( sClassName.equals( rtl::OUString( RTL_CONSTASCII_USTRINGPARAM("com.sun.star.bridge.oleautomation.XAutomationObject" ) ) ) )
+            ::rtl::OUString aInterfaceName = xClass->getName();
+            if ( aInterfaceName.equals( rtl::OUString( RTL_CONSTASCII_USTRINGPARAM("com.sun.star.bridge.oleautomation.XAutomationObject" ) ) ) )
             {
                 // there is a hack in the extensions/source/ole/oleobj.cxx  to return the typename of the automation object, lets check if it
                 // matches
@@ -1767,20 +1781,15 @@ bool checkUnoObjectType( SbUnoObject* pUnoObj,
                         // can't check type, leave it pass
                         result = true;
                     else
-                        result = sTypeName.equals( aClass );
+                        result = sTypeName.equals( rClass );
                 }
                 break; // finished checking automation object
             }
-            OSL_TRACE("Checking if object implements %s",
-                OUStringToOString( defaultNameSpace + aClass,
-                    RTL_TEXTENCODING_UTF8 ).getStr() );
-            // although interfaces in the ooo.vba.vba namespace
-            // obey the idl rules and have a leading X, in basic we
-            // want to be able to do something like
-            // 'dim wrkbooks as WorkBooks'
-            // so test assumes the 'X' has been dropped
-            sal_Int32 indexLastDot = sClassName.lastIndexOf('.');
-            if ( indexLastDot > -1 && sClassName.copy( indexLastDot + 1).equalsIgnoreAsciiCase( ::rtl::OUString( RTL_CONSTASCII_USTRINGPARAM("X") ) + aClass ) )
+
+            // match interface name with passed class name
+            OSL_TRACE("Checking if object implements %s", OUStringToOString( aClassName, RTL_TEXTENCODING_UTF8 ).getStr() );
+            if ( (aClassName.getLength() < aInterfaceName.getLength()) &&
+                    aInterfaceName.matchIgnoreAsciiCase( aClassName, aInterfaceName.getLength() - aClassName.getLength() ) )
             {
                 result = true;
                 break;
diff --git a/basic/source/classes/sbxmod.cxx b/basic/source/classes/sbxmod.cxx
index c722e680fd8c..24b031e8f4e9 100644
--- a/basic/source/classes/sbxmod.cxx
+++ b/basic/source/classes/sbxmod.cxx
@@ -61,6 +61,7 @@
 #include <com/sun/star/lang/XServiceInfo.hpp>
 #include <com/sun/star/script/ModuleType.hpp>
 #include <com/sun/star/script/vba/XVBACompatibility.hpp>
+#include <com/sun/star/script/vba/VBAScriptEventId.hpp>
 #include <com/sun/star/beans/XPropertySet.hpp>
 #include <com/sun/star/document/XEventBroadcaster.hpp>
 #include <com/sun/star/document/XEventListener.hpp>
@@ -88,10 +89,8 @@ using namespace com::sun::star;
 #include <cppuhelper/implbase1.hxx>
 #include <basic/sbobjmod.hxx>
 #include <com/sun/star/uno/XAggregation.hpp>
-#include <map>
 #include <com/sun/star/script/XInvocation.hpp>
 
- using namespace ::com::sun::star;
 using namespace com::sun::star::lang;
 using namespace com::sun::star::reflection;
 using namespace com::sun::star::beans;
@@ -107,6 +106,7 @@ using namespace com::sun::star::script;
 #include <cppuhelper/implbase1.hxx>
 #include <comphelper/anytostring.hxx>
 #include <com/sun/star/beans/XPropertySet.hpp>
+#include <ooo/vba/VbQueryClose.hpp>
 
 typedef ::cppu::WeakImplHelper1< XInvocation > DocObjectWrapper_BASE;
 typedef ::std::map< sal_Int16, Any, ::std::less< sal_Int16 > > OutParamMap;
@@ -451,24 +451,36 @@ TYPEINIT1(SbUserFormModule,SbObjModule)
 
 typedef std::vector<HighlightPortion> HighlightPortions;
 
-bool getDefaultVBAMode( StarBASIC* pb )
+uno::Reference< frame::XModel > getDocumentModel( StarBASIC* pb )
 {
-    bool bResult = false;
-    if ( pb && pb->IsDocBasic() )
+    uno::Reference< frame::XModel > xModel;
+    if( pb && pb->IsDocBasic() )
     {
         uno::Any aDoc;
-    if ( pb->GetUNOConstant( "ThisComponent", aDoc ) )
-        {
-            uno::Reference< beans::XPropertySet > xProp( aDoc, uno::UNO_QUERY );
-            if ( xProp.is() )
-            {
-                uno::Reference< script::vba::XVBACompatibility > xVBAMode( xProp->getPropertyValue( rtl::OUString( RTL_CONSTASCII_USTRINGPARAM("BasicLibraries") ) ), uno::UNO_QUERY );
-                if ( xVBAMode.is() )
-                    bResult = xVBAMode->getVBACompatibilityMode() == sal_True;
-            }
-        }
+        if( pb->GetUNOConstant( "ThisComponent", aDoc ) )
+            xModel.set( aDoc, uno::UNO_QUERY );
     }
-    return bResult;
+    return xModel;
+}
+
+uno::Reference< vba::XVBACompatibility > getVBACompatibility( const uno::Reference< frame::XModel >& rxModel )
+{
+    uno::Reference< vba::XVBACompatibility > xVBACompat;
+    try
+    {
+        uno::Reference< beans::XPropertySet > xModelProps( rxModel, uno::UNO_QUERY_THROW );
+        xVBACompat.set( xModelProps->getPropertyValue( ::rtl::OUString( RTL_CONSTASCII_USTRINGPARAM( "BasicLibraries" ) ) ), uno::UNO_QUERY );
+    }
+    catch( uno::Exception& )
+    {
+    }
+    return xVBACompat;
+}
+
+bool getDefaultVBAMode( StarBASIC* pb )
+{
+    uno::Reference< vba::XVBACompatibility > xVBACompat = getVBACompatibility( getDocumentModel( pb ) );
+    return xVBACompat.is() && xVBACompat->getVBACompatibilityMode();
 }
 
 class AsyncQuitHandler
@@ -501,20 +513,6 @@ IMPL_LINK( AsyncQuitHandler, OnAsyncQuit, void*, /*pNull*/ )
     return 0L;
 }
 
-void VBAUnlockDocuments( StarBASIC* pBasic )
-{
-    if ( pBasic && pBasic->IsDocBasic() )
-    {
-        SbUnoObject* pGlobs = dynamic_cast< SbUnoObject* >( pBasic->Find( ::rtl::OUString( RTL_CONSTASCII_USTRINGPARAM( "ThisComponent" ) ), SbxCLASS_DONTCARE ) );
-        if ( pGlobs )
-        {
-            uno::Reference< frame::XModel > xModel( pGlobs->getUnoAny(), uno::UNO_QUERY );
-            ::basic::vba::lockControllersOfAllDocuments( xModel, sal_False );
-            ::basic::vba::enableContainerWindowsOfAllDocuments( xModel, sal_True );
-        }
-    }
-}
-
 /////////////////////////////////////////////////////////////////////////////
 
 // Ein BASIC-Modul hat EXTSEARCH gesetzt, damit die im Modul enthaltenen
@@ -833,7 +831,7 @@ void SbModule::SetSource( const String& r )
 void SbModule::SetSource32( const ::rtl::OUString& r )
 {
     // Default basic mode to library container mode, but.. allow Option VBASupport 0/1 override
-        SetVBACompat( getDefaultVBAMode( static_cast< StarBASIC*>( GetParent() ) ) );
+    SetVBACompat( getDefaultVBAMode( static_cast< StarBASIC*>( GetParent() ) ) );
     aOUSource = r;
     StartDefinitions();
     SbiTokenizer aTok( r );
@@ -1031,6 +1029,8 @@ sal_uInt16 SbModule::Run( SbMethod* pMeth )
     sal_uInt16 nRes = 0;
     sal_Bool bDelInst = sal_Bool( pINST == NULL );
     StarBASICRef xBasic;
+    uno::Reference< frame::XModel > xModel;
+    uno::Reference< script::vba::XVBACompatibility > xVBACompat;
     if( bDelInst )
     {
 #ifdef DBG_TRACE_BASIC
@@ -1041,6 +1041,23 @@ sal_uInt16 SbModule::Run( SbMethod* pMeth )
 
         pINST = new SbiInstance( (StarBASIC*) GetParent() );
 
+        /*  If a VBA script in a document is started, get the VBA compatibility
+            interface from the document Basic library container, and notify all
+            VBA script listeners about the started script. */
+        if( mbVBACompat )
+        {
+            StarBASIC* pBasic = static_cast< StarBASIC* >( GetParent() );
+            if( pBasic && pBasic->IsDocBasic() ) try
+            {
+                xModel.set( getDocumentModel( pBasic ), uno::UNO_SET_THROW );
+                xVBACompat.set( getVBACompatibility( xModel ), uno::UNO_SET_THROW );
+                xVBACompat->broadcastVBAScriptEvent( script::vba::VBAScriptEventId::SCRIPT_STARTED, GetName() );
+            }
+            catch( uno::Exception& )
+            {
+            }
+        }
+
         // Launcher problem
         // i80726 The Find below will genarate an error in Testtool so we reset it unless there was one before already
         sal_Bool bWasError = SbxBase::GetError() != 0;
@@ -1183,9 +1200,20 @@ sal_uInt16 SbModule::Run( SbMethod* pMeth )
                 ResetCapturedAssertions();
 #endif
 
-                // VBA always ensures screenupdating is enabled after completing
-                if ( mbVBACompat )
-                    VBAUnlockDocuments( PTR_CAST( StarBASIC, GetParent() ) );
+                if( xVBACompat.is() )
+                {
+                    // notify all VBA script listeners about the stopped script
+                    try
+                    {
+                        xVBACompat->broadcastVBAScriptEvent( script::vba::VBAScriptEventId::SCRIPT_STOPPED, GetName() );
+                    }
+                    catch( uno::Exception& )
+                    {
+                    }
+                    // VBA always ensures screenupdating is enabled after completing
+                    ::basic::vba::lockControllersOfAllDocuments( xModel, sal_False );
+                    ::basic::vba::enableContainerWindowsOfAllDocuments( xModel, sal_True );
+                }
 
 #ifdef DBG_TRACE_BASIC
                 dbg_DeInitTrace();
@@ -2276,8 +2304,9 @@ public:
                 uno::Reference< document::XVbaMethodParameter > xVbaMethodParameter( xControl->getPeer(), uno::UNO_QUERY );
                 if ( xVbaMethodParameter.is() )
                 {
+#endif
                     sal_Int8 nCancel = 0;
-                    sal_Int8 nCloseMode = 0;
+                    sal_Int8 nCloseMode = ::ooo::vba::VbQueryClose::vbFormControlMenu;
 
                     Sequence< Any > aParams;
                     aParams.realloc(2);
@@ -2286,14 +2315,13 @@ public:
 
                     mpUserForm->triggerMethod( rtl::OUString(RTL_CONSTASCII_USTRINGPARAM("Userform_QueryClose") ),
                                                 aParams);
+#if IN_THE_FUTURE
                     xVbaMethodParameter->setVbaMethodParameter( rtl::OUString( RTL_CONSTASCII_USTRINGPARAM("Cancel")), aParams[0]);
                     return;
 
                 }
             }
         }
-
-        mpUserForm->triggerMethod( rtl::OUString(RTL_CONSTASCII_USTRINGPARAM("Userform_QueryClose") ) );
 #endif
     }
     //liuchen 2009-7-21
@@ -2403,15 +2431,14 @@ void SbUserFormModule::triggerMethod( const String& aMethodToRun )
     Sequence< Any > aArguments;
     triggerMethod( aMethodToRun, aArguments );
 }
-void SbUserFormModule::triggerMethod( const String& aMethodToRun, Sequence< Any >& /*aArguments*/)
+
+void SbUserFormModule::triggerMethod( const String& aMethodToRun, Sequence< Any >& aArguments )
 {
     OSL_TRACE("*** trigger %s ***", rtl::OUStringToOString( aMethodToRun, RTL_TEXTENCODING_UTF8 ).getStr() );
     // Search method
     SbxVariable* pMeth = SbObjModule::Find( aMethodToRun, SbxCLASS_METHOD );
     if( pMeth )
     {
-#if IN_THE_FUTURE
-                 //liuchen 2009-7-21, support Excel VBA UserForm_QueryClose event with parameters
         if ( aArguments.getLength() > 0 )   // Setup parameters
         {
             SbxArrayRef xArray = new SbxArray;
@@ -2439,8 +2466,6 @@ void SbUserFormModule::triggerMethod( const String& aMethodToRun, Sequence< Any
             pMeth->SetParameters( NULL );
         }
         else
-//liuchen 2009-7-21
-#endif
         {
             SbxValues aVals;
             pMeth->Get( aVals );
@@ -2532,7 +2557,7 @@ void SbUserFormModule::Unload()
     OSL_TRACE("** Unload() ");
 
     sal_Int8 nCancel = 0;
-    sal_Int8 nCloseMode = 1;
+    sal_Int8 nCloseMode = ::ooo::vba::VbQueryClose::vbFormCode;
 
     Sequence< Any > aParams;
     aParams.realloc(2);
@@ -2542,7 +2567,7 @@ void SbUserFormModule::Unload()
     triggerMethod( rtl::OUString(RTL_CONSTASCII_USTRINGPARAM("Userform_QueryClose") ), aParams);
 
     aParams[0] >>= nCancel;
-    if (nCancel == 1)
+    if (nCancel != 0)  // Basic returns -1 for "True"
     {
         return;
     }
@@ -2585,6 +2610,9 @@ void SbUserFormModule::InitObject()
         SbUnoObject* pGlobs = (SbUnoObject*)GetParent()->Find( aHook, SbxCLASS_DONTCARE );
         if ( m_xModel.is() && pGlobs )
         {
+            // broadcast INITIALIZE_USERFORM script event before the dialog is created
+            Reference< script::vba::XVBACompatibility > xVBACompat( getVBACompatibility( m_xModel ), uno::UNO_SET_THROW );
+            xVBACompat->broadcastVBAScriptEvent( script::vba::VBAScriptEventId::INITIALIZE_USERFORM, GetName() );
 
             uno::Reference< lang::XMultiServiceFactory > xVBAFactory( pGlobs->getUnoAny(), uno::UNO_QUERY_THROW );
             uno::Reference< lang::XMultiServiceFactory > xFactory = comphelper::getProcessServiceFactory();