Announcement

Collapse

Forum Guidelines

This forum is for finished source code that is working properly. If you have questions about this or any other source code, please post it in one of the Discussion Forums, not here.
See more
See less

Modify a Excel Variant Array with a PBWin 7.02 dll

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

  • Modify a Excel Variant Array with a PBWin 7.02 dll

    Code:
    'Demonstration of modifying excel data with a pb dll using a
    'variant no paren array
    'Useful up to 100k cells, larger than that is very slow
    'Requires pbwin7.02
    #COMPILE DLL "ModvArry.dll"
    #DIM ALL
    FUNCTION ModvArray ALIAS "ModvArray" (vArrayNoParen AS VARIANT,vDllStartTime AS VARIANT) EXPORT AS STRING
    
       DIM dDllStartTime AS DOUBLE
       LET dDllStartTime = VARIANT#(vDllStartTime)
    
       DIM sReturnInfo AS STRING
       sReturnInfo = " dll crankup time " &  FORMAT$(TIMER - dDllStartTime,"000.00") & $CRLF
    
       IF VARIANTVT(vArrayNoParen) = 0 OR VARIANTVT(vArrayNoParen) = 1 THEN
          MSGBOX "nothing in vInArray"
          FUNCTION = "Error"
          EXIT FUNCTION
       END IF
    
       DIM i AS LONG
       DIM j AS LONG
       DIM vArray2Dim(0) AS VARIANT
       LET vArray2Dim() = vArrayNoParen
       DIM ubrows AS LONG
       DIM ubcols AS LONG
    
       ubrows = UBOUND(vArray2Dim(),1)
       ubcols = UBOUND(vArray2Dim(),2)
       IF ubrows = 0 OR ubcols = 0 OR ubrows = -1 OR ubcols = -1 THEN
           MSGBOX "InArray has no dimensions"
           FUNCTION = "Error"
           EXIT FUNCTION
       END IF
       sReturnInfo =  sReturnInfo & " dll up to mod array " &  FORMAT$(TIMER - dDllStartTime,"000.00") & $CRLF
    
       DIM vtype AS LONG
       FOR j = 1 TO ubcols
          FOR i = 1 TO ubrows
             vtype = VARIANTVT(vArray2Dim(i,j))
             IF vtype = 0  OR  vtype = 1 THEN ' nothing or null
                vArray2Dim(i,j) = "was a blank" & STR$(i) & STR$(j)
             ELSEIF vtype = 8 THEN 'string
                vArray2Dim(i,j) = "string " & VARIANT$(vArray2Dim(i, j))
             ELSEIF vtype => 2 AND vtype <= 6 THEN
                vArray2Dim(i,j) = VARIANT#(vArray2Dim(i, j)) + 100
             END IF
           NEXT i
       NEXT j
       sReturnInfo =  sReturnInfo & " dll past mod array " &  FORMAT$(TIMER - dDllStartTime,"000.00") & $CRLF
    
       LET vArrayNoParen = vArray2Dim()
       sReturnInfo =  sReturnInfo & " dll past assign " &  FORMAT$(TIMER - dDllStartTime,"000.00")
    
       FUNCTION = sReturnInfo
    END FUNCTION
    
    
    'ModvArry.xls
    Attribute VB_Name = "Module1"
    Declare Function ModvArray Lib "ModvArry.dll" (vArrayNoParen As Variant, vDllStartTime As Variant) As String
    Option Explicit
    
    Sub StartTest()
      
      Dim Stime As Variant
      Stime = Timer
      Call Test
      Debug.Print "after function return " & Timer - Stime
      End
       
    End Sub
    
    Function Test()
      Dim Stime As Variant
      Stime = Timer
      
      Dim vArrayNoParen As Variant
      
      Dim lRows As Variant
      Dim lCols As Variant
      Dim oRange As Range
      Dim ubrows As Variant
      Dim ubcols As Variant
      Dim SheetName As Variant
      Dim vDllStartTime As Variant
      Dim vPutInCellsStartTime As Variant
      Dim SReturnValue As String
    
      'much larger than 100k cells and it slows down tremendously
      lRows = 30000
      lCols = 3
      SheetName = "Sheet1"
      
      ChDrive ThisWorkbook.Path
      ChDir ThisWorkbook.Path
      
      ThisWorkbook.Worksheets(SheetName).Activate
      Range(Cells(1, 1), Cells.SpecialCells(xlLastCell)).Delete
      Range(Cells(1, 1), Cells(lRows, 1)).Formula = "=TEXT(ROW(),""000"")"
      Range(Cells(1, 2), Cells(lRows, 2)).Formula = "=row()"
      Range(Cells(1, 3), Cells(lRows, 3)).Value = "something"
      Cells(4, 1).Value = Empty
      
      Debug.Print "Start to before assigning cells " & Timer - Stime
      'by far the fastest way to get cell data is a no paren variant
      vArrayNoParen = Range(Cells(1, 1), Cells(lRows, lCols)).Value
      Debug.Print "after assign cells " & Timer - Stime
      
      vDllStartTime = Timer
      SReturnValue = ModvArray(vArrayNoParen, vDllStartTime)
      Debug.Print SReturnValue
      Debug.Print " time within dll " & Timer - vDllStartTime
      Debug.Print "start to after dll " & Timer - Stime
      
      If SReturnValue = "Error" Then
         MsgBox "dll returned error"
      Else
         vPutInCellsStartTime = Timer
         ubrows = UBound(vArrayNoParen, 1)
         ubcols = UBound(vArrayNoParen, 2)
         Set oRange = Cells(1, 5)
         'oRange.Resize(ubRows, ubCols).NumberFormat = "@" 'to force text format
         oRange.Resize(ubrows, ubcols).Value = vArrayNoParen
         Debug.Print " time to put in cells " & Timer - vPutInCellsStartTime
      End If
      Set oRange = Nothing
      Debug.Print "done within function " & Timer - Stime
    
    End Function
    '30000 rows, 3 columns
    'Start to before assigning cells 0.8808594
    'after assign cells 1.041016
    ' dll crankup time -000.00
    ' dll up to mod array 000.05
    ' dll past mod array 000.22
    ' dll past assign 000.71
    ' time within dll 1.148438
    'start to after dll 2.189453
    ' time to put in cells 2.910156
    'done within function 5.099609
    'after function return 6.089844



    [This message has been edited by John Hackl (edited June 13, 2003).]
Working...
X