Solved

can any one help me to make this code into an application

Posted on 2004-03-25
1
258 Views
Last Modified: 2010-04-17
hey can anyone make this coding into an application, that can be use in Oracle database. As i have only the function one is the BLOBTOFILE and another one is FILETOBLOB.

for the BLOBTOFILE right, i want it to retrieve and put into a folder and not a file. As for the FILETOBLOB is from a folder to Oracle Database.

CODING:

BLOBTOFILE:

Public Function BLOBToFile(ByVal strFullPath As String, ByRef objField As ADODB.Field, Optional ByVal bUseStream As Boolean = True, Optional ByVal lngChunkSize As Long = 8192) As Boolean
    On Error Resume Next
    Dim objStream As ADODB.Stream
    Dim intFreeFile As Integer
    Dim lngBytesLeft As Long
    Dim lngReadBytes As Long
    Dim byBuffer() As Byte

    If bUseStream Then
        Set objStream = New ADODB.Stream

        With objStream
            .Type = adTypeBinary
            .Open
            .Write objField.Value
            .SaveToFile strFullPath, adSaveCreateOverWrite
        End With

        DoEvents
        Else

            If Dir(strFullPath) <> "" Then
                Kill strFullPath
            End If
            lngBytesLeft = objField.ActualSize
            intFreeFile = FreeFile
            Open strFullPath For Binary As #intFreeFile

            Do Until lngBytesLeft <= 0
                lngReadBytes = lngBytesLeft


                If lngReadBytes > lngChunkSize Then
                    lngReadBytes = lngChunkSize
                End If
                byBuffer = objField.GetChunk(lngReadBytes)
                Put #intFreeFile, , byBuffer
                lngBytesLeft = lngBytesLeft - lngReadBytes

                DoEvents
                Loop
                Close #intFreeFile
            End If

            If Err.Number <> 0 Or Err.LastDllError <> 0 Then
                BLOBToFile = False
            Else
                BLOBToFile = True
            End If
        End Function

CODING:

FILETOBLOB:

Public Function FileToBLOB(ByVal strFullPath As String, ByRef objField As ADODB.Field, Optional ByVal bUseStream As Boolean = True, Optional ByVal lngChunkSize As Long = 8192) As Boolean
    On Error Resume Next
    Dim objStream As ADODB.Stream
    Dim intFreeFile As Integer
    Dim lngBytesLeft As Long
    Dim lngReadBytes As Long
    Dim byBuffer() As Byte
    Dim varChunk As Variant


    If bUseStream Then
        Set objStream = New ADODB.Stream


        With objStream
            .Type = adTypeBinary
            .Open
            .LoadFromFile strFullPath
            objField.Value = .Read(adReadAll)
        End With
    Else


        With objField
            '<<--If the field does not support
            '     Long Binary data'-->>
            '<<--then we cannot load the data
            '     into the field.-->>


            If (.Attributes And adFldLong) <> 0 Then
                intFreeFile = FreeFile
                Open strFullPath For Binary Access Read As #intFreeFile
                lngBytesLeft = LOF(intFreeFile)


                Do Until lngBytesLeft <= 0


                    If lngBytesLeft > lngChunkSize Then
                        lngReadBytes = lngChunkSize
                    Else
                        lngReadBytes = lngBytesLeft
                    End If
                    ReDim byBuffer(lngReadBytes)
                    Get #intFreeFile, , byBuffer()
                    objField.AppendChunk byBuffer()
                    lngBytesLeft = lngBytesLeft - lngReadBytes


                    DoEvents
                    Loop
                    Close #intFreeFile
                Else
                    Err.Raise -10000, "FileToBLOB", "The Database Field does Not support Long Binary Data."
                End If
            End With
        End If
       


        If Err.Number <> 0 Or Err.LastDllError <> 0 Then
            FileToBLOB = False
        Else
            FileToBLOB = True
        End If
    End Function
=====
END
=====

these are the two functions i have...hope anyone kind enough to help make into an application...

peacer3434
0
Comment
Question by:peacer3434
1 Comment
 

Accepted Solution

by:
ahxing83 earned 400 total points
ID: 10683999
try this i have help you amend the code you have stated earlier:

Private Sub btnGetImages_Click()

    On Error Resume Next
    Dim objConn As New ADODB.Connection
    Dim objRs As New ADODB.Recordset
    Dim strFullPath As String
    strFullPath = App.Path & "\img\"
    Dim arrImgData() As Byte
    Dim strImageName As String
    Dim i As Integer
    Dim conn As String

    conn = "Provider=MSDAORA;Password=sitcro;User ID=crosit;Data Source=Crot3;Locale Identifier=1033"
    objConn.Open conn

If objConn.State <> 1 Then
    MsgBox "Unable to connect to Oracle!", vbInformation
Else
    MsgBox "Connected to Oracle!", vbInformation
End If

    objRs.Open "select * from TB_PHOTO_CONTENT", conn
    On Error Resume Next
    If Dir(strFullPath) = "" Then
        MkDir strFullPath
    End If

    'position the recordset on the first recordset

    'Do While Not objRs.EOF
    For i = 1 To 1
    objRs.MoveFirst
         'Read the record from the database
        strImageName = objRs("PHOTO_SERIAL_NO")
               
        Set objstream = New ADODB.Stream
        With objstream
            .Type = adTypeBinary
            .Open
            .Write objRs.Fields("IMAGE").Value
            .SaveToFile strFullPath, adToSaveCreateOverWrite
        End With
        'create the file
        'Open strFullPath & strImageName For Binary As #1
        'arrImgData = objRs("IMAGE").GetChunk(objRs("IMAGE").ActualSize)
        'Write to the file
        'Put #1, , arrImgData
        'Close #1
        'MsgBox "Done"
        'move on the next record
        objRs.MoveNext
    Next
    'Loop
    MsgBox "Done"
   
    RetrieveAllImagesFrm.Hide

End Sub

Private Sub close_Click()
RetrieveAllImagesFrm.Hide

End Sub

Private Sub UpdateAllImages_Click()
    'Ignore this code its for adding images in the DB
    Dim strFile As String
    Dim files As New Collection
    Dim file As Variant
    Dim pattern As String
    Dim pic As StdPicture
    Dim relocal As New ADODB.Recordset


    strFile = App.Path & "\img\"
    pattern = "*.jpg"
   
    Set files = getFilesInDirectory(strFile, pattern)
   
        For Each file In files
        'Set pic = LoadPicture(strFile & file)
        relocal.CursorLocation = adUseClient
        relocal.Open "Select * From TB_PHOTO_CONTENT where PHOTO_SERIAL_NO like '" & file & "'", con, adOpenDynamic, adLockOptimistic
        With relocal
        GetPhoto Path & file, relocal, "IMAGE"
        .Update
        End With
        relocal.close
   
    Next file
    MsgBox "Images Updated"
   
    RetrieveAllImagesFrm.Hide
End Sub
0

Featured Post

Threat Intelligence Starter Resources

Integrating threat intelligence can be challenging, and not all companies are ready. These resources can help you build awareness and prepare for defense.

Join & Write a Comment

Suggested Solutions

Title # Comments Views Activity
add text to end of existing text in file 16 62
count7 challenge 12 70
Scripting vs. Programming languages 25 117
recursion example 16 70
Whether you've completed a degree in computer sciences or you're a self-taught programmer, writing your first lines of code in the real world is always a challenge. Here are some of the most common pitfalls for new programmers.
Whether you’re a college noob or a soon-to-be pro, these tips are sure to help you in your journey to becoming a programming ninja and stand out from the crowd.
An introduction to basic programming syntax in Java by creating a simple program. Viewers can follow the tutorial as they create their first class in Java. Definitions and explanations about each element are given to help prepare viewers for future …
In this fifth video of the Xpdf series, we discuss and demonstrate the PDFdetach utility, which is able to list and, more importantly, extract attachments that are embedded in PDF files. It does this via a command line interface, making it suitable …

746 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

8 Experts available now in Live!

Get 1:1 Help Now