help with code to remove lines

I have this code that removes all blank lines but I was wondering if there was a way to code this to only delete blank lines if there are more then 1 blank lines.

so if my text looks like this

   
abc



def






ghi

it will look like this after

abc

def

ghi

this is the code

Const ForReading = 1
Const ForWriting = 2

Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFile = objFSO.OpenTextFile(Filename, ForReading)

Do Until objFile.AtEndOfStream
   strLine = objFile.Readline
   strLine = Trim(strLine)
    If Len(strLine) > 0 Then
        strNewContents = strNewContents & strLine & vbCrLf
        
End If

Loop

objFile.Close
Set objFile = objFSO.OpenTextFile(Filename, ForWriting)
objFile.Write strNewContents
objFile.Close