Question Can anyone help me convert this module code from VB6 ?

[alexgiurca]

Hy!

Can anyone PLEASE help me to convert this code from VB 6.0 to VB.NET? The code is a module which can be used to read / import pictures and other OLE Object's from Excel to any other database. The code works flawlessly in VB 6 / VBA.

The code will need to be put into a Module in VB.NET. The type will be converted into a STRUCTURE, and ADODB/Excel references have to be added to the project (this is what I've figured so far).

Option Explicit

Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Integer) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function CopyImage Lib "user32" (ByVal hImage As Long, ByVal uType As Long, ByVal PixelWidth As Long, ByVal PixelHeight As Long, ByVal Flags As Long) As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (pPictDesc As PictDesc, riid As Guid, ByVal fOwn As Long, ppvObj As IPicture) As Long

Type Guid
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
End Type
        
Type PictDesc
    cbSizeofStruct As Long
    picType As Long
    hImage As Long
    xExt As Long
    yExt As Long
End Type

Private Const BLOCK_SIZE = 16384
Private Const CF_BITMAP = 2
Private Const S_OK As Long = &H0
Private Const LR_COPYRETURNORG = &H4

Function IPictureFromCopyPicture(Source As Object, Optional StretchWidth As Single, Optional StretchHeight As Single) As IPictureDisp
    Dim hBmp As Long
    Dim PictDesc As PictDesc
    Dim IDispatch As Guid
    Dim SaveWidth As Single
    Dim SaveHeight As Single
    Dim PicIsRng As Boolean
       
    If StretchWidth <> 0 Or StretchHeight <> 0 Then
        If TypeOf Source Is Range Then
            Source.CopyPicture
            ActiveSheet.PasteSpecial "Picture (Enhanced Metafile)"
            Set Source = Selection
            PicIsRng = True
        End If
        
        SaveWidth = Source.Width
        SaveHeight = Source.Height
        Source.Width = IIf(StretchWidth = 0, Source.Width, StretchWidth)
        Source.Height = IIf(StretchHeight = 0, Source.Height, StretchHeight)
        Source.CopyPicture xlScreen, xlBitmap
        
        If PicIsRng Then
            Source.Delete
        Else
            Source.Width = SaveWidth
            Source.Height = SaveHeight
        End If
    Else
        Source.CopyPicture xlScreen, xlBitmap
    End If

    If OpenClipboard(0) <> 0 Then
        hBmp = GetClipboardData(CF_BITMAP)
        hBmp = CopyImage(hBmp, 0, 0, 0, LR_COPYRETURNORG)
        CloseClipboard
        If hBmp <> 0 Then
                  
            With IDispatch
               .Data1 = &H20400
               .Data4(0) = &HC0
               .Data4(7) = &H46
            End With
            
            With PictDesc
               .cbSizeofStruct = Len(PictDesc)
               .picType = 1
               .hImage = hBmp
            End With
            
            If OleCreatePictureIndirect(PictDesc, IDispatch, False, IPictureFromCopyPicture) <> S_OK Then
                Set IPictureFromCopyPicture = Nothing
            End If
        End If
    End If
End Function

Function SaveObjectPictureToFile(ByVal Source As Object, FileName As String, Optional StretchWidth As Single, Optional StretchHeight As Single) As Boolean
    Dim Ipic As IPictureDisp
    
    Set Ipic = IPictureFromCopyPicture(Source, StretchWidth, StretchHeight)
    If Not Ipic Is Nothing Then
        SavePicture Ipic, FileName
        SaveObjectPictureToFile = True
    End If
End Function


      Sub BlobToFile(fld As ADODB.Field, ByVal FName As String, _
                     Optional FieldSize As Long = -1, _
                     Optional Threshold As Long = 1048576)
      '
      ' Assumes file does not exist
      ' Data cannot exceed approx. 2Gb in size
      '
      Dim F As Long, bData() As Byte, sData As String
        F = FreeFile
        Open FName For Binary As #F
        Select Case fld.Type
          Case adLongVarBinary
            If FieldSize = -1 Then   ' blob field is of unknown size
              WriteFromUnsizedBinary F, fld
            Else                     ' blob field is of known size
              If FieldSize > Threshold Then   ' very large actual data
                WriteFromBinary F, fld, FieldSize
              Else                            ' smallish actual data
                bData = fld.Value
                Put #F, , bData  ' PUT tacks on overhead if use fld.Value
              End If
            End If
          Case adLongVarChar, adLongVarWChar
            If FieldSize = -1 Then
              WriteFromUnsizedText F, fld
            Else
              If FieldSize > Threshold Then
                WriteFromText F, fld, FieldSize
              Else
                sData = fld.Value
                Put #F, , sData  ' PUT tacks on overhead if use fld.Value
              End If
            End If
        End Select
        Close #F
      End Sub

      Sub WriteFromBinary(ByVal F As Long, fld As ADODB.Field, _
                          ByVal FieldSize As Long)
      Dim data() As Byte, BytesRead As Long
        Do While FieldSize <> BytesRead
          If FieldSize - BytesRead < BLOCK_SIZE Then
            data = fld.GetChunk(FieldSize - BLOCK_SIZE)
            BytesRead = FieldSize
          Else
            data = fld.GetChunk(BLOCK_SIZE)
            BytesRead = BytesRead + BLOCK_SIZE
          End If
          Put #F, , data
        Loop
      End Sub

      Sub WriteFromUnsizedBinary(ByVal F As Long, fld As ADODB.Field)
      Dim data() As Byte, Temp As Variant
        Do
          Temp = fld.GetChunk(BLOCK_SIZE)
          If IsNull(Temp) Then Exit Do
          data = Temp
          Put #F, , data
        Loop While LenB(Temp) = BLOCK_SIZE
      End Sub

      Sub WriteFromText(ByVal F As Long, fld As ADODB.Field, _
                        ByVal FieldSize As Long)
      Dim data As String, CharsRead As Long
        Do While FieldSize <> CharsRead
          If FieldSize - CharsRead < BLOCK_SIZE Then
            data = fld.GetChunk(FieldSize - BLOCK_SIZE)
            CharsRead = FieldSize
          Else
            data = fld.GetChunk(BLOCK_SIZE)
            CharsRead = CharsRead + BLOCK_SIZE
          End If
          Put #F, , data
        Loop
      End Sub

      Sub WriteFromUnsizedText(ByVal F As Long, fld As ADODB.Field)
      Dim data As String, Temp As Variant
        Do
          Temp = fld.GetChunk(BLOCK_SIZE)
          If IsNull(Temp) Then Exit Do
          data = Temp
          Put #F, , data
        Loop While Len(Temp) = BLOCK_SIZE
      End Sub

      Sub FileToBlob(ByVal FName As String, fld As ADODB.Field, _
                     Optional Threshold As Long = 1048576)
      '
      ' Assumes file exists
      ' Assumes calling routine does the UPDATE
      ' File cannot exceed approx. 2Gb in size
      '
      Dim F As Long, data() As Byte, FileSize As Long
        F = FreeFile
        Open FName For Binary As #F
        FileSize = LOF(F)
        Select Case fld.Type
          Case adLongVarBinary
            If FileSize > Threshold Then
              ReadToBinary F, fld, FileSize
            Else
              data = InputB(FileSize, F)
              fld.Value = data
            End If
          Case adLongVarChar, adLongVarWChar
            If FileSize > Threshold Then
              ReadToText F, fld, FileSize
            Else
              fld.Value = Input(FileSize, F)
            End If
        End Select
        Close #F
      End Sub

      Sub ReadToBinary(ByVal F As Long, fld As ADODB.Field, _
                       ByVal FileSize As Long)
      Dim data() As Byte, BytesRead As Long
        Do While FileSize <> BytesRead
          If FileSize - BytesRead < BLOCK_SIZE Then
            data = InputB(FileSize - BytesRead, F)
            BytesRead = FileSize
          Else
            data = InputB(BLOCK_SIZE, F)
            BytesRead = BytesRead + BLOCK_SIZE
          End If
          fld.AppendChunk data
        Loop
      End Sub

      Sub ReadToText(ByVal F As Long, fld As ADODB.Field, _
                     ByVal FileSize As Long)
      Dim data As String, CharsRead As Long
        Do While FileSize <> CharsRead
          If FileSize - CharsRead < BLOCK_SIZE Then
            data = Input(FileSize - CharsRead, F)
            CharsRead = FileSize
          Else
            data = Input(BLOCK_SIZE, F)
            CharsRead = CharsRead + BLOCK_SIZE
          End If
          fld.AppendChunk data
        Loop
      End Sub