Drag and Drop Symbol in Visio Sheet

Hello Everyone

I am using following VBA Code to Drop Symbols into Visio Sheet with Device Association.
I got this Drop Symbol Function VBA Code from Aucotec VBA Training Manual.
The Drop Symbol Function Code is working fine.
My only problem with this code it is taking about 7 seconds to 8 seconds to execute following line code in this Drop Symbol Function
Call Utils.ExecuteSheetOperation(moObj, atParamData)is

This Call Utils.ExecuteSheetOperation(moObj, atParamData) line of VBA Code takes about 7 to 8 seconds for [u]each Shape[/u]

In my Active Project I have more than 1000 - 2000 Shapes to be dropped into different Visio Sheets (Under the Documents)
On an average each Visio Sheet I have about 240-300 shapes
So just imagine if I have to execute this line VBA Code Call Utils.ExecuteSheetOperation(moObj, atParamData)[/i for 240-300 shapes in each sheet. It will take about 240-300 shapes multiplied by approximate 7.5 seconds. It will take about 30 mins (approximate) for each Sheet.

30 mins for each Visio Sheets which is very very long time.
My questions to Aucotec Tech Support. Is there any alternative solution for me to reduce my time
If I can reduce my time to drop each shape through macro. It will be very very help for our business.all

At present users are dragging all the shapes manually into Visio Sheets. Only thing they do different in comparison to my macro. Users selects all the shapes one time under Equipment -->> Devices before dragging into Visio Sheet.

I will appreciate for your response.......

Here is my VBA Code
[i]Private Function Drop_Symbol_Into_Visio_Documnet_From_Name(oSheet As Sheet, CloseAfterDrop As Boolean, oStencil As ObjectItem, sSymbolname As String, _
WithObject As Boolean, x As Double, y As Double, Optional oDevice As ObjectItem, Optional Scalefactor As Single)
' oSheet: sheet for dropping the symbol
' oStencil: Stencil Name
' CloseAfterDrop: Close sheet at the end of function Y/N
' sSymbolname: Name of the symbol
' WithObject: Associate oDevice Y/N
' X,Y: Coordinates in mm
' oDevice: optional device for association
' Scalefactor: optional for Scaling

Dim oMaster As ObjectItem
Dim sMasterUniRef As String
Dim sMasterU As String
Dim moObj As ObjectItem 'Sheet as parameter must be ObjectItem
Dim atParamData() As Aucotec.AucExecuteSheetRecord
Dim StartTime1 As Double
Dim StartTime2 As Double
Dim SecondsElapsed1 As Double
Dim SecondsElapsed2 As Double

Dim oVisio As Visio.Application
Dim vsoPage As Visio.Page

StartTime1 = 0
StartTime1 = Timer

For Each oMaster In oStencil.Children
If oMaster.Name = sSymbolname Then
sMasterU = oMaster.Attributes.ItemByID(aucAttrSymbolSyncDesignation).Value
Exit For
End If
Next oMaster

If sMasterU = "" Then
'MsgBox "Symbol " & sSymbolname & " not found on stencil"
Exit Function
End If

sMasterUniRef = oStencil.ID & "#" & sMasterU

'***Check if Visio Sheet is Opened or Not. If Not Open. Open it***********************
If Not oSheet.IsOpened Then Call oSheet.Open(aucSheetOpenAutosave + aucSheetOpenVisio)
'^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^

Set moObj = oSheet 'for Utils must be ObjectItem

'***'Check Drop Area (new with version 6.0)***************************************************
ReDim atParamData(1 To 5)
atParamData(1).qual = aucOpExecSheetCheckDropArea
atParamData(2).qual = aucArgExecSheetRef2Master
atParamData(2).Val = sMasterUniRef
atParamData(3).qual = aucArgExecSheetPosX
atParamData(3).Val = x
atParamData(4).qual = aucArgExecSheetPosY
atParamData(4).Val = y
atParamData(5).qual = aucArgExecSheetRetVal

Call Utils.ExecuteSheetOperation(moObj, atParamData)

If atParamData(5).Val = 1 Then
'***On Hold***MsgBox "Shape " & sSymbolname & " in conflict with other shapes/connections"
End If
'^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^

'***Object Association***********************************************************************
ReDim atParamData(1 To 4)
atParamData(1).qual = aucOpExecSheetDropSymbol
atParamData(2).qual = aucArgExecSheetRef2Master
atParamData(2).Val = sMasterUniRef
atParamData(3).qual = aucArgExecSheetPosX
atParamData(3).Val = x + 189
atParamData(4).qual = aucArgExecSheetPosY
atParamData(4).Val = y

If WithObject Then
ReDim Preserve atParamData(1 To 5)
atParamData(5).qual = aucArgExecSheetRef2Obj
atParamData(5).Val = oDevice.ID
End If
'^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^

'***Debug*****************
StartTime2 = 0
StartTime2 = Timer
'^^^^^^^^^^^^^^^^^^^^^^^^^^
'***Drop Shape in Visio Sheet************************
Call Utils.ExecuteSheetOperation(moObj, atParamData)
'^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^

'***Debug*****************
SecondsElapsed2 = 0
SecondsElapsed2 = Round(Timer - StartTime2, 4)
'^^^^^^^^^^^^^^^^^^^^^^^^^^

'***Close Visio Sheet After Symbol Drop***********************
If CloseAfterDrop = True Then oSheet.Close
'^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^

End Function