VB6 builk uploading images to Oracle database

Recently I found myself in a situation where I should migrate a lot of existing images into a Oracle database. The web frontend was in place for uploading images  and also for streaming images back to the client. However the initial number of images to upload was very large (10K+ images).

The solution was to create a small program that could do this for me.

The destination data base in question that were to hold the images already defined image categories and subcategories, so the application needed to support this.

So the first thing we do on form load is to retrieve the categories and subcategories from the data base and display them as combo boxes.

Private Sub Form_Load()
    Dim cn2 As ADODB.Connection
    Dim rst As ADODB.Recordset, rst2 As ADODB.Recordset
    
    Set cn = New ADODB.Connection
    cn.Open (strConnection)
    
    Set cn2 = New ADODB.Connection
    cn2.Open (strConnection)
    
    Set rst = cn.Execute("SELECT category_group_id, CATEGORY_GROUP_NAME From MEDIA_CATEGORY_GROUP order by category_group_name")
        
    rst.MoveFirst
    While Not rst.EOF
        Debug.Print rst.Fields("category_group_name").Value
        cmbCategories.AddItem rst.Fields("category_group_name").Value
        cmbCategories.ItemData(cmbCategories.NewIndex) = "-1"
   
        Set rst2 = cn.Execute("SELECT category_id, CATEGORY From MEDIA_CATEGORY " & _
            "where category_group_id = " & rst.Fields("category_group_id").Value & " order by category")
        rst2.MoveFirst
        
        While Not rst2.EOF
            Debug.Print rst2.Fields("category").Value
            cmbCategories.AddItem rst2.Fields("category").Value
            cmbCategories.ItemData(cmbCategories.NewIndex) = rst2.Fields("category_id").Value
            
            rst2.MoveNext
        Wend
        
        rst.MoveNext
    Wend
    
    Set rst = Nothing
    Set rst2 = Nothing
    Set cn2 = Nothing
End Sub

We have some small helper methods that handle source directory for images to upload, cleaning up on form unload, and a simple prerequisites check that the user has specified the needed input

Private Sub DirList_Change()
    ' Update the file list box to synchronize with the directory list box.
    filList.Path = dirList.Path
    filList.Pattern = Me.txtSearchSpec.Text
End Sub

Private Sub DirList_LostFocus()
    dirList.Path = dirList.List(dirList.ListIndex)
End Sub

Private Sub DrvList_Change()
    On Error GoTo DriveHandler
    dirList.Path = drvList.Drive
    Exit Sub

DriveHandler:
    drvList.Drive = dirList.Path
    Exit Sub
End Sub

Private Sub Form_Unload(Cancel As Integer)
    Set cn = Nothing
    End
End Sub
Private Sub txtSearchSpec_Change()
    ' Update file list box if user changes pattern.
    filList.Pattern = txtSearchSpec.Text
End Sub

Private Sub txtSearchSpec_GotFocus()
    txtSearchSpec.SelStart = 0          ' Highlight the current entry.
    txtSearchSpec.SelLength = Len(txtSearchSpec.Text)
End Sub

Private Sub checkSettings()
    ' If media category has not been chosen
    If Me.cmbCategories.ListIndex = -1 Then
        Err.Raise 10000, , "You must select a media category to upload to!"
    ElseIf Me.cmbCategories.ListIndex > -1 And Me.cmbCategories.ItemData(Me.cmbCategories.ListIndex) = -1 Then
        Err.Raise 10003, , "The category you have selected is not a category but a category group. Please try again but this time only select from the category listings starting with '--'"
    ElseIf Me.txtPath.Text = "" Or Right(Me.txtPath.Text, 1) <> "\" Then
        Err.Raise 10001, , "You must specify a path to the directory on the webserver " & _
                         "in which you want to save the media files, the path must end with a '\' (backslash)"
    ElseIf Me.filList.ListCount = 0 Then
        Err.Raise 10002, , "There was no files with the extensions " & Me.txtSearchSpec.Text & " in the chosen directory. No media files where uploaded. "
    End If
End Sub

Finally we have the method that is invoked when the user is actually uploading the images to the database

Private Sub cmdUpload_Click()
    Dim x As Long
    Dim rst As ADODB.Recordset, rst2 As ADODB.Recordset
    Dim fs As FileSystemObject, f As File
    Dim mime As String, orgFilePath As String, orgFile As String
    Dim catID As Long, media_id As Long, fileSize As Long
    
    On Error GoTo Error_Handler
    
    Call checkSettings
    
    Set rst = New ADODB.Recordset
    rst.Open "media_elements", cn, adOpenDynamic, adLockOptimistic, adCmdTable
    
    ' Update dirList.Path if it is different from the currently
    ' selected directory, otherwise perform the search.
    If dirList.Path <> dirList.List(dirList.ListIndex) Then
        dirList.Path = dirList.List(dirList.ListIndex)
        
        ' Exit so user can take a look before searching.
        Exit Sub
    End If

    filList.Pattern = txtSearchSpec.Text
    filList.Path = dirList.Path
    
    ' Used so we are able to get the nextid value form the sequence
    Set rst2 = New ADODB.Recordset
    
    ' USed so we can get the file size
    Set fs = New FileSystemObject
    
    ' Loop through all the found files in the selected diretory
    
    frmUpload.Show
    x = 0
    
    
    While x <= filList.ListCount - 1
        orgFilePath = filList.Path & "\" & filList.List(x)
        frmUpload.lblUpload.Caption = orgFilePath
        frmUpload.Refresh
        
        ' Get nextval from sequence
        Set rst2 = cn.Execute("SELECT icseq_media_elements.nextval as id from dual")
        media_id = rst2.Fields("id").Value
        catID = cmbCategories.ItemData(cmbCategories.ListIndex)
        
        ' Is the mime type jpg or gif?
        orgFile = filList.List(x)
        If InStr(1, orgFile, ".jpg") > 0 Then
            mime = "image/jpg"
        ElseIf InStr(1, orgFile, ".gif") > 0 Then
            mime = "image/gif"
        Else
            mime = ""
        End If
        
        ' Get the file size
        Set f = fs.GetFile(orgFilePath)
        fileSize = f.Size
        
        ' Insert new record
        With rst
            .AddNew
            !media_id = media_id
            Call FileToBlob(rst.Fields("media"), orgFilePath)
            !mime_type = mime
            !org_file_name = orgFile
            !file_size = fileSize
            !Description = "Inserted by media bulk upload tool"
            !category_id = catID
            !user_created = "BULKUPLOAD"
            !date_created = Now()
            !user_changed = "BULKUPLOAD"
            !date_changed = Now()
            .Update
        End With
        
        ' Copy the file
        fs.CopyFile orgFilePath, txtPath & media_id & "." & fs.GetExtensionName(filList.Path & "\" & filList.List(x))
        
        Debug.Print "Copying: " & filList.Path & "\" & filList.List(x) & " -> " & Me.txtPath.Text & rst2.Fields("id").Value & "." & fs.GetExtensionName(filList.Path & "\" & filList.List(x))
        
        x = x + 1
    Wend
    frmUpload.Hide
    Exit Sub

Error_Handler:
    MsgBox (Err.Description)
    Exit Sub
    
End Sub

And the helper method that does the heavy lifting with regards to loading the bytes from the file into the vb record.

Sub FileToBlob(fld As ADODB.Field, filename As String, _
    Optional ChunkSize As Long = 8192)
    Dim fnum As Integer, bytesLeft As Long, bytes As Long
    Dim tmp() As Byte
    
    ' Raise an error if the field doesn't support GetChunk.
    If (fld.Attributes And adFldLong) = 0 Then
        Err.Raise 1001, , "Field doesn't support the GetChunk method."
    End If
    ' Open the file; raise an error if the file doesn't exist.
    If Dir$(filename) = "" Then Err.Raise 53, , "File not found"
    
    fnum = FreeFile
    Open filename For Binary As fnum
    ' Read the file in chunks, and append data to the field.
    bytesLeft = LOF(fnum)
    Do While bytesLeft
        bytes = bytesLeft
        If bytes > ChunkSize Then bytes = ChunkSize
        ReDim tmp(1 To bytes) As Byte
        Get #1, , tmp
        fld.AppendChunk tmp
        bytesLeft = bytesLeft - bytes
    Loop
    
    Close #fnum
End Sub