home *** CD-ROM | disk | FTP | other *** search
/ Visual Basic Source Code / Visual Basic Source Code.iso / vbsource / hugstr / huge_tst.bas < prev    next >
Encoding:
BASIC Source File  |  1992-09-15  |  6.8 KB  |  160 lines
  1. '########## HUGEARR -- Huge Array Functions -- Module
  2. 'This declaration file contains the original names for these functions.
  3. Declare Function HugeDim% Lib "hugearr.dll" Alias "VBHugeDim" (ByVal recsize%, ByVal limit&)
  4. Declare Function HugeRedim% Lib "hugearr.dll" Alias "VBHugeRedim" (ByVal hArray%, ByVal limit&)
  5. Declare Function HugeErase% Lib "hugearr.dll" Alias "VBHugeErase" (ByVal hArray%)
  6. Declare Function GetHugeEl% Lib "hugearr.dll" Alias "VBHugeGet" (ByVal Index%, ByVal el&, buffer As Any)
  7. Declare Function GetHugeNEl% Lib "hugearr.dll" Alias "VBHugeGetNum" (ByVal Index%, ByVal el&, ByVal nelem%, buffer As Any)
  8. Declare Function HugeInt% Lib "hugearr.dll" Alias "VBHugeGetInt" (ByVal hArray%, ByVal el&)
  9. Declare Function HugeLong& Lib "hugearr.dll" Alias "VBHugeGetLong" (ByVal hArray%, ByVal el&)
  10. Declare Function HugeSingle! Lib "hugearr.dll" Alias "VBHugeGetSingle" (ByVal hArray%, ByVal el&)
  11. Declare Function HugeDouble# Lib "hugearr.dll" Alias "VBHugeGetDouble" (ByVal hArray%, ByVal el&)
  12. Declare Function HugeCurrency@ Lib "hugearr.dll" Alias "VBHugeGetCurrency" (ByVal hArray%, ByVal el&)
  13. Declare Function NumHugeArrays% Lib "hugearr.dll" Alias "VBHugeNumArrays" ()
  14. Declare Function HugeUbound& Lib "hugearr.dll" Alias "VBHugeUBound" (ByVal hArray%)
  15. Declare Function HugeLoad& Lib "hugearr.dll" Alias "VBHugeLoad" (ByVal hArray%, ByVal RecLen%, ByVal Fn$)
  16. Declare Function HugeSave& Lib "hugearr.dll" Alias "VBHugeSave" (ByVal hArray%, ByVal NEl&, ByVal RecLen%, ByVal Fn$)
  17. Declare Function SetHugeEl% Lib "hugearr.dll" Alias "VBHugeSet" (ByVal Index%, ByVal el&, buffer As Any)
  18. Declare Function SetHugeNEl% Lib "hugearr.dll" Alias "VBHugeSetNum" (ByVal Index%, ByVal el&, ByVal nelem%, buffer As Any)
  19.  
  20. '################# new functions from hstrcat.c ###########################
  21. Declare Function VBHugeStrCat Lib "HUGEARR.DLL" (ByVal dest As Any, ByVal src As String) As Long
  22. Declare Function VBHugeStrEnd Lib "HUGEARR.DLL" (ByVal hMem As Integer) As Long
  23. Declare Function VBHugeLock Lib "HUGEARR.DLL" (ByVal hMem%) As Long
  24.  
  25. Declare Function GetActiveWindow Lib "User" () As Integer
  26. Declare Function lstrcpy Lib "Kernel" (ByVal lpString1 As Any, ByVal lpString2 As Any) As Long
  27. Declare Function AnsiPrev Lib "User" (ByVal lpString As String, ByVal lpString As String) As Long
  28.  
  29. '============ clipboard functions
  30. Declare Function EmptyClipboard Lib "User" () As Integer
  31. Declare Function OpenClipboard Lib "User" (ByVal hWnd As Integer) As Integer
  32. Declare Function CloseClipboard Lib "User" () As Integer
  33. Declare Function SetClipboardData Lib "User" (ByVal wFormat As Integer, ByVal hMem As Integer) As Integer
  34. Declare Function GetClipboardData Lib "User" (ByVal wFormat As Integer) As Integer
  35.  
  36. '=============================================
  37. Declare Function GlobalAlloc Lib "Kernel" (ByVal wFlags As Integer, ByVal dwBytes As Long) As Integer
  38. Declare Function GlobalCompact Lib "Kernel" (ByVal dwMinFree As Long) As Long
  39. Declare Function GlobalFree Lib "Kernel" (ByVal hMem As Integer) As Integer
  40. Declare Function GlobalHandle Lib "Kernel" (ByVal wMem As Integer) As Long
  41. Declare Function GlobalLock Lib "Kernel" (ByVal hMem As Integer) As Long
  42. Declare Function GlobalReAlloc Lib "Kernel" (ByVal hMem As Integer, ByVal dwBytes As Long, ByVal wFlags As Integer) As Integer
  43.  
  44. 'NOTE: instead of declaring the function GlobalDiscard and calling
  45. '      GlobalDiscard(hMem), call GlobalReAlloc(hMem, 0, GMEM_MOVEABLE)
  46. Declare Function GlobalSize Lib "Kernel" (ByVal hMem As Integer) As Long
  47. Declare Function GlobalUnlock Lib "Kernel" (ByVal hMem As Integer) As Integer
  48. Declare Function hmemcpy Lib "Kernel" (ByVal lpdest As Any, ByVal lpsource As Any, ByVal length As Long) As Long
  49. '====================================================
  50.  
  51. '==========================================================
  52. Function BuildHuge& ()
  53.  
  54. Dim rocnt%
  55. MEM_CHUNKS& = 64000
  56.  
  57. numcols% = 20
  58. roww$ = String$(2000, Chr$(0))    ' allocate space for 1 row of data
  59.  
  60. NL$ = Chr$(13) + Chr$(10)       'CRLF
  61. TABKEY$ = Chr$(9)               'tab character
  62.  
  63. '============================================
  64. Rem ====== allocate initial block of memory for all of data
  65.         numallocs& = 1
  66.         mem_sp& = MEM_CHUNKS& * numallocs&
  67.         hMem% = GlobalAlloc(GMEM_MOVEABLE Or GMEM_ZEROINIT, ByVal mem_sp&)
  68.         If hMem% = 0 Then
  69.         MsgBox "Can't Do initial memory allocation"
  70.         SQLQuery = 0
  71.         Exit Function
  72.         End If
  73.         lptrStart& = VBHugeLock(ByVal hMem%)
  74.         If lptrStart& = 0 Then
  75.         MsgBox "Can't do initial memory allocation"
  76.         SQLQuery = 0
  77.         Exit Function
  78.         End If
  79.         lptr& = lptrStart&       'initialize pointer
  80.         memused& = 0
  81.  
  82. '==== init string
  83.     For rocnt% = 1 To 500
  84. '        roww$ = Str$(rocnt%) + TABKEY$
  85.     roww$ = ""
  86.  
  87. '=== build a row of test data
  88.     For x% = 1 To numcols%
  89.         colval$ = "R" + Str$(rocnt%) + "C" + Str$(x%)
  90.         roww$ = roww$ + colval$ + TABKEY$
  91.     Next x%
  92.  
  93. Rem ===  add crlf
  94.     roww$ = roww$ + NL$        ' add CRLF
  95.     length = Len(roww$)
  96.  
  97. Rem  === calculate used memory
  98.          If (memused& + length + 2) >= mem_sp& Then
  99.         MsgBox "doing a realloc"
  100.         numallocs& = numallocs& + 1
  101.         mem_sp& = MEM_CHUNKS& * numallocs&
  102.         hMem% = GlobalReAlloc(ByVal hMem%, mem_sp&, GMEM_MOVEABLE)
  103.         If hMem% = 0 Then
  104.             MsgBox "Can't Reallocate memory"
  105.             SQLQuery = 0
  106.             ret% = GlobalFree(ByVal hMem%)
  107.             Exit Function
  108.         End If
  109.            lptrStart& = VBHugeLock(ByVal hMem%)
  110.         If lptrStart& = 0 Then
  111.             ret% = GlobalFree(ByVal hMem%)
  112.             MsgBox "Can't Do a Reallocate"
  113.             SQLQuery = 0
  114.             Exit Function
  115.         End If
  116.         lptr& = VBHugeStrEnd&(ByVal hMem%) 'find new end of string
  117.         End If     ' ===============  end of realloc
  118.  
  119. Rem ====== concatanate new row of data to old one
  120.          lptr& = VBHugeStrCat&(lptr&, ByVal roww$)
  121.          memused& = memused& + length
  122.  
  123.     Next rocnt%             'row loop counter
  124.  
  125.       MsgBox "memory used= " + Str$(memused&)
  126. '============= get size of data and allocate clipboard memory
  127.     lSize& = GlobalSize(hMem%) + 5
  128.  
  129.     hClipMem% = GlobalAlloc(GMEM_MOVEABLE Or GMEM_ZEROINIT, lSize&)
  130.     If hClipMem% = 0 Then
  131.         MsgBox "Can't allocate memory for Clipboard"
  132.         SQLQuery = 0
  133.         Exit Function
  134.     End If
  135.     lpClipData& = VBHugeLock(hClipMem%)
  136.     If lpClipData& = 0 Then
  137.         MsgBox "Can't allocate memory for Clipboard"
  138.         SQLQuery = 0
  139.         Exit Function
  140.     End If
  141.  
  142. '=== copy data to clipboard memory
  143.     lptrStart& = VBHugeLock(hMem%)  'get start address
  144.     old& = hmemcpy(lpClipData&, lptrStart&, memused&)
  145.     
  146.     ret% = GlobalUnlock(hMem%)        'release handle
  147.     ret% = GlobalUnlock(hClipMem%)    'release handle
  148.     hWnd% = GetActiveWindow()
  149.     If (OpenClipboard(hWnd%)) Then
  150.         MsgBox "Opening clipboard"
  151.         ret% = EmptyClipboard()
  152.         ret% = SetClipboardData(CF_TEXT, hClipMem%)
  153.         ret% = CloseClipboard()
  154.     End If
  155.     st% = GlobalFree(hMem%)   'free memory
  156.  
  157.     BuildHuge = rocnt% - 1
  158. End Function
  159.  
  160.