将 .ged 文件读取和解析到 sqlite 数据库时出现内存不足错误
Out of memory error when reading and parsing a .ged file into a sqlite database
我编写了以下程序来读取和解析 .ged 文件（家谱数据）并将其存储在 SQLite 数据库中。该程序可以运行，但是当加载大文件时，我得到一个 "out of memory exception"。我是 Visual Basic 的新手，但似乎每个创建的 object 都存储在内存中，直到程序结束，因为随着程序运行，内存使用量增加到 4 gigs。
我找遍了，但找不到解决方案。求助！
我有一个相似的家庭和 Child class 和服务器中的潜艇 class 每个。
人Class：
Public Class Person
Public Property ID As String
Public Property personID As String
Public Property surName As String
Public Property givenName As String
Public Property sex As String
Public Property birthDate As String
Public Property birthYear As String
Public Property birthPlace As String
Public Property deathDate As String
Public Property deathYear As String
Public Property deathPlace As String
Public Property famC As String
End Class
服务器：
Public Sub AddPerson(p As Person)
Dim addPersonquery As String = "INSERT INTO Person(
ID,
PersonID,
SurName,
GivenName,
Sex,
BirthDate,
BirthPlace,
DeathDate,
DeathPlace,
FamC)
VALUES(
@ID,
@pid,
@sn,
@gn,
@se,
@bd,
@bP,
@dd,
@dp,
@fc);"
Using SqlConn As New SQLiteConnection(AMconnectionString)
Dim cmd As New SQLiteCommand(addPersonquery, SqlConn)
cmd.Parameters.AddWithValue("@ID", p.ID)
cmd.Parameters.AddWithValue("@pid", p.personID)
cmd.Parameters.AddWithValue("@sn", p.surName)
cmd.Parameters.AddWithValue("@gn", p.givenName)
cmd.Parameters.AddWithValue("@se", p.sex)
cmd.Parameters.AddWithValue("@bd", p.birthDate)
cmd.Parameters.AddWithValue("@bp", p.birthPlace)
cmd.Parameters.AddWithValue("@dd", p.deathDate)
cmd.Parameters.AddWithValue("@dp", p.deathPlace)
cmd.Parameters.AddWithValue("@fc", p.famC)
SqlConn.Open()
cmd.ExecuteNonQuery()
End Using
End Sub
主程序：
Option Strict On
Public Class GedcomParser
Dim AdamMarsServer As New Server()
Public Sub Button1_Click(sender As Object, e As EventArgs) Handles Button1.Click
AdamMarsServer.CreateDatabase()
Gedcomreader()
Close()
End Sub
Private Sub Gedcomreader()
Dim ofdbox As New OpenFileDialog()
ofdbox.Title = "Select Your FTM Gedcom file"
ofdbox.Filter = "gedcom Files|*.ged"
ofdbox.InitialDirectory = (My.Computer.FileSystem.SpecialDirectories.MyDocuments)
ofdbox.ShowDialog()
Dim fileReader As System.IO.StreamReader
fileReader = My.Computer.FileSystem.OpenTextFileReader(ofdbox.FileName)
Dim stringReader As String
Dim strRecData As String
Dim strPlaceHolder As String
Dim blnIndividual As Boolean
Dim blnFamily As Boolean
stringReader = fileReader.ReadLine()
Do While Not stringReader = ""
stringReader = fileReader.ReadLine()
strPlaceHolder = stringReader
If Strings.Left(strPlaceHolder, 1) = "0" Then
If Len(strRecData) <> 0 Then
If blnFamily Or blnIndividual Then
ParseRecord(strRecData)
'numpeople.Text = ProgressBar2.Value.ToString()
'numfam.Text = ProgressBar3.Value.ToString()
strRecData = ""
blnFamily = False
blnIndividual = False
End If
End If
Select Case Strings.Right(strPlaceHolder, 3)
Case "NDI"
blnIndividual = True
blnFamily = False
strRecData = "IND " & strPlaceHolder
'ProgressBar2.Increment(1)
Case "FAM"
blnFamily = True
blnIndividual = False
strRecData = "FAM " & strPlaceHolder
'ProgressBar3.Increment(1)
End Select
Else
If blnIndividual Or blnFamily Then
strRecData = strRecData & vbCr & strPlaceHolder
End If
End If
Loop
fileReader.Close()
MessageBox.Show("Done")
End Sub
Private Sub ParseRecord(strRecord As String)
Dim childs As New child()
Dim persons As New Person()
Dim mfamily As New Family()
Dim intPosition As Integer = 6
Dim strData As String
Dim strSubType As String
Select Case Strings.Left(strRecord, 3)
Case "IND"
Do While intPosition <> 0
intPosition = 1
intPosition = InStr(intPosition, strRecord, Chr(13))
If intPosition = 0 And Len(strRecord) > 0 Then
strData = strRecord
Else
strData = Strings.Left(strRecord, intPosition)
End If
strRecord = Strings.Right(strRecord, Len(strRecord) - intPosition)
If String.Compare(strData, 0, "IND", 0, 3) = 0 Then
persons.personID = Mid(strData, InStr(1, strData, "@") + 1,
InStrRev(strData, "@") - InStr(1, strData, "@") - 1)
childs.PersonID = Mid(strData, InStr(1, strData, "@") + 1,
InStrRev(strData, "@") - InStr(1, strData, "@") - 1)
Else
Select Case Strings.Left(strData, 1)
Case "1"
Select Case Mid(strData, 3, 4)
Case "NAME"
If Len(strData) = 7 Then
persons.surName = ""
persons.givenName = ""
Else
persons.surName = Mid(strData, InStr(1, strData, "/") + 1,
InStrRev(strData, "/") - InStr(1, strData, "/") - 1)
Dim givName = Split(strData, "/")(0)
persons.givenName = givName.Remove(0, 7)
End If
Case "BIRT"
strSubType = "BIRTH"
Case "DEAT"
strSubType = "DEATH"
Case "FAMC"
persons.famC = Mid(strData, InStr(1, strData, "@") + 1,
InStrRev(strData, "@") - InStr(1, strData, "@") - 1)
childs.familyID = Mid(strData, InStr(1, strData, "@") + 1,
InStrRev(strData, "@") - InStr(1, strData, "@") - 1)
Case "SEX "
persons.sex = Mid(strData, 7, 1)
Case Else
End Select
Case "2"
Select Case strSubType
Case "BIRTH"
If Mid(strData, 3, 4) = "DATE" Then
persons.birthDate = GetGenData(strData)
ElseIf Mid(strData, 3, 4) = "PLAC" Then
persons.birthPlace = GetGenData(strData)
End If
Case "DEATH"
If Mid(strData, 3, 4) = "DATE" Then
persons.deathDate = GetGenData(strData)
ElseIf Mid(strData, 3, 4) = "PLAC" Then
persons.deathPlace = GetGenData(strData)
End If
Case Else
End Select
End Select
End If
Loop
AdamMarsServer.AddPerson(persons)
AdamMarsServer.Addchild(childs)
Case "FAM"
Do While intPosition <> 0
intPosition = 1
intPosition = InStr(intPosition, strRecord, Chr(13))
If intPosition = 0 And Len(strRecord) > 0 Then
strData = strRecord
Else
strData = Strings.Left(strRecord, intPosition)
End If
strRecord = Strings.Right(strRecord, Len(strRecord) - intPosition)
If String.Compare(strData, 0, "FAM", 0, 3) = 0 Then
mfamily.FamilyID = Mid(strData, InStr(1, strData, "@") + 1,
InStrRev(strData, "@") - InStr(1, strData, "@") - 1)
Else
Select Case Strings.Left(strData, 1)
Case "1"
Select Case Mid(strData, 3, 4)
Case "HUSB"
mfamily.HusbandID = Mid(strData, InStr(1, strData, "@") + 1,
InStrRev(strData, "@") - InStr(1, strData, "@") - 1)
Case "WIFE"
mfamily.WifeID = Mid(strData, InStr(1, strData, "@") + 1,
InStrRev(strData, "@") - InStr(1, strData, "@") - 1)
Case "MARR"
strSubType = "Marriage"
Case Else
End Select
Case "2"
Select Case strSubType
Case "Marriage"
If Mid(strData, 3, 4) = "DATE" Then
mfamily.MarriageDate = GetGenData(strData)
ElseIf Mid(strData, 3, 4) = "PLAC" Then
mfamily.MarriagePlace = GetGenData(strData)
End If
Case Else
End Select
End Select
End If
Loop
AdamMarsServer.AddFamily(mfamily)
End Select
End Sub
Function GetGEDNumber(GED As String) As String
GetGEDNumber = Mid(GED, InStr(1, GED, "@") + 1, InStrRev(GED, "@") - InStr(1, GED, "@") - 1)
End Function
Function GetGenData(Data As String) As String
GetGenData = Replace(Replace(Strings.Right(Data, Len(Data) - 7), Chr(13), ""), Chr(10), "")
End Function
结束Class
这是从这个 VBA 程序中添加的：
Sub ImportGED(strFullFileName As String)
Dim fso As New Scripting.FileSystemObject
Dim filGED As Scripting.File
Dim txsGED As Scripting.TextStream
Dim strLine As String
Dim strRecData As String
Dim strPlaceHolder As String
Dim blnIndividual As Boolean
Dim blnFamily As Boolean
Dim strSubType As String
Screen.MousePointer = ccHourglass
Set filGED = fso.GetFile(strFullFileName)
Set txsGED = filGED.OpenAsTextStream(ForReading, TristateUseDefault)
Do While Not txsGED.AtEndOfStream
If Form_GetGEDFile.ProgressBar2.Value < 25 Then
Form_GetGEDFile.ProgressBar2.Value = Form_GetGEDFile.ProgressBar2.Value + 1
Else
Form_GetGEDFile.ProgressBar2.Value = 1
End If
Form_GetGEDFile.Repaint
Form_GetGEDFile.Refresh
strPlaceHolder = txsGED.ReadLine
If Left(strPlaceHolder, 1) = "0" Then
If Len(strRecData) <> 0 Then
If blnFamily Or blnIndividual Then
ParseRecord strRecData
strRecData = ""
blnFamily = False
blnIndividual = False
End If
End If
Select Case Right(strPlaceHolder, 3)
Case "NDI"
blnIndividual = True
blnFamily = False
strRecData = "IND " & strPlaceHolder
Case "FAM"
blnFamily = True
blnIndividual = False
strRecData = "FAM " & strPlaceHolder
End Select
Else
If blnIndividual Or blnFamily Then
strRecData = strRecData & vbCr & strPlaceHolder
End If
End If
Loop
Form_GetGEDFile.ProgressBar2.Value = 25
txsGED.Close
Screen.MousePointer = ccDefault
End Sub
Sub ParseRecord(strRecord As String)
Dim conGen As New ADODB.Connection
Dim rstData As New ADODB.Recordset
Dim rstQuery As New ADODB.Recordset
Dim intPosition As Integer
Dim blnInSub As Boolean
Dim strData As String
intPosition = 1
conGen.Open Application.CurrentProject.BaseConnectionString
Select Case Left(strRecord, 3)
Case "IND"
rstData.Open "Select * FROM Individuals", conGen, adOpenKeyset, adLockPessimistic
rstData.AddNew
Do While intPosition <> 0
intPosition = 1
intPosition = InStr(intPosition, strRecord, Chr(13))
If intPosition = 0 And Len(strRecord) > 0 Then
strData = strRecord
Else
strData = Left(strRecord, intPosition)
End If
strRecord = Right(strRecord, Len(strRecord) - intPosition)
If Left(strData, 3) = "IND" Then
rstData![GED ID] = Mid(strData, InStr(1, strData, "@") + 1, InStrRev(strData, "@") - InStr(1, strData, "@") - 1)
Else
Select Case Left(strData, 1)
Case 1
Select Case Mid(strData, 3, 4)
Case "NAME"
rstData![Full Name] = Replace(GetGenData(strData), "/", "")
strSubType = "NAME"
Case "BIRT"
strSubType = "BIRTH"
Case "DEAT"
strSubType = "DEATH"
Case "FAMC"
rstData!Parents = GetGEDNumber(strData)
Case "SEX "
rstData!Sex = Mid(strData, 7, 1)
End Select
Case 2
Select Case strSubType
Case "Name"
If Mid(strData, 3, 4) = "GIVN" Then
rstData![Given Name] = GetGenData(strData)
ElseIf Mid(strData, 3, 4) = "SURN" Then
rstData!Surname = GetGenData(strData)
End If
Case "BIRTH"
If Mid(strData, 3, 4) = "DATE" Then
rstData![Birth Date] = GetGenData(strData)
ElseIf Mid(strData, 3, 4) = "PLAC" Then
rstData![Birth Location] = GetGenData(strData)
End If
Case "DEATH"
If Mid(strData, 3, 4) = "DATE" Then
rstData![Death Date] = GetGenData(strData)
ElseIf Mid(strData, 3, 4) = "PLAC" Then
rstData![Death Location] = GetGenData(strData)
End If
End Select
End Select
End If
Loop
rstData.Update
Case "FAM"
rstData.Open "Families", conGen, adOpenDynamic, adLockPessimistic
rstData.AddNew
Do While intPosition <> 0
intPosition = 1
intPosition = InStr(intPosition, strRecord, Chr(13))
If intPosition = 0 And Len(strRecord) > 0 Then
strData = strRecord
Else
strData = Left(strRecord, intPosition)
End If
strRecord = Right(strRecord, Len(strRecord) - intPosition)
If Left(strData, 3) = "FAM" Then
rstData![GED Family ID] = GetGEDNumber(strData)
Else
Select Case Left(strData, 1)
Case 1
Select Case Mid(strData, 3, 4)
Case "HUSB"
rstQuery.Open "Select ID, [GED ID] FROM Individuals Where [GED ID]='" & GetGEDNumber(strData) & "'", conGen, adOpenStatic, adLockReadOnly
rstData![Father ID] = rstQuery!ID
rstQuery.Close
Case "WIFE"
rstQuery.Open "Select ID, [GED ID] FROM Individuals Where [GED ID]='" & GetGEDNumber(strData) & "'", conGen, adOpenStatic, adLockReadOnly
rstData![Mother ID] = rstQuery!ID
rstQuery.Close
Case "MARR"
strSubType = "Marriage"
End Select
Case 2
Select Case strSubType
Case "Marriage"
If Mid(strData, 3, 4) = "DATE" Then
rstData![Marriage Date] = GetGenData(strData)
ElseIf Mid(strData, 3, 4) = "PLAC" Then
rstData![Marriage Location] = GetGenData(strData)
End If
End Select
End Select
End If
Loop
rstData.Update
End Select
rstData.Close
Set rstData = Nothing
conGen.Close
Set conGen = Nothing
End Sub
Function GetGEDNumber(GED As String) As String
GetGEDNumber = Mid(GED, InStr(1, GED, "@") + 1, InStrRev(GED, "@") - InStr(1,
GED, "@") - 1)
End Function
Function GetGenData(Data As String) As String
GetGenData = Replace(Replace(Right(Data, Len(Data) - 7), Chr(13), ""),
Chr(10), "")
End Function
我的代码中是否遗漏了这一部分？如果是这样，我需要用什么来替换它？
rstData.Close
Set rstData = Nothing
conGen.Close
Set conGen = Nothing
内存问题可能是未使用 Using...End Using 的结果。 .net 中的变量是垃圾收集的。这是托管代码 - 读取托管内存。当对象使用非托管资源时就会出现问题。为了清理这些资源，这些对象实现了 IDisposable，因此它们将具有 Dispose() 方法。如果我们未能调用 Dispose() 方法，那么非托管资源就会堆积起来并导致 "Out of Memory"。一个简单的处理方法是使用 Using...End Using.
Because of this, the Using block guarantees disposal of the
resources, no matter how you exit the block. This is true even in the
case of an unhandled exception, except SO Exception
（来自 ms 文档）
您将 Using 放在 Dim 语句的位置。
Using cn as New SqlConnection("Your connection string")
然后，当您使用完连接后，...
End Using
请注意，这是一个代码块，在其中声明的任何内容在外部都是不可见的。在块之前声明并初始化您需要的任何变量。
我编写了以下程序来读取和解析 .ged 文件（家谱数据）并将其存储在 SQLite 数据库中。该程序可以运行，但是当加载大文件时，我得到一个 "out of memory exception"。我是 Visual Basic 的新手，但似乎每个创建的 object 都存储在内存中，直到程序结束，因为随着程序运行，内存使用量增加到 4 gigs。
我找遍了，但找不到解决方案。求助！
我有一个相似的家庭和 Child class 和服务器中的潜艇 class 每个。
人Class：
Public Class Person
Public Property ID As String
Public Property personID As String
Public Property surName As String
Public Property givenName As String
Public Property sex As String
Public Property birthDate As String
Public Property birthYear As String
Public Property birthPlace As String
Public Property deathDate As String
Public Property deathYear As String
Public Property deathPlace As String
Public Property famC As String
End Class
服务器：
Public Sub AddPerson(p As Person)
Dim addPersonquery As String = "INSERT INTO Person(
ID,
PersonID,
SurName,
GivenName,
Sex,
BirthDate,
BirthPlace,
DeathDate,
DeathPlace,
FamC)
VALUES(
@ID,
@pid,
@sn,
@gn,
@se,
@bd,
@bP,
@dd,
@dp,
@fc);"
Using SqlConn As New SQLiteConnection(AMconnectionString)
Dim cmd As New SQLiteCommand(addPersonquery, SqlConn)
cmd.Parameters.AddWithValue("@ID", p.ID)
cmd.Parameters.AddWithValue("@pid", p.personID)
cmd.Parameters.AddWithValue("@sn", p.surName)
cmd.Parameters.AddWithValue("@gn", p.givenName)
cmd.Parameters.AddWithValue("@se", p.sex)
cmd.Parameters.AddWithValue("@bd", p.birthDate)
cmd.Parameters.AddWithValue("@bp", p.birthPlace)
cmd.Parameters.AddWithValue("@dd", p.deathDate)
cmd.Parameters.AddWithValue("@dp", p.deathPlace)
cmd.Parameters.AddWithValue("@fc", p.famC)
SqlConn.Open()
cmd.ExecuteNonQuery()
End Using
End Sub
主程序：
Option Strict On
Public Class GedcomParser
Dim AdamMarsServer As New Server()
Public Sub Button1_Click(sender As Object, e As EventArgs) Handles Button1.Click
AdamMarsServer.CreateDatabase()
Gedcomreader()
Close()
End Sub
Private Sub Gedcomreader()
Dim ofdbox As New OpenFileDialog()
ofdbox.Title = "Select Your FTM Gedcom file"
ofdbox.Filter = "gedcom Files|*.ged"
ofdbox.InitialDirectory = (My.Computer.FileSystem.SpecialDirectories.MyDocuments)
ofdbox.ShowDialog()
Dim fileReader As System.IO.StreamReader
fileReader = My.Computer.FileSystem.OpenTextFileReader(ofdbox.FileName)
Dim stringReader As String
Dim strRecData As String
Dim strPlaceHolder As String
Dim blnIndividual As Boolean
Dim blnFamily As Boolean
stringReader = fileReader.ReadLine()
Do While Not stringReader = ""
stringReader = fileReader.ReadLine()
strPlaceHolder = stringReader
If Strings.Left(strPlaceHolder, 1) = "0" Then
If Len(strRecData) <> 0 Then
If blnFamily Or blnIndividual Then
ParseRecord(strRecData)
'numpeople.Text = ProgressBar2.Value.ToString()
'numfam.Text = ProgressBar3.Value.ToString()
strRecData = ""
blnFamily = False
blnIndividual = False
End If
End If
Select Case Strings.Right(strPlaceHolder, 3)
Case "NDI"
blnIndividual = True
blnFamily = False
strRecData = "IND " & strPlaceHolder
'ProgressBar2.Increment(1)
Case "FAM"
blnFamily = True
blnIndividual = False
strRecData = "FAM " & strPlaceHolder
'ProgressBar3.Increment(1)
End Select
Else
If blnIndividual Or blnFamily Then
strRecData = strRecData & vbCr & strPlaceHolder
End If
End If
Loop
fileReader.Close()
MessageBox.Show("Done")
End Sub
Private Sub ParseRecord(strRecord As String)
Dim childs As New child()
Dim persons As New Person()
Dim mfamily As New Family()
Dim intPosition As Integer = 6
Dim strData As String
Dim strSubType As String
Select Case Strings.Left(strRecord, 3)
Case "IND"
Do While intPosition <> 0
intPosition = 1
intPosition = InStr(intPosition, strRecord, Chr(13))
If intPosition = 0 And Len(strRecord) > 0 Then
strData = strRecord
Else
strData = Strings.Left(strRecord, intPosition)
End If
strRecord = Strings.Right(strRecord, Len(strRecord) - intPosition)
If String.Compare(strData, 0, "IND", 0, 3) = 0 Then
persons.personID = Mid(strData, InStr(1, strData, "@") + 1,
InStrRev(strData, "@") - InStr(1, strData, "@") - 1)
childs.PersonID = Mid(strData, InStr(1, strData, "@") + 1,
InStrRev(strData, "@") - InStr(1, strData, "@") - 1)
Else
Select Case Strings.Left(strData, 1)
Case "1"
Select Case Mid(strData, 3, 4)
Case "NAME"
If Len(strData) = 7 Then
persons.surName = ""
persons.givenName = ""
Else
persons.surName = Mid(strData, InStr(1, strData, "/") + 1,
InStrRev(strData, "/") - InStr(1, strData, "/") - 1)
Dim givName = Split(strData, "/")(0)
persons.givenName = givName.Remove(0, 7)
End If
Case "BIRT"
strSubType = "BIRTH"
Case "DEAT"
strSubType = "DEATH"
Case "FAMC"
persons.famC = Mid(strData, InStr(1, strData, "@") + 1,
InStrRev(strData, "@") - InStr(1, strData, "@") - 1)
childs.familyID = Mid(strData, InStr(1, strData, "@") + 1,
InStrRev(strData, "@") - InStr(1, strData, "@") - 1)
Case "SEX "
persons.sex = Mid(strData, 7, 1)
Case Else
End Select
Case "2"
Select Case strSubType
Case "BIRTH"
If Mid(strData, 3, 4) = "DATE" Then
persons.birthDate = GetGenData(strData)
ElseIf Mid(strData, 3, 4) = "PLAC" Then
persons.birthPlace = GetGenData(strData)
End If
Case "DEATH"
If Mid(strData, 3, 4) = "DATE" Then
persons.deathDate = GetGenData(strData)
ElseIf Mid(strData, 3, 4) = "PLAC" Then
persons.deathPlace = GetGenData(strData)
End If
Case Else
End Select
End Select
End If
Loop
AdamMarsServer.AddPerson(persons)
AdamMarsServer.Addchild(childs)
Case "FAM"
Do While intPosition <> 0
intPosition = 1
intPosition = InStr(intPosition, strRecord, Chr(13))
If intPosition = 0 And Len(strRecord) > 0 Then
strData = strRecord
Else
strData = Strings.Left(strRecord, intPosition)
End If
strRecord = Strings.Right(strRecord, Len(strRecord) - intPosition)
If String.Compare(strData, 0, "FAM", 0, 3) = 0 Then
mfamily.FamilyID = Mid(strData, InStr(1, strData, "@") + 1,
InStrRev(strData, "@") - InStr(1, strData, "@") - 1)
Else
Select Case Strings.Left(strData, 1)
Case "1"
Select Case Mid(strData, 3, 4)
Case "HUSB"
mfamily.HusbandID = Mid(strData, InStr(1, strData, "@") + 1,
InStrRev(strData, "@") - InStr(1, strData, "@") - 1)
Case "WIFE"
mfamily.WifeID = Mid(strData, InStr(1, strData, "@") + 1,
InStrRev(strData, "@") - InStr(1, strData, "@") - 1)
Case "MARR"
strSubType = "Marriage"
Case Else
End Select
Case "2"
Select Case strSubType
Case "Marriage"
If Mid(strData, 3, 4) = "DATE" Then
mfamily.MarriageDate = GetGenData(strData)
ElseIf Mid(strData, 3, 4) = "PLAC" Then
mfamily.MarriagePlace = GetGenData(strData)
End If
Case Else
End Select
End Select
End If
Loop
AdamMarsServer.AddFamily(mfamily)
End Select
End Sub
Function GetGEDNumber(GED As String) As String
GetGEDNumber = Mid(GED, InStr(1, GED, "@") + 1, InStrRev(GED, "@") - InStr(1, GED, "@") - 1)
End Function
Function GetGenData(Data As String) As String
GetGenData = Replace(Replace(Strings.Right(Data, Len(Data) - 7), Chr(13), ""), Chr(10), "")
End Function
结束Class
这是从这个 VBA 程序中添加的：
Sub ImportGED(strFullFileName As String)
Dim fso As New Scripting.FileSystemObject
Dim filGED As Scripting.File
Dim txsGED As Scripting.TextStream
Dim strLine As String
Dim strRecData As String
Dim strPlaceHolder As String
Dim blnIndividual As Boolean
Dim blnFamily As Boolean
Dim strSubType As String
Screen.MousePointer = ccHourglass
Set filGED = fso.GetFile(strFullFileName)
Set txsGED = filGED.OpenAsTextStream(ForReading, TristateUseDefault)
Do While Not txsGED.AtEndOfStream
If Form_GetGEDFile.ProgressBar2.Value < 25 Then
Form_GetGEDFile.ProgressBar2.Value = Form_GetGEDFile.ProgressBar2.Value + 1
Else
Form_GetGEDFile.ProgressBar2.Value = 1
End If
Form_GetGEDFile.Repaint
Form_GetGEDFile.Refresh
strPlaceHolder = txsGED.ReadLine
If Left(strPlaceHolder, 1) = "0" Then
If Len(strRecData) <> 0 Then
If blnFamily Or blnIndividual Then
ParseRecord strRecData
strRecData = ""
blnFamily = False
blnIndividual = False
End If
End If
Select Case Right(strPlaceHolder, 3)
Case "NDI"
blnIndividual = True
blnFamily = False
strRecData = "IND " & strPlaceHolder
Case "FAM"
blnFamily = True
blnIndividual = False
strRecData = "FAM " & strPlaceHolder
End Select
Else
If blnIndividual Or blnFamily Then
strRecData = strRecData & vbCr & strPlaceHolder
End If
End If
Loop
Form_GetGEDFile.ProgressBar2.Value = 25
txsGED.Close
Screen.MousePointer = ccDefault
End Sub
Sub ParseRecord(strRecord As String)
Dim conGen As New ADODB.Connection
Dim rstData As New ADODB.Recordset
Dim rstQuery As New ADODB.Recordset
Dim intPosition As Integer
Dim blnInSub As Boolean
Dim strData As String
intPosition = 1
conGen.Open Application.CurrentProject.BaseConnectionString
Select Case Left(strRecord, 3)
Case "IND"
rstData.Open "Select * FROM Individuals", conGen, adOpenKeyset, adLockPessimistic
rstData.AddNew
Do While intPosition <> 0
intPosition = 1
intPosition = InStr(intPosition, strRecord, Chr(13))
If intPosition = 0 And Len(strRecord) > 0 Then
strData = strRecord
Else
strData = Left(strRecord, intPosition)
End If
strRecord = Right(strRecord, Len(strRecord) - intPosition)
If Left(strData, 3) = "IND" Then
rstData![GED ID] = Mid(strData, InStr(1, strData, "@") + 1, InStrRev(strData, "@") - InStr(1, strData, "@") - 1)
Else
Select Case Left(strData, 1)
Case 1
Select Case Mid(strData, 3, 4)
Case "NAME"
rstData![Full Name] = Replace(GetGenData(strData), "/", "")
strSubType = "NAME"
Case "BIRT"
strSubType = "BIRTH"
Case "DEAT"
strSubType = "DEATH"
Case "FAMC"
rstData!Parents = GetGEDNumber(strData)
Case "SEX "
rstData!Sex = Mid(strData, 7, 1)
End Select
Case 2
Select Case strSubType
Case "Name"
If Mid(strData, 3, 4) = "GIVN" Then
rstData![Given Name] = GetGenData(strData)
ElseIf Mid(strData, 3, 4) = "SURN" Then
rstData!Surname = GetGenData(strData)
End If
Case "BIRTH"
If Mid(strData, 3, 4) = "DATE" Then
rstData![Birth Date] = GetGenData(strData)
ElseIf Mid(strData, 3, 4) = "PLAC" Then
rstData![Birth Location] = GetGenData(strData)
End If
Case "DEATH"
If Mid(strData, 3, 4) = "DATE" Then
rstData![Death Date] = GetGenData(strData)
ElseIf Mid(strData, 3, 4) = "PLAC" Then
rstData![Death Location] = GetGenData(strData)
End If
End Select
End Select
End If
Loop
rstData.Update
Case "FAM"
rstData.Open "Families", conGen, adOpenDynamic, adLockPessimistic
rstData.AddNew
Do While intPosition <> 0
intPosition = 1
intPosition = InStr(intPosition, strRecord, Chr(13))
If intPosition = 0 And Len(strRecord) > 0 Then
strData = strRecord
Else
strData = Left(strRecord, intPosition)
End If
strRecord = Right(strRecord, Len(strRecord) - intPosition)
If Left(strData, 3) = "FAM" Then
rstData![GED Family ID] = GetGEDNumber(strData)
Else
Select Case Left(strData, 1)
Case 1
Select Case Mid(strData, 3, 4)
Case "HUSB"
rstQuery.Open "Select ID, [GED ID] FROM Individuals Where [GED ID]='" & GetGEDNumber(strData) & "'", conGen, adOpenStatic, adLockReadOnly
rstData![Father ID] = rstQuery!ID
rstQuery.Close
Case "WIFE"
rstQuery.Open "Select ID, [GED ID] FROM Individuals Where [GED ID]='" & GetGEDNumber(strData) & "'", conGen, adOpenStatic, adLockReadOnly
rstData![Mother ID] = rstQuery!ID
rstQuery.Close
Case "MARR"
strSubType = "Marriage"
End Select
Case 2
Select Case strSubType
Case "Marriage"
If Mid(strData, 3, 4) = "DATE" Then
rstData![Marriage Date] = GetGenData(strData)
ElseIf Mid(strData, 3, 4) = "PLAC" Then
rstData![Marriage Location] = GetGenData(strData)
End If
End Select
End Select
End If
Loop
rstData.Update
End Select
rstData.Close
Set rstData = Nothing
conGen.Close
Set conGen = Nothing
End Sub
Function GetGEDNumber(GED As String) As String
GetGEDNumber = Mid(GED, InStr(1, GED, "@") + 1, InStrRev(GED, "@") - InStr(1,
GED, "@") - 1)
End Function
Function GetGenData(Data As String) As String
GetGenData = Replace(Replace(Right(Data, Len(Data) - 7), Chr(13), ""),
Chr(10), "")
End Function
我的代码中是否遗漏了这一部分？如果是这样，我需要用什么来替换它？
rstData.Close
Set rstData = Nothing
conGen.Close
Set conGen = Nothing
内存问题可能是未使用 Using...End Using 的结果。 .net 中的变量是垃圾收集的。这是托管代码 - 读取托管内存。当对象使用非托管资源时就会出现问题。为了清理这些资源，这些对象实现了 IDisposable，因此它们将具有 Dispose() 方法。如果我们未能调用 Dispose() 方法，那么非托管资源就会堆积起来并导致 "Out of Memory"。一个简单的处理方法是使用 Using...End Using.
Because of this, the Using block guarantees disposal of the resources, no matter how you exit the block. This is true even in the case of an unhandled exception, except SO Exception
（来自 ms 文档）
您将 Using 放在 Dim 语句的位置。
Using cn as New SqlConnection("Your connection string")
然后，当您使用完连接后，...
End Using
请注意，这是一个代码块，在其中声明的任何内容在外部都是不可见的。在块之前声明并初始化您需要的任何变量。