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

Question

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