VB6 crashes out of IDE after exiting program that sets up MMF

189 Views Asked by At

User wqw suggested I supply a working program that will run in the IDE. This is a minimal reproduceable example but it's large. The predecessor code was originally developed by Karl E. Peterson. I have undoubtedly gronked it. My app drops out of the IDE when I exit the running program. Break then (Menu>>Run>>End). This suggests deeper problems with my code. App uses MMF 'files'. The .exe runs without problems but dropping out of the IDE suggests something ain't right. Yes, this is 3 modules and is a ridiculous amount of code (commented to the best of my ability). The line that breaks things is highlighted as 'OFFENDING LINE'. If you stop and exit the IDE anywhere above that line there is no problem. Anywhere after and the IDE goes wonky and you can't exit. It either kicks me out or requires killing the IDE in task manager. Thanks for having a look!

'*************************************************
'DUMMY_MAIN.BAS
'*************************************************

Attribute VB_Name = "dummy_Main"
Option Explicit

Public Sub Main()

   Dim mySize As Long, void As Double

Dim table As TableType
Dim DataDescPage As DataDescPageType
Dim TableSymInfo As TableSymInfoType
Dim dPageSymbolList As dPageSymbolListType
Dim fxd_dPageSymbolList As fxd_dPageSymbolListType
Dim Rank As RankType
'Dim xProcJOB As xProcJOBtype
Dim RANKmem As RANKmemType

void = LenB(table) '1220
void = LenB(xProc) '1176
void = LenB(DataDescPage) '812
void = LenB(TableSymInfo) '1264
void = LenB(dPageSymbolList) '836
void = LenB(fxd_dPageSymbolList) '13,476
void = LenB(Rank) '76
void = LenB(xProcJOB) '27,436
void = LenB(RANKmem) '52
void = LenB(MSGar(1)) '29544
void = 1220& + &O1176& + 812& + 1264& + 836& + 13476& + 76& + 27436& + 52 +    29544&

'^75,354 bytes total

Debug.Assert 0

   mySize = LenB(MSGar(1))
   
   mySize = mySize * 40
   
   Call MMF_OpenOrCreateMap("MMF_MSG", mySize, MSGhObj, MSGbaseAddressOfMMF, 0)

   Call MMF_AttachToLocalArray(0)

'NEW NEW v Call MMF_ReleaseLocalArray(0)

   MsgBox ("Bye")
      
End Sub

'*************************************************
'DUMMY_OPS.BAS
'*************************************************
Attribute VB_Name = "dummy_ops"
Option Explicit

Private Const PAGE_READWRITE As Long = 4
Private Const API_NULL As Long = 0
Private Const INVALID_HANDLE_VALUE As Long = -1
Private Const API_FALSE As Long = 0
Private Const SECTION_MAP_WRITE = &H2
Private Const FILE_MAP_WRITE = SECTION_MAP_WRITE
Private Const FORMAT_MESSAGE_FROM_SYSTEM = 4096
Private Const FADF_AUTO As Integer = 1

Public Declare Function VarPtrArray Lib "msvbvm60.dll" Alias "VarPtr" (VAR() As Any) As Long

Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long

Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
    ByVal Destination As Long, _
    ByVal Source As Long, _
    ByVal Length As Long)

'my Alias
Private Declare Sub CopyMemorySA Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)

Private Declare Function CreateFileMapping Lib "kernel32" Alias "CreateFileMappingA" ( _
    ByVal hFile As Long, _
    ByVal lpFileMappigAttributes As Long, _
    ByVal flProtect As Long, _
    ByVal dwMaximumSizeHigh As Long, _
    ByVal dwMaximumSizeLow As Long, _
    ByVal lpName As String) As Long
Private Declare Function MapViewOfFile Lib "kernel32" ( _
    ByVal hFileMappingObject As Long, _
    ByVal dwDesiredAccess As Long, _
    ByVal dwFileOffsetHigh As Long, _
    ByVal dwFileOffsetLow As Long, _
    ByVal dwNumberOfBytesToMap As Long) As Long
Private Declare Function OpenFileMapping Lib "kernel32" Alias "OpenFileMappingA" ( _
    ByVal dwDesiredAccess As Long, _
    ByVal bInheritHandle As Long, _
    ByVal lpName As String) As Long
Private Declare Function UnmapViewOfFile Lib "kernel32" (ByVal lpBaseAddress As Long) As Long

Private Declare Function FormatMessage Lib "kernel32" _
   Alias "FormatMessageA" (ByVal dwFlags As Long, _
   lpSource As Any, ByVal dwMessageId As Long, _
   ByVal dwLanguageId As Long, ByVal lpBuffer As String, _
   ByVal nSize As Long, Arguments As Long) As Long

Private Type SAFEARRAYBOUND
    cElements As Long
    lLbound As Long
End Type

Private Type SAFEARRAY
   cDims As Integer         'Count of dimensions in this array.
   fFeatures As Integer     'Flags used by the SafeArray
   cbElements As Long       'Size of an element of the array.
   cLocks As Long           ' Number of locks
   pvData As Long           ' Pointer to the data.
End Type

Private MSGm_pSA As Long
Public MSGhObj As Long
Private MSGm_SA() As SAFEARRAY
Private MSGm_SAOld As SAFEARRAY
Private MSGm_SABounds() As SAFEARRAYBOUND
Private MSGm_SAOldBounds() As SAFEARRAYBOUND
Public MSGbaseAddressOfMMF As Long
Private MSGm_pvDataSA As Long
Private MSGm_pvDataSABounds As Long
Private MSG_MMFcreated As Boolean
Public mystr As String
Public MSGcounter As Long

Public MSGar() As MSGType
Public xProcJOB As xProcJOBtype
Public xProc As xProcType


Public Sub MMF_AttachToArray(ArrayPtr As Long, passedUBound As Long, ARRAYcounter As Long, _
   MMFname As String, m_pSA As Long, m_SA() As SAFEARRAY, m_SAOld As SAFEARRAY, _
   m_SABounds() As SAFEARRAYBOUND, m_SAOldBounds() As SAFEARRAYBOUND, BaseAddressOfMMF As Long, _
   m_pvDataSA As Long, m_pvDataSABounds As Long)
   
   Dim ppSA As Long, pSA As Long, nDims As Integer

m_SA(1).fFeatures = FADF_AUTO 'wqw idea

50

   ppSA = ArrayPtr '-->ArrayPtr is VarPtrArray(MSGar or GBLmemAr or RANKmemAr or TRADESmemAr)
   'based on the text I am assuming ppSA wil become a pointer to a pointer to the SA struct for array MSGar()
   'At this moment ppSA is the base addr of MSGar in my world
   
   'v a NEW var m_pSA is a private long. We assign to it ppSA which is the pointer to MSGar()
   CopyMemorySA m_pSA, ByVal ppSA, 4&: If err.LastDllError Then MsgBox (MMF_GetWin32ErrorDescription(err))
   'this should be the same as m_pSA=ppSA?
   
   If m_pSA Then '<- m_pSA holds pointer to MSGar()
   
      'get safearray structure
      'v copy the first 2 bytes of the MSGar() pointer into the int var nDims
      CopyMemorySA nDims, ByVal m_pSA, 2&: If err.LastDllError Then MsgBox (MMF_GetWin32ErrorDescription(err))
      'so now nDims knows/holds the number of diminsions of MSGArrayPtr() --->1

      If nDims < 1 Then nDims = 1 'just in case
      ReDim m_SAOldBounds(nDims - 1) As SAFEARRAYBOUND 'initialize m_SAOldBounds()
      '      ^ this will receive a copy of the current 16 byte SA struct

      'Copy the entire (empty at this moment) 16 byte SA structure to a private var of type SA known as m_SAOld
      'We're saving previous SA values I guess...even tho none exist at this point bcuz MSGAr() is empty
      CopyMemorySA m_SAOld, ByVal m_pSA, 16&: If err.LastDllError Then MsgBox (MMF_GetWin32ErrorDescription(err))
      'so now we've saved the entire current m_pSA struct to m_SAOld
      
      'v Copy 8 bytes from the location *immediately following*
      'our original array structure to Private m_SABounds() As SAFEARRAYBOUND
      'I'm assuming that this means copy the 8 bytes from the existing SAFEARRAYBOUND structure
      '(.cElements and .lLbound) to m_SAOldBounds(0), the lowest/first elem of
      'm_SAOldBounds thus saving/preserving whatever is there.
      CopyMemorySA m_SAOldBounds(0), ByVal m_pSA + 16&, nDims * 8&: If err.LastDllError Then MsgBox (MMF_GetWin32ErrorDescription(err))

      ReDim m_SABounds(0) As SAFEARRAYBOUND 'initialize a new safearraybound

      'point m_sa(0) to safearray structure associated with MSGar()

      'Copy the VarPtrArray of EMPTY SA array named m_SA() to empty long pSA thus initialising "pSA"
      'as a pointer to the new SA array
      CopyMemorySA pSA, ByVal VarPtrArray(m_SA), 4&: If err.LastDllError Then MsgBox (MMF_GetWin32ErrorDescription(err))

      'Copy a long found at the addr+12 of the new SA array (.pvdata) to a NEW long var called m_pvDataSA
      CopyMemorySA m_pvDataSA, ByVal pSA + 12&, 4&: If err.LastDllError Then MsgBox (MMF_GetWin32ErrorDescription(err))
      'so now m_pvDataSA is a pointer to .pvdata of the new array m_SA()

      'Copy long m_pSA to pSA+12(.pvdata)  m_pSA is a copy of ppSA so essentially we are copying the value of
      'ppSA to .pvdata of pSA
      'so now m_SA().pvdata is a pointer to our original MSGar()
      CopyMemorySA ByVal pSA + 12&, m_pSA, 4&: If err.LastDllError Then MsgBox (MMF_GetWin32ErrorDescription(err))
      

      'point m_SABounds() to safearray bounds
      'overwrite the pointer to SA with the pointer to m_SABounds(0)
      CopyMemorySA pSA, ByVal VarPtrArray(m_SABounds), 4&: If err.LastDllError Then MsgBox (MMF_GetWin32ErrorDescription(err))
      


      'initialize (copy to) m_pvDataSABounds our new pSA.pvdata (pointer to MSGar())
      CopyMemorySA m_pvDataSABounds, ByVal pSA + 12&, 4&: If err.LastDllError Then MsgBox (MMF_GetWin32ErrorDescription(err))
      'm_pvDataSABounds is later used as test in release array routine

      'v  m_pSA + 16& is pointer to .cElements of original MSGar()
      'so here we copy the Long pointer into .cElements of our original MSGar()
      'v to pSA.data. So now pSA.data is a pointer to .cElements of SAFEARRAYBOUND of our original MSGar()
'ZZZZZZZZZZZZZZZ  OFFENDING LINE  ZZZZZZZZZZZZZZZ
Debug.Assert 0
      CopyMemorySA ByVal pSA + 12&, m_pSA + 16&, 4&: If err.LastDllError Then MsgBox (MMF_GetWin32ErrorDescription(err))
Debug.Assert 0
'ZZZZZZZZZZZZZZZ  OFFENDING LINE  ZZZZZZZZZZZZZZZ
'if I end the running program after ^ this line or below, it freezes up or CRASHS out of IDE.
'if I end the running program above ^ this line, no freeze up, no CRASH out of IDE.
      ' redim m_SABounds
      'assign nDims to SAFEARRAYBOUND.cElements
      CopyMemorySA ByVal pSA + 16&, nDims, 4&: If err.LastDllError Then MsgBox (MMF_GetWin32ErrorDescription(err))

      'assign SAFEARRAYBOUND.lLbound a value of 1
      CopyMemorySA ByVal pSA + 20&, 1&, 4&: If err.LastDllError Then MsgBox (MMF_GetWin32ErrorDescription(err))
      
      m_SA(0).cLocks = m_SA(0).cLocks + 1&

   End If

   ARRAYcounter = passedUBound

   m_SABounds(1).cElements = ARRAYcounter
   m_SA(0).pvData = BaseAddressOfMMF


End Sub

Public Function MMF_GetWin32ErrorDescription(err As ErrObject) As String

   Dim lngRet As Long
   Dim strAPIError As String
   Dim ErrorCode As Long

   strAPIError = String$(2048, " ")
   
   ErrorCode = err.LastDllError

   lngRet = FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, _
   ByVal 0&, ErrorCode, 0, strAPIError, Len(strAPIError), 0)
   
   strAPIError = Left$(strAPIError, lngRet)
   MMF_GetWin32ErrorDescription = strAPIError
   
   err.Clear

End Function
Public Sub MMF_CloseMap(BaseAddressOfMMF As Long, hObj As Long)
    UnmapViewOfFile BaseAddressOfMMF
    CloseHandle hObj
    hObj = 0
End Sub

Public Sub MMF_OpenOrCreateMap(ByVal Name As String, ByVal size As Long, hObj As Long, _
   BaseAddressOfMMF As Long, MMFcreated As Boolean)
   
   Dim resizeCounter As Long
   If hObj Then
      Call MMF_CloseMap(BaseAddressOfMMF, hObj)
      If err.LastDllError Then
         MsgBox ("0z MMF_OpenOrCreateMap" + Str(err.LastDllError) + Str(hObj))
      End If
      
   End If
   
top:

   hObj = OpenFileMapping(FILE_MAP_WRITE, API_FALSE, Name)


   err.Clear
   MMFcreated = False
   If hObj = 0 Then
      If size = 0 Then Exit Sub

      If size < 1 Then err.Raise 5, , "Size must be at least 1 byte."

      hObj = CreateFileMapping(INVALID_HANDLE_VALUE, API_NULL, PAGE_READWRITE, 0, size, Name)
      If err.LastDllError Then
         MsgBox ("3z MMF_OpenOrCreateMap" + Str(err.LastDllError))
      End If
      
      If err.LastDllError Then MsgBox (MMF_GetWin32ErrorDescription(err))
      MMFcreated = True
   End If
   
   If hObj Then
      BaseAddressOfMMF = MapViewOfFile(hObj, FILE_MAP_WRITE, 0, 0, 0)
      If err.LastDllError Then
      MsgBox ("2MMF_OpenOrCreateMap" + Str(err.LastDllError) + vbCrLf + vbCrLf + _
            MMF_GetWin32ErrorDescription(err))
      err.Clear
      End If
      
   End If

End Sub
Public Sub MMF_AttachToLocalArray(whichMap As Integer)

   Select Case whichMap
   Case 0 'MSG

      ReDim MSGar(1 To 40) As MSGType
      
      ReDim MSGm_SA(1) As SAFEARRAY

      Call MMF_AttachToArray(VarPtrArray(MSGar), 40, MSGcounter, _
        "MMF_MSG", MSGm_pSA, MSGm_SA(), MSGm_SAOld, MSGm_SABounds(), MSGm_SAOldBounds(), _
        MSGbaseAddressOfMMF, MSGm_pvDataSA, MSGm_pvDataSABounds)

   End Select

End Sub

Public Sub MMF_ReleaseArray(m_pSA As Long, m_SA() As SAFEARRAY, m_SABounds() As SAFEARRAYBOUND, m_SAOld As SAFEARRAY, _ m_SAOldBounds() As SAFEARRAYBOUND, m_pvDataSA As Long, m_pvDataSABounds As Long)

Dim pSA As Long

If m_pSA Then 'Debug.Assert 0 CopyMemorySA ByVal m_pSA, m_SAOld, 16& CopyMemorySA ByVal m_pSA + 16&, m_SAOldBounds(0), m_SAOld.cDims * 8& m_pSA = 0

  If m_pvDataSA Then

'Debug.Assert 0 CopyMemorySA pSA, ByVal VarPtrArray(m_SA), 4 CopyMemorySA ByVal pSA + 12, m_pvDataSA, 4 m_pvDataSA = 0 End If

  If m_pvDataSABounds Then

'Debug.Assert 0 CopyMemorySA pSA, ByVal VarPtrArray(m_SABounds), 4 CopyMemorySA ByVal pSA + 12, m_pvDataSABounds, 4 CopyMemorySA ByVal pSA + 16&, 1&, 4& CopyMemorySA ByVal pSA + 20&, 0&, 4& m_pvDataSABounds = 0 End If End If End Sub

Public Sub MMF_ReleaseLocalArray(whichAr As Long) Select Case whichAr Case 0 'MSG Call MMF_ReleaseArray(MSGm_pSA, MSGm_SA(), MSGm_SABounds(), MSGm_SAOld, _ MSGm_SAOldBounds(), MSGm_pvDataSA, MSGm_pvDataSABounds) End Select End Sub Public Sub MMF_ReleaseArray(m_pSA As Long, m_SA() As SAFEARRAY, m_SABounds() As SAFEARRAYBOUND, m_SAOld As SAFEARRAY, _ m_SAOldBounds() As SAFEARRAYBOUND, m_pvDataSA As Long, m_pvDataSABounds As Long)

Dim pSA As Long

If m_pSA Then 'Debug.Assert 0 CopyMemorySA ByVal m_pSA, m_SAOld, 16& CopyMemorySA ByVal m_pSA + 16&, m_SAOldBounds(0), m_SAOld.cDims * 8& m_pSA = 0

  If m_pvDataSA Then

'Debug.Assert 0 CopyMemorySA pSA, ByVal VarPtrArray(m_SA), 4 CopyMemorySA ByVal pSA + 12, m_pvDataSA, 4 m_pvDataSA = 0 End If

  If m_pvDataSABounds Then

'Debug.Assert 0 CopyMemorySA pSA, ByVal VarPtrArray(m_SABounds), 4 CopyMemorySA ByVal pSA + 12, m_pvDataSABounds, 4 CopyMemorySA ByVal pSA + 16&, 1&, 4& CopyMemorySA ByVal pSA + 20&, 0&, 4& m_pvDataSABounds = 0 End If End If End Sub

Public Sub MMF_ReleaseLocalArray(whichAr As Long) Select Case whichAr Case 0 'MSG Call MMF_ReleaseArray(MSGm_pSA, MSGm_SA(), MSGm_SABounds(), MSGm_SAOld, _ MSGm_SAOldBounds(), MSGm_pvDataSA, MSGm_pvDataSABounds) End Select End Sub

'*************************************************
'DUMMY_VARIABLES.BAS
'*************************************************

Attribute VB_Name = "dummy_variables"
Option Explicit


Public Type TableType
   symbol            As String * 8
   Instrument        As Integer
   DataPageName      As String * 24
   Description       As String * 20
   IsTagged          As Boolean
   MARGIN            As Double
   ValOfPtMove       As Double
   EachTick          As Double
   DispDec           As Integer
   Format            As String * 27
   Sector            As Integer
   Custom            As Integer
   LimitInDollars    As Double
   ForexCMPField     As Integer
   Store(1 To 8)     As Double
   StoreNotes(1 To 8) As String * 20
   MostRecentForex   As Double
   DecimalMult       As Double
   UseReciprocal     As Boolean
   isCloseOnlySeries As Boolean
   OtherAsciiFields  As Integer
   priceDataFileExt  As String * 4
   dateFormatCRC     As Integer
   priceDataFilePathCRC  As Integer
   ForexFileName As String * 255
   dummy1(1 To 4) As Byte
   hiDate            As Long
   loDate            As Long
   NumOfRecordsToLoad   As Long
   dummy2(1 To 4) As Byte
   howManyPriceFields   As Long
   CacheAction As Integer
   dummy3(1 To 4) As Byte
   MinRecsToRetainTag As Integer
   priceDataFileTime As String * 8
   eodFileTime As String * 8
   dummy4(1 To 24) As Byte
End Type

Public Type DataDescPageType
   dummy(1 To 812) As Byte
End Type

Public Type xProcType
   dummy(1 To 1176) As Byte
End Type

'Public Type TableSymInfoType
'   dummy(1 To 1264) As Byte
'End Type
Public Type TableSymInfoType
   sSym                 As String * 8
   howManyPriceFields   As Integer
   isOpenIncluded       As Boolean
   isHighIncluded       As Boolean
   isLowIncluded        As Boolean
   IsTagged             As Boolean
   m_DatElForThisSym As Long
   LastNonZeroDay As Long
   parentTableSymIndex As Long
   eodHasChanged As Boolean
   table                As TableType
End Type


Public Type dPageSymbolListType
   dummy(1 To 836) As Byte
End Type

Public Type fxd_dPageSymbolListType
   dummy(1 To 13476) As Byte
End Type

Public Type RankType
   dummy(1 To 76) As Byte
End Type

Public Type xProcJOBtype
   dummy(1 To 27436) As Byte
End Type

Public Type RANKmemType
   dummy(1 To 52) As Byte
End Type

Public Type MSGType
   ChildLocalUBofRANKar As Long
   ChildLocalUBofTRADESar As Long
   
   MMFbyteToReceiveChildLocalRANKar As Long
   MMFbyteToReceiveChildLocalTRADESar As Long
   
   childMSGelement As Long
   GBL_MMFchildArBounds As Long
   hiDate As Long
   msgNum As Long
   calledFromWhere As Long
   processID As String * 8
   RANKmem As RANKmemType
   RANKasgnProcIndex As Long
   TRADESAsgnProcIndex As Long
   xProcJOB As xProcJOBtype
   xProc As xProcType
   dPage As DataDescPageType
   busy As Integer
   isActive As Boolean
   youveGotMail As Boolean
End Type
0

There are 0 best solutions below