Solved

Needing Code to Automate Insert/Link OLE Object

Posted on 2004-03-30
12
878 Views
Last Modified: 2008-02-01
In my current db, there is a need to insert some pictures and I would like to simply the process with the use of some VB vice someone right-clicking->finding the file->inserting.

What I am looking is to Add/Edit linking a file (.jpg) into an OLE Object field.

And Possibly beable to test the file name typed in by the user as an existing file in the current designated folder.

Summary: Basically the user would enter the file name into an unbound field, and execute a command that would test for the file existence and then link the file to the current record.

Thanks much... Stephen Out.
0
Comment
Question by:snoble
  • 6
  • 4
  • 2
12 Comments
 
LVL 4

Expert Comment

by:goliak
ID: 10715082
Here is the solution. But don't even try to understand this code. Just insert it in a Module. To open an OpenFile Dialog use this construction.

Dim OFN As MSA_OPENFILENAME
   On Error GoTo cmdPath_Click_Error
OFN.strFilter = MSA_CreateFilterString("JPEG files", "*.jpg", "All files", "*.*")
If MSA_GetOpenFileName(OFN) = 0 Then End
txtFoto = OFN.strFullPathReturned

The next code place in Module.
-----------------------------------------------------------------------------------------------------------

Declare Function GetOpenFileName Lib "comdlg32.dll" Alias _
    "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Boolean
Declare Function GetSaveFileName Lib "comdlg32.dll" Alias _
    "GetSaveFileNameA" (pOpenfilename As OPENFILENAME) As Boolean
   
Public strFileName As String

Type MSA_OPENFILENAME
    ' Filter string used for the Open dialog filters.
    ' Use MSA_CreateFilterString() to create this.
    ' Default = All Files, *.*
    strFilter As String
    ' Initial Filter to display.
    ' Default = 1.
    lngFilterIndex As Long
    ' Initial directory for the dialog to open in.
    ' Default = Current working directory.
    strInitialDir As String
    ' Initial file name to populate the dialog with.
    ' Default = "".
    strInitialFile As String
    strDialogTitle As String
    ' Default extension to append to file if user didn't specify one.
    ' Default = System Values (Open File, Save File).
    strDefaultExtension As String
    ' Flags (see constant list) to be used.
    ' Default = no flags.
    lngFlags As Long
    ' Full path of file picked.  When the File Open dialog box is
    ' presented, if the user picks a nonexistent file,
    ' only the text in the "File Name" box is returned.
    strFullPathReturned As String
    ' File name of file picked.
    strFileNameReturned As String
    ' Offset in full path (strFullPathReturned) where the file name
    ' (strFileNameReturned) begins.
    intFileOffset As Integer
    ' Offset in full path (strFullPathReturned) where the file extension begins.
    intFileExtension As Integer
End Type

Const ALLFILES = "All Files"

Type OPENFILENAME
    lStructSize As Long
    hwndOwner As Long
    hInstance As Long
    lpstrFilter As String
    lpstrCustomFilter As Long
    nMaxCustrFilter As Long
    nFilterIndex As Long
    lpstrFile As String
    nMaxFile As Long
    lpstrFileTitle As String
    nMaxFileTitle As Long
    lpstrInitialDir As String
    lpstrTitle As String
    Flags As Long
    nFileOffset As Integer
    nFileExtension As Integer
    lpstrDefExt As String
    lCustrData As Long
    lpfnHook As Long
    lpTemplateName As Long
End Type

Global Const OFN_ALLOWMULTISELECT = &H200
Global Const OFN_CREATEPROMPT = &H2000
Global Const OFN_EXPLORER = &H80000
Global Const OFN_FILEMUSTEXIST = &H1000
Global Const OFN_HIDEREADONLY = &H4
Global Const OFN_NOCHANGEDIR = &H8
Global Const OFN_NODEREFERENCELINKS = &H100000
Global Const OFN_NONETWORKBUTTON = &H20000
Global Const OFN_NOREADONLYRETURN = &H8000
Global Const OFN_NOVALIDATE = &H100
Global Const OFN_OVERWRITEPROMPT = &H2
Global Const OFN_PATHMUSTEXIST = &H800
Global Const OFN_READONLY = &H1
Global Const OFN_SHOWHELP = &H10

Function TextReport_LIB_FileOpen(strSearchPath, pstrFilterDesc As String, pstrFilter As String, Optional strDialogueTitle As String = "File Open") As String
' Displays the Open dialog box for the user to locate
' the Northwind database. Returns the full path to Northwind.
   
    Dim msaof As MSA_OPENFILENAME
   
    ' Set options for the dialog box.
    msaof.strDialogTitle = strDialogueTitle
    msaof.strInitialDir = strSearchPath
    msaof.strDefaultExtension = Right(pstrFilter, 3)
    msaof.strFilter = MSA_CreateFilterString(pstrFilterDesc, pstrFilter)
   
    ' Call the Open dialog routine.
    MSA_GetOpenFileName msaof
   
    ' Return the path and file name.
    TextReport_LIB_FileOpen = Trim(msaof.strFullPathReturned)
       
End Function

Function TextReport_LIB_FileSaveAs(strSearchPath As String, pstrFilterDesc As String, pstrFilter As String) As String
' Displays the Save As dialog box for the user
   
    Dim msaof As MSA_OPENFILENAME
   
    ' Set options for the dialog box.
    msaof.strDialogTitle = "Save As?"
    msaof.strInitialDir = strSearchPath
    msaof.strDefaultExtension = Right(pstrFilter, 3)
    msaof.strFilter = MSA_CreateFilterString(pstrFilterDesc, pstrFilter)
   
    ' Call the Open dialog routine.
    MSA_GetSaveFileName msaof
   
    ' Return the path and file name.
    TextReport_LIB_FileSaveAs = Trim(msaof.strFullPathReturned)
   
End Function

Function MSA_CreateFilterString(ParamArray varFilt() As Variant) As String
' Creates a filter string from the passed in arguments.
' Returns "" if no argumentss are passed in.
' Expects an even number of argumentss (filter name, extension), but
' if an odd number is passed in, it appends "*.*".
   
    Dim strFilter As String
    Dim intRet As Integer
    Dim intNum As Integer

    intNum = UBound(varFilt)
    If (intNum <> -1) Then
        For intRet = 0 To intNum
            strFilter = strFilter & varFilt(intRet) & vbNullChar
        Next
        If intNum Mod 2 = 0 Then
            strFilter = strFilter & "*.*" & vbNullChar
        End If
       
        strFilter = strFilter & vbNullChar
    Else
        strFilter = ""
    End If

    MSA_CreateFilterString = strFilter
End Function

Private Function MSA_ConvertFilterString(strFilterIn As String) As String
' Creates a filter string from a bar ("|") separated string.
' The string should pairs of filter|extension strings, i.e. "Access Databases|*.mdb|All Files|*.*"
' If no extensions exists for the last filter pair, *.* is added.
' This code will ignore any empty strings, i.e. "||" pairs.
' Returns "" if the strings passed in is empty.

   
    Dim strFilter As String
    Dim intNum As Integer, intPos As Integer, intLastPos As Integer

    strFilter = ""
    intNum = 0
    intPos = 1
    intLastPos = 1

    ' Add strings as long as we find bars.
    ' Ignore any empty strings (not allowed).
    Do
        intPos = InStr(intLastPos, strFilterIn, "|")
        If (intPos > intLastPos) Then
            strFilter = strFilter & Mid(strFilterIn, intLastPos, intPos - intLastPos) & vbNullChar
            intNum = intNum + 1
            intLastPos = intPos + 1
        ElseIf (intPos = intLastPos) Then
            intLastPos = intPos + 1
        End If
    Loop Until (intPos = 0)
       
    ' Get last string if it exists (assuming strFilterIn was not bar terminated).
    intPos = Len(strFilterIn)
    If (intPos >= intLastPos) Then
        strFilter = strFilter & Mid(strFilterIn, intLastPos, intPos - intLastPos + 1) & vbNullChar
        intNum = intNum + 1
    End If
   
    ' Add *.* if there's no extension for the last string.
    If intNum Mod 2 = 1 Then
        strFilter = strFilter & "*.*" & vbNullChar
    End If
   
    ' Add terminating NULL if we have any filter.
    If strFilter <> "" Then
        strFilter = strFilter & vbNullChar
    End If
   
    MSA_ConvertFilterString = strFilter
End Function

Function MSA_GetSaveFileName(msaof As MSA_OPENFILENAME) As Integer
' Opens the file save dialog.
   
    Dim of As OPENFILENAME
    Dim intRet As Integer

    MSAOF_to_OF msaof, of
    of.Flags = of.Flags Or OFN_HIDEREADONLY
    intRet = GetSaveFileName(of)
    If intRet Then
        OF_to_MSAOF of, msaof
    End If
    MSA_GetSaveFileName = intRet
End Function

Function MSA_SimpleGetSaveFileName() As String
' Opens the file save dialog with default values.

    Dim msaof As MSA_OPENFILENAME
    Dim intRet As Integer
    Dim strRet As String
   
    intRet = MSA_GetSaveFileName(msaof)
    If intRet Then
        strRet = msaof.strFullPathReturned
    End If
   
    MSA_SimpleGetSaveFileName = strRet
End Function

Function MSA_GetOpenFileName(msaof As MSA_OPENFILENAME) As Integer
' Opens the Open dialog.
   
    Dim of As OPENFILENAME
    Dim intRet As Integer

    MSAOF_to_OF msaof, of
    intRet = GetOpenFileName(of)
    If intRet Then
        OF_to_MSAOF of, msaof
    End If
    MSA_GetOpenFileName = intRet

End Function

Function MSA_SimpleGetOpenFileName() As String
' Opens the Open dialog with default values.

    Dim msaof As MSA_OPENFILENAME
    Dim intRet As Integer
    Dim strRet As String
   
    intRet = MSA_GetOpenFileName(msaof)
    If intRet Then
        strRet = msaof.strFullPathReturned
    End If
   
    MSA_SimpleGetOpenFileName = strRet
   
End Function


Private Sub OF_to_MSAOF(of As OPENFILENAME, msaof As MSA_OPENFILENAME)
' This sub converts from the Win32 structure to the Microsoft Access structure.
   
    msaof.strFullPathReturned = Left(of.lpstrFile, InStr(of.lpstrFile, vbNullChar) - 1)
    msaof.strFileNameReturned = of.lpstrFileTitle
    msaof.intFileOffset = of.nFileOffset
    msaof.intFileExtension = of.nFileExtension
End Sub

Private Sub MSAOF_to_OF(msaof As MSA_OPENFILENAME, of As OPENFILENAME)
' This sub converts from the Microsoft Access structure to the Win32 structure.
   
    Dim strFile As String * 512

    ' Initialize some parts of the structure.
    of.hwndOwner = Application.hWndAccessApp
    of.hInstance = 0
    of.lpstrCustomFilter = 0
    of.nMaxCustrFilter = 0
    of.lpfnHook = 0
    of.lpTemplateName = 0
    of.lCustrData = 0
   
    If msaof.strFilter = "" Then
        of.lpstrFilter = MSA_CreateFilterString(ALLFILES)
    Else
        of.lpstrFilter = msaof.strFilter
    End If
    of.nFilterIndex = msaof.lngFilterIndex
   
    of.lpstrFile = msaof.strInitialFile _
        & String(512 - Len(msaof.strInitialFile), 0)
    of.nMaxFile = 511

    of.lpstrFileTitle = String(512, 0)
    of.nMaxFileTitle = 511

    of.lpstrTitle = msaof.strDialogTitle

    of.lpstrInitialDir = msaof.strInitialDir
   
    of.lpstrDefExt = msaof.strDefaultExtension

    of.Flags = msaof.lngFlags
   
    of.lStructSize = Len(of)
End Sub
0
 
LVL 4

Expert Comment

by:goliak
ID: 10715195
That's really works on every PC. But you can also use OpenFileName Dialog Box. It is simpler but it may not work on different PCs.

Sub GetFileFromOCX()
  Dim CDLG As Object
  Set CDLG = CreateObject("MSComDlg.CommonDialog")
  With CDLG
    .DialogTitle = "Get me a File!"
    .Filter = _
      "Documents|*.doc|Templates|*.dot|Text Files|*.txt"
    .ShowOpen
    MsgBox .FileName
  End With
  Set CDLG = Nothing
End Sub

Don't forget to set reference to C:\WINNT\System32\Comdlg32.ocx
0
 
LVL 5

Expert Comment

by:Emanon_Consulting
ID: 10715265
Hi Stephen,

Although MS Access can store .jpg images, it usually results in file bloating.  Meaning that if you were to store a small .jpg image (30-40 kb) in the database, the size of the database does not just increase by 30-40 kb it may bloat in size to an additional 385 kb + and that's for each .jpg!

If I may suggest an alternative...  (something that I have done in one of my application's to store photos)

Try storing the file path to the folder that the image is located in.

-Create a folder specifically for the .jpg's to be stored in.
-Create a text field in your app to store the file path to the .jpg (255 characters)
-Then Using an Image frame on the form you can set the properties to link the Picture to the file path stored in your app.

Here's a link to a MS Article that covers the Bloating effect of storing images and how to store the file path to the image instead.
http://support.microsoft.com/default.aspx?scid=kb;en-us;285820&Product=acc2003

And here is a link to Alan Warrens web site that gives another alternative.  Alan prefers to use Binary Long Objects (Blob’s).
http://www.cashoz.com/samples/blobs.asp
(Note to Alan Warren if you are reading this...  I hope you don't mind I shared your info!)

Good luck
Cheers
M
0
 
LVL 1

Author Comment

by:snoble
ID: 10715468
goliak... I appreciate your code, but I don't think it is exactly what I am looking for or maybe I am missing it.

Emanon...
You are correct, I am wanting to Link in (*.jpg) files into my db possible through an OLE Object Field. I searched your 'associates' (aka Warren) and I downloaded the Blob.mdb. So I am going to play with it and see if I can't use his code.

Summary: My db has a BE and Distributed FE's to multiple user. My idea for this is to have a designated folder for all the pictures to be saved into. Then the user will create a new record, and then Open/Find the file to link into the record.

0
 
LVL 5

Expert Comment

by:Emanon_Consulting
ID: 10715657
Hi Stephen,

I believe that Alan's appraoch is more suitable for larger applications as it will store the images in the Back End of your app as "BLOB's".  (I haven't had the chance to experiment with Blob's yet)
His approach should make managing the application easier in the long run.  Also you can relocate your app and not loose all the links which could be devastating in a large app on a server.

If you want to store the file path and link to an Image control (which I have done) then I will post some more info for you in a minute or three...

Cheers
M
0
 
LVL 1

Author Comment

by:snoble
ID: 10715753
Emanon....

I am playing with the Blob but that might be more advanced then I know how to manipulate. My BE is stationary and I don't have to worry about loosing my links. So any code to store a file path and link an Image is greatly appreciated.

Thanks....
0
How to run any project with ease

Manage projects of all sizes how you want. Great for personal to-do lists, project milestones, team priorities and launch plans.
- Combine task lists, docs, spreadsheets, and chat in one
- View and edit from mobile/offline
- Cut down on emails

 
LVL 5

Accepted Solution

by:
Emanon_Consulting earned 225 total points
ID: 10715757
Hi Stephen,

Here's another useful link for you from 'The Access Web' site...
API: Call the standard Windows File Open/Save dialog box
http://www.mvps.org/access/api/api0001.htm

You can use this code to get the file path of the .jpg

On your form you can have the txtBox properties for the file path set to Visible=No.  This way the User does not see the file path.
You can use the Click or DoubleClick Event  on the Image control to call the GetOpenFile function to retrieve the file path, then add some code to set the Image controls Picture link to the new file path.

This is copied from one of my applications for storing photos of children in a Daycare Data Management App I did a while back.  Bare with my VBA as it may not be as robust as some of the other experts here.
But this should give you an idea...
Something like this...
'*************Start of Sub***************
Private Sub ChildPhoto_Click()

On Error GoTo ErrorHandler
   
    'Check to see if a file path to the photo already exists
    If IsNull(ChildPhotoPath) Then
        'If there is no file path then prompt user
        If MsgBox("There is no current photo to display.  Would you like to find a Photo now?", vbYesNo, "No current Photo") = vbNo Then
            'If user cancels then exit sub procedure
            Exit Sub
        Else
            'If user wants to retrieve a path then call procedure to get file path
            Call GetOpenFile
                'Check to see if a file path has been saved or exists
                If IsNull(ChildPhotoPath) Then
                    'If no file path then display no picture
                    ChildPhoto.Picture = ""
                Else
                    'If file path exists then display picture
                    ChildPhoto.Picture = ChildPhotoPath
                End If
        End If
    Else
        'If File path exists already then call refresh procedure
        Call RefreshPhoto
    End If
   
ErrorExit:
    Exit Sub
   
ErrorHandler:
    DoCmd.Beep
    Resume ErrorExit

End Sub

'***

Private Sub RefreshPhoto()

On Error GoTo ErrorHandler

    'Check to see if the photo has been refreshed and is displayed
    If ChildPhoto.Picture = ChildPhotoPath Then
        'If photo is already displayed then call Enlarge Photo procedure
        Call EnlargePhoto
    Else
        'If photo is not displayed then display it
        ChildPhoto.Picture = ChildPhotoPath
    End If
   
ErrorExit:
    Exit Sub

ErrorHandler:
    DoCmd.Beep
    'If there is an invalid file path then call InvalidPhotoPath procedure to fix
    Call InvalidPhotoPath
    Resume ErrorExit

End Sub

'****

Private Sub EnlargePhoto()

On Error GoTo ErrorHandler

        'Open the report to display a printable version of the current photo
        DoCmd.OpenReport "rptPhotoZoom", acViewPreview
   
ErrorExit:
    Exit Sub

ErrorHandler:
    DoCmd.Beep
    Resume ErrorExit

End Sub

'****

Private Sub InvalidPhotoPath()

On Error GoTo ErrorHandler
    'The photo directory may have been renamed, relocated or deleted and is now invalid.
    'Inform User of invalid path and option to relocate photo.
    If MsgBox("The file path to the photo is no longer valid.  The photo may have been relocated or deleted from the directory." _
    & vbCrLf & vbCrLf & "Would you like to find a Photo now?", vbYesNo, "Photo error") = vbNo Then
        'If user cancels then delete photo file path and picture display and exit sub procedure
        Me.ChildPhoto.Picture = "(none)"
        Me.ChildPhotoPath.Value = Null
        Exit Sub
    Else
        'If user wants to retrieve a path then call procedure to get file path
        Call GetOpenFile
            'Check to see if a file path has been saved or exists
            If IsNull(ChildPhotoPath) Then
                'If no file path then display no picture
                ChildPhoto.Picture = ""
            Else
                'If file path exists then display picture
                ChildPhoto.Picture = ChildPhotoPath
            End If
    End If
   
ErrorExit:
    Exit Sub

ErrorHandler:
    DoCmd.Beep
    MsgBox "Error No: " & Err.Number & "; Description: " & Err.Description
    Resume ErrorExit

End Sub

'****
'Code for my delete button to delete the photo's file path
Private Sub cmdDeletePhoto_Click()  

On Error GoTo ErrorHandler
   
    'Check to see if a file path to the photo already exists
    If IsNull(ChildPhotoPath) Then
        'If there is no file path then prompt user
        MsgBox "There is no current photo to Delete.", vbInformation, "Photo Error"
    Else
        'Check to see if the photo has been refreshed and is displayed
        If ChildPhoto.Picture <> ChildPhotoPath Then
            'If photo is not displayed then display it
            ChildPhoto.Picture = ChildPhotoPath
        End If
        'Prompt user before deleting photo file path
        If MsgBox("Are you sure you want to permanently delete this photo?", vbYesNo, "Delete Photo?") = vbNo Then
            'If user cancels delete then exit procedure
            Exit Sub
        Else
            'If user confirms delete then delete photo file path and picture display
            Me.ChildPhoto.Picture = "(none)"
            Me.ChildPhotoPath.Value = Null
        End If
    End If
   
ErrorExit:
    Exit Sub
   
ErrorHandler:
    DoCmd.Beep
    Resume ErrorExit
   
End Sub

'***************End of Sub***************

Hope you don't mind all the code...
I hope some of it is helpfull.

Good Luck!
Cheers
M

0
 
LVL 1

Author Comment

by:snoble
ID: 10716504
Emanon...

Your code is working relatively smooth right now except of course I have a question =). I am just using the basics in testing the code, but when I call the method of .picture I am getting an error "Object doesn't support this type of property or method". Is there a reference I am needing or is my data type wrong (OLE Object). Below is the code I am working with right now

Private Sub InsertPic_Click()
   
    If IsNull(FilePath) Then
        If MsgBox("There is no current photo to display.  Would you like to find a Photo now?", vbYesNo, "No current Photo") = vbNo Then
            Exit Sub
        Else
            Call GetOpenFile
                If IsNull(FilePath) Then
                    HtPicture.Picture = ""
                Else
                    HtPicture.Picture = FilePath <--- method / property is supported.
                End If
        End If
    End If
End Sub

Private Sub GetOpenFile()
  Dim CDLG As Object
  Set CDLG = CreateObject("MSComDlg.CommonDialog")
  With CDLG
    .DialogTitle = "Zimmer Heat Treat Pictures..."
    .Filter = _
      "Heat Treat(*bmp)|*.bmp|Heat Treat(*jpg)|*.jpg"
    .ShowOpen
   End With
   FilePath.Value = CDLG.FileName
  Set CDLG = Nothing
End Sub
0
 
LVL 1

Author Comment

by:snoble
ID: 10716659
Emanon...

Quick question... are you inserting your picture into a command button?? I am looking at the methods for that and I saw the Picture so I was checking. Thanks.
0
 
LVL 1

Author Comment

by:snoble
ID: 10716744
To narrow my question... what object/type of field are you assigning the linked picture too? I could see using the Image option in the toolbox to incorporate your code in. Let me know... Almost there... =)
0
 
LVL 1

Author Comment

by:snoble
ID: 10717072
Emanon...

Sorry... user error. I did not read your post thoroughly. I see you are listing the Image Control which is what I have been playing with. Thanks a lot... I can take it from here.

(Until another day ..............)
0
 
LVL 5

Expert Comment

by:Emanon_Consulting
ID: 10717171
Hi Stephen,

Sorry I had an errand to run...

In the Record Source table I store the file path in a text field that is formatted with it's field size to 255 characters(the maxt for a text field). (ChildPhotoPath)
I do not use an OLE Object at all in the table.

On the form I have the text box (ChildPhotoPath) that stores the file path set to Visible = No   - my Users do not see the file path (I don't think they need to).
(I Usually call the 'Name' of my text box the same as the 'RecordSource'  - good or bad that's what I have been doing...)

On the form I use an Image Control - I do not use a 'Bound Object Frame' or 'Unbound Object Frame'.
In the Properties of the Image Control Once it is in place I set the 'Picture' = (none) and the 'Picture Type' = Linked.
Then I use VBA to set the Properties 'Picture' = the file path to the .jpg (ChildPhotoPath).

Does this make sense?
Good Luck!
Cheers
M
0

Featured Post

Better Security Awareness With Threat Intelligence

See how one of the leading financial services organizations uses Recorded Future as part of a holistic threat intelligence program to promote security awareness and proactively and efficiently identify threats.

Join & Write a Comment

The first two articles in this short series — Using a Criteria Form to Filter Records (http://www.experts-exchange.com/A_6069.html) and Building a Custom Filter (http://www.experts-exchange.com/A_6070.html) — discuss in some detail how a form can be…
It took me quite some time to sort out all the different properties of combo and list boxes available from Visual Basic at run-time. Not that the documentation is lacking: the help pages are quite thorough and well written. The problem was rather wh…
Familiarize people with the process of utilizing SQL Server views from within Microsoft Access. Microsoft Access is a very powerful client/server development tool. One of the SQL Server objects that you can interact with from within Microsoft Access…
Basics of query design. Shows you how to construct a simple query by adding tables, perform joins, defining output columns, perform sorting, and apply criteria.

757 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

24 Experts available now in Live!

Get 1:1 Help Now