Results 1 to 1 of 1
  1. #1
    Lurker
    Join Date
    Jun 2013
    Posts
    1
    Thanks
    0
    Thanked 0 Times in 0 Posts

    Unhappy Vb-access runtime error 3001

    VB-ACCESS RUNTIME ERROR 3001
    ________________________________________
    DEAR SIR,

    I AM A STUDENT IN VISUAL BASIC.I AM TRYING TO INSERT IMAGE ON VB FORM(GETCHUNK--METHOD),IT IS SUCCESSFULLY SAVED AND TRYING TO RETRIEVE IN SAME TIME ITS OK AND TRYING TO EDIT THAT FORM AND TRYING TO SAVE,ITS WORKING BUT CREATE A SAME ANOTHER ENTRY ON DATABASE.BUT IF I CLOSED THAT APPLICATION,BUT AFTER RE-LOGIN, ITS NOT RETRIVING.AT THAT TIME SHOW ERROR MESSAGE ----(RUN-TIME ERROR-3001 ARGUMENTS ARE OF THE WRONG TYPE,ARE OUT OF ACCEPTABLE RANGE,OR ARE IN CONFLICT WITH ONE ANOTHER)--- .I CHECK THE DEBUG,SHOW ERROR---------pictData() = rsEMP("Photo").GetChunk(leftOverData),ON
    Private Sub ReadPictureData()---I AM ALSO ATTACHED MY SOURCE CODE.CAN U PLS ANSWER MY REQUEST.

    REGARDS
    BOBY KURIAKOSE

    -----------------------------

    Code:
    Option Explicit
    
    Const BLOCK_SIZE As Long = 100000 'bytes
    
    Dim cnnEmp As ADODB.Connection
    Dim rsEMP As ADODB.Recordset
    
    Dim fileSize As Long
    Dim fileName As String
    Dim rs As New ADODB.Recordset
    Dim rs1 As New ADODB.Recordset
    Dim rs2 As New ADODB.Recordset
    Dim rs3 As New ADODB.Recordset
    Dim rs4 As New ADODB.Recordset
    Dim rs5 As New ADODB.Recordset
    Dim i As Integer
    Dim s As String
    Dim sql As String
    
    
    
    Private Sub cmdadd_Click()
    
    txtbalamt.Text = "0"
    sql = "select max(regno) as rn from studentdetails"
    If rs1.State Then
    rs1.Close
    End If
    rs1.Open sql, cn, adOpenKeyset, adLockOptimistic
    If rs1.RecordCount = 0 Then
    txtregno.Text = "1"
    Else
    txtregno.Text = Int(rs1.Fields("rn")) + 1
    End If
    t
    
    Private Sub cmdsearch_Click()
    MSFlexGrid1.Rows = 1
    MSFlexGrid1.Visible = True
    If rs5.State Then
    rs5.Close
    End If
    
    i = 1
    MSFlexGrid1.TextMatrix(0, 0) = "RegNo"
    MSFlexGrid1.TextMatrix(0, 1) = "NAME"
    If Optname.Value = True Then
    sql = "select * from studentdetails where name like '" & "%" & Trim(txtsrchname.Text) & "%" & "'"
    rs5.Open sql, cn, adOpenKeyset, adLockOptimistic
    While Not rs5.EOF
    MSFlexGrid1.Rows = MSFlexGrid1.Rows + 1
    MSFlexGrid1.TextMatrix(i, 0) = rs5.Fields!RegNo
    MSFlexGrid1.TextMatrix(i, 1) = rs5.Fields!Name
    
    rs5.MoveNext
    i = i + 1
    
    Wend
    End If
    
    
    Private Sub Form_Load()
    
    Optname.Value = True
    txtsrchname.Enabled = True
    cmddelete.Enabled = False
    cmdadd.Enabled = True
    cmdedit.Enabled = False
    cmdsave.Enabled = False
    cmdsearch.Enabled = True
    MSFlexGrid1.ColWidth(0) = 0
    MSFlexGrid1.Visible = False
    
    
    
    DTPlearto.Enabled = False
    Set cnnEmp = New ADODB.Connection
    Set rsEMP = New ADODB.Recordset
    
    'Open the Database connection
    With cnnEmp
    .Provider = "microsoft.jet.oledb.4.0"
    .CursorLocation = adUseClient
    .Open App.Path & "\data.mdb"
    End With
    
    ' Open the EMP table.
    Dim sSQL As String
    sSQL = "select * " & _
    " from studentdetails"
    
    With rsEMP
    .CursorType = adOpenKeyset
    .LockType = adLockOptimistic
    .Open sSQL, cnnEmp
    End With
    
    ClearFields
    
    End Sub
    
    
    
    
    Private Sub ClearFields()
    
    Dim con As Control
    
    For Each con In Controls
    If TypeOf con Is TextBox Then
    con.Text = ""
    ElseIf TypeOf con Is Image Then
    con.Picture = Nothing
    End If
    Next
    
    End Sub
    
    
    
    Private Function ValidateData() As Boolean
    
    
    ValidateData = True
    'End If
    
    End Function
    
    
    
    Private Sub FillFields()
    
    Me.MousePointer = vbHourglass
    
    
    
    
    
    
    
    txtregno = "" & rsEMP("RegNo")
    txtlearnearsno = "" & rsEMP("learnersno")
    
    DTPmy3 = "" & rsEMP("mydate3")
    
    DTPmy4 = "" & rsEMP("mydate4")
    
    
    ReadPictureData
    
    Me.MousePointer = vbNormal
    
    End Sub
    
    
    Private Sub ReadPictureData()
    
    Dim diskFile As String
    diskFile = App.Path & "\temp\emp.bmp"
    
    Dim tempDir As String
    tempDir = Dir(App.Path & "\temp", vbDirectory)
    
    If tempDir = "" Then
    MkDir App.Path & "\temp"
    End If
    
    ' Delete the temp picture file.
    If Len(Dir$(diskFile)) > 0 Then
    Kill diskFile
    End If
    
    'Get the Phot size
    fileSize = rsEMP("Photo").ActualSize
    
    'Get a free file handle
    Dim destfileNum As Long
    destfileNum = FreeFile
    
    'Open the file
    Open diskFile For Binary As destfileNum
    
    'Calculate the number of blocks (100000 bytes blocks)
    Dim pictBlocks As Integer
    pictBlocks = fileSize / BLOCK_SIZE
    
    'Calculate the left over data
    Dim leftOverData As Long
    leftOverData = fileSize Mod BLOCK_SIZE
    
    'Byte array for Picture data.
    Dim pictData() As Byte
    'Get the left over data first
    pictData() = rsEMP("Photo").GetChunk(leftOverData)
    
    'write the binary picture data from a variable to disk file
    Put destfileNum, , pictData()
    
    Dim i
    
    'Now get the remaining binary picture data in Blocks of 100000
    For i = 1 To pictBlocks
    pictData() = rsEMP("Photo").GetChunk(BLOCK_SIZE)
    Put destfileNum, , pictData()
    Next i
    
    'Close the file handle
    Close destfileNum
    
    'Load the temp Picture into the Image control
    Image1.Picture = LoadPicture(App.Path & "\temp\emp.bmp")
    
    End Sub
    
    Private Sub cmdSave_Click()
    
    ' This procedure Saves the employee information to the DB.
    ' converts that Image file to a Byte array, and saves the Byte
    ' Array to the table using the Appendchunk method.
    
    'Validate the employee information
    If ValidateData = False Then
    
    Exit Sub
    
    Else
    
    Me.MousePointer = vbHourglass
    
    'Get a Free file handle
    Dim sourceFile As Integer
    sourceFile = FreeFile
    
    'Open the Photo
    Open fileName For Binary Access Read As sourceFile
    
    'Get the size of the file in bytes
    fileSize = LOF(sourceFile)
    
    If fileSize = 0 Then
    
    Close sourceFile
    
    MsgBox "Employee's Photo is invalid"
    Exit Sub
    
    Else
    
    'Calculate the number of blocks (100000 bytes blocks)
    Dim pictBlocks As Integer
    pictBlocks = fileSize / BLOCK_SIZE
    
    'Calculate the left over data
    Dim leftOverData As Long
    leftOverData = fileSize Mod BLOCK_SIZE
    
    'Byte array for Picture data.
    Dim pictData() As Byte
    ReDim pictData(leftOverData)
    
    'Reads data from an open disk file into pictData()
    Get sourceFile, , pictData()
    
    
    'Save the Employee Information
    rsEMP.AddNew
    'Appends the Left Over binary picture data to the Photo field
    'in the employee table
    rsEMP("Photo").AppendChunk pictData()
    
    ReDim pictData(BLOCK_SIZE)
    
    Dim i As Integer
    
    For i = 1 To pictBlocks
    'Read the picture data in blocks of 100000 bytes
    Get sourceFile, , pictData()
    'appends the binary picture data the Photo field
    rsEMP("Photo").AppendChunk pictData()
    Next i
    
    ' rsEMP("FirstName") = txtFName
    'rsEMP("MiddleName") = txtMName
    'rsEMP("LastName") = txtLName
    'rsEMP("SSN") = txtSSN
    'rsEMP("Notes") = txtNotes
    
    'Update the data
    
    rsEMP("RegNo") = txtregno.Text
    ELSE
    rsEMP("instamt8") = 0
    End If
    
    End If
    
    rsEMP.Update
    
    'close the file handle
    Close sourceFile
    
    End If
    
    Me.MousePointer = vbNormal
    
    'Clear the form
    ClearFields
    
    MsgBox "Students information successfully saved"
    
    End If
    
    End Sub
    
    Private Sub Image1_DblClick()
    
    ' Retrieve the picture and update the record.
    CommonDialog1.Filter = "(*.bmp;*.ico;*.gif;*.jpg)|*.bmp;*.ico;*.gif;*.jpg "
    CommonDialog1.ShowOpen
    
    fileName = CommonDialog1.fileName
    
    If fileName <> "" Then
    Set Image1.Picture = LoadPicture(fileName)
    End If
    
    End Sub
    
    'v1.1 changes
    Private Sub Image1_OLEDragOver(Data As DataObject, _
    Effect As Long, _
    Button As Integer, _
    Shift As Integer, _
    X As Single, _
    Y As Single, _
    State As Integer)
    
    'vset a drag drop effect
    If Data.GetFormat(vbCFFiles) Then
    Effect = vbDropEffectCopy And Effect
    Exit Sub
    End If
    
    Effect = vbDropEffectNone
    
    End Sub
    
    
    
    Private Sub Image1_OLEDragDrop(Data As DataObject, _
    Effect As Long, _
    Button As Integer, _
    Shift As Integer, _
    X As Single, _
    Y As Single)
    
    'if File list from Windows Explorer
    If Data.GetFormat(vbCFFiles) Then
    
    Dim vFN
    
    For Each vFN In Data.Files
    Dim fileExt As String
    
    'get the file ext
    fileExt = Mid(vFN, InStrRev(vFN, ".") + 1, Len(vFN))
    
    Select Case UCase(fileExt)
    Case "BMP", "GIF", "JPEG", "JPG", "WMF", "TIF", "PNG"
    Set Image1.Picture = LoadPicture(vFN)
    fileName = vFN
    End Select
    
    Next vFN
    
    End If
    
    End Sub
    'end of v1.1 changes
    
    Private Sub MSFlexGrid1_DblClick()
    cmdedit.Enabled = True
    cmddelete.Enabled = True
    cmdadd.Enabled = True
    cmdsave.Enabled = False
    cmdsearch.Enabled = True
    MSFlexGrid1.Visible = False
    If rs2.State Then
    rs2.Close
    End If
    
    sql = "select * from studentdetails where RegNo=" & Trim(MSFlexGrid1.TextMatrix(MSFlexGrid1.Row, 0)) & ""
    rs2.Open sql, cn, adOpenKeyset, adLockOptimistic
    If rs2.RecordCount > 0 Then
    With rs2
    
    Me.MousePointer = vbHourglass
    
    'txtFName = "" & rsEMP("FirstName")
    'txtLName = "" & rsEMP("LastName")
    'txtMName = "" & rsEMP("MiddleName")
    'txtSSN = "" & rsEMP("SSN")
    'txtNotes = "" & rsEMP("Notes")
    
    ReadPictureData
    
    Me.MousePointer = vbNormal
    
    
    
    
    txtregno = "" & rsEMP("RegNo")
    txtlearnearsno = "" & rsEMP("learnersno")
    
    
    End With
    End If
    
    End Sub
    
    Private Sub optclamt_Click()
    
    If optclamt.Value = True Then
    txtsrtyamt.Enabled = True
    DTPsrchtestdate.Enabled = False
    DTPlenvalon.Enabled = False
    DTPlenvalfrom.Enabled = False
    DTplernvalto.Enabled = False
    
    
    ElseIf Optname.Value = True Then
    txtsrchname.Enabled = True
    txtsrtyamt.Enabled = False
    DTPsrchtestdate.Enabled = False
    DTPlenvalon.Enabled = False
    DTPlenvalfrom.Enabled = False
    DTplernvalto.Enabled = False
    
    ElseIf Opttestdate.Value = True Then
    txtsrchname.Enabled = False
    txtsrtyamt.Enabled = False
    DTPsrchtestdate.Enabled = True
    DTPlenvalon.Enabled = False
    DTPlenvalfrom.Enabled = False
    DTplernvalto.Enabled = False
    ElseIf Optlenvaon.Value = True Then
    txtsrchname.Enabled = False
    txtsrtyamt.Enabled = False
    DTPsrchtestdate.Enabled = False
    txtsrtyamt.Enabled = False
    DTPlenvalon.Enabled = True
    DTPlenvalfrom.Enabled = False
    DTplernvalto.Enabled = False
    
    ElseIf Optvabt.Value = True Then
    txtsrchname.Enabled = False
    txtsrtyamt.Enabled = False
    DTPsrchtestdate.Enabled = False
    DTPlenvalon.Enabled = False
    DTPlenvalfrom.Enabled = True
    DTplernvalto.Enabled = True
    End If
    End Sub
    
    
    Private Sub Optlenvaon_Click()
    If Optname.Value = True Then
    txtsrchname.Enabled = True
    DTPsrchtestdate.Enabled = False
    DTPlenvalon.Enabled = False
    DTPlenvalfrom.Enabled = False
    DTplernvalto.Enabled = False
    
    ElseIf optclamt.Value = True Then
    txtsrtyamt.Enabled = True
    DTPsrchtestdate.Enabled = False
    DTPlenvalon.Enabled = False
    DTPlenvalfrom.Enabled = False
    DTplernvalto.Enabled = False
    
    ElseIf Opttestdate.Value = True Then
    txtsrchname.Enabled = False
    txtsrtyamt.Enabled = False
    DTPsrchtestdate.Enabled = True
    DTPlenvalon.Enabled = False
    DTPlenvalfrom.Enabled = False
    DTplernvalto.Enabled = False
    
    ElseIf Optlenvaon.Value = True Then
    txtsrchname.Enabled = False
    txtsrtyamt.Enabled = False
    DTPsrchtestdate.Enabled = False
    txtsrtyamt.Enabled = False
    DTPlenvalon.Enabled = True
    DTPlenvalfrom.Enabled = False
    DTplernvalto.Enabled = False
    
    ElseIf Optvabt.Value = True Then
    txtsrchname.Enabled = False
    txtsrtyamt.Enabled = False
    DTPsrchtestdate.Enabled = False
    DTPlenvalon.Enabled = False
    DTPlenvalfrom.Enabled = True
    DTplernvalto.Enabled = True
    End If
    End Sub
    
    Private Sub Optname_Click()
    If Optname.Value = True Then
    txtsrchname.Enabled = True
    txtsrtyamt.Enabled = False
    DTPsrchtestdate.Enabled = False
    DTPlenvalon.Enabled = False
    DTPlenvalfrom.Enabled = False
    DTplernvalto.Enabled = False
    
    ElseIf Opttestdate.Value = True Then
    txtsrchname.Enabled = False
    txtsrtyamt.Enabled = False
    DTPsrchtestdate.Enabled = True
    DTPlenvalon.Enabled = False
    DTPlenvalfrom.Enabled = False
    DTplernvalto.Enabled = False
    
    ElseIf Optlenvaon.Value = True Then
    txtsrtyamt.Enabled = False
    txtsrchname.Enabled = False
    DTPsrchtestdate.Enabled = False
    DTPlenvalon.Enabled = True
    DTPlenvalfrom.Enabled = False
    DTplernvalto.Enabled = False
    
    ElseIf Optvabt.Value = True Then
    txtsrchname.Enabled = False
    txtsrtyamt.Enabled = False
    DTPsrchtestdate.Enabled = False
    DTPlenvalon.Enabled = False
    DTPlenvalfrom.Enabled = True
    DTplernvalto.Enabled = True
    End If
    
    'ElseIf optclamt.Value = True Then
    txtsrtyamt.Enabled = True
    DTPsrchtestdate.Enabled = False
    DTPlenvalon.Enabled = False
    DTPlenvalfrom.Enabled = False
    DTplernvalto.Enabled = False
    End Sub
    
    Private Sub Opttestdate_Click()
    If Optname.Value = True Then
    txtsrchname.Enabled = True
    DTPsrchtestdate.Enabled = False
    DTPlenvalon.Enabled = False
    DTPlenvalfrom.Enabled = False
    DTplernvalto.Enabled = False
    txtsrtyamt.Enabled = False
    
    ElseIf Opttestdate.Value = True Then
    txtsrchname.Enabled = False
    DTPsrchtestdate.Enabled = True
    DTPlenvalon.Enabled = False
    DTPlenvalfrom.Enabled = False
    DTplernvalto.Enabled = False
    txtsrtyamt.Enabled = False
    
    ElseIf Optlenvaon.Value = True Then
    txtsrchname.Enabled = False
    DTPsrchtestdate.Enabled = False
    DTPlenvalon.Enabled = True
    DTPlenvalfrom.Enabled = False
    DTplernvalto.Enabled = False
    txtsrtyamt.Enabled = False
    
    ElseIf Optvabt.Value = True Then
    txtsrchname.Enabled = False
    DTPsrchtestdate.Enabled = False
    DTPlenvalon.Enabled = False
    DTPlenvalfrom.Enabled = True
    DTplernvalto.Enabled = True
    
    ElseIf optclamt.Value = True Then
    txtsrtyamt.Enabled = True
    DTPsrchtestdate.Enabled = False
    DTPlenvalon.Enabled = False
    DTPlenvalfrom.Enabled = False
    DTplernvalto.Enabled = False
    
    
    End If
    
    End Sub
    
    Private Sub Optvabt_Click()
    If Optname.Value = True Then
    txtsrchname.Enabled = True
    DTPsrchtestdate.Enabled = False
    DTPlenvalon.Enabled = False
    DTPlenvalfrom.Enabled = False
    DTplernvalto.Enabled = False
    
    ElseIf Opttestdate.Value = True Then
    txtsrchname.Enabled = False
    txtsrtyamt.Enabled = False
    DTPsrchtestdate.Enabled = True
    DTPlenvalon.Enabled = False
    DTPlenvalfrom.Enabled = False
    DTplernvalto.Enabled = False
    
    ElseIf Optlenvaon.Value = True Then
    txtsrchname.Enabled = False
    txtsrtyamt.Enabled = False
    DTPsrchtestdate.Enabled = False
    DTPlenvalon.Enabled = True
    DTPlenvalfrom.Enabled = False
    DTplernvalto.Enabled = False
    
    ElseIf Optvabt.Value = True Then
    txtsrchname.Enabled = False
    DTPsrchtestdate.Enabled = False
    DTPlenvalon.Enabled = False
    DTPlenvalfrom.Enabled = True
    DTplernvalto.Enabled = True
    txtsrtyamt.Enabled = False
    
    ElseIf optclamt.Value = True Then
    txtsrtyamt.Enabled = True
    DTPsrchtestdate.Enabled = False
    DTPlenvalon.Enabled = False
    DTPlenvalfrom.Enabled = False
    DTplernvalto.Enabled = False
    
    
    End If
    End Sub
    
    Private Sub PrintForm_Click()
    PrintForm
    End Sub
    Last edited by RetiredGeek; 2013-06-08 at 07:03. Reason: Added Code Tags to facilitate copying of code

Tags for this Thread

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •