Bijlage bij record in acces 2003

[mindgame112]

Beste mensen,

Ik heb een vrij uitgebreide vraag dus hier een poging om het uit te leggen:

Ik ben bezig met mijn stage om een register te maken van gevaarlijke stoffen die aanwezig zijn in een laboratorium. Nu ben ik al een heel eind met het toevoegen verwijderen en bekijken van alle gegevens in formulieren etc. maar mijn probleem is dat elke stof ook een pdf heeft met alle veiligheidfsinformatie.

Nu heb ik dit probleem zo eerst opgelost door een knop te maken met deze functie:

Private Sub Knop37_Click()
On Error GoTo Err_info

Dim msdsid As String

msdsid = [Forms]![Stof info]![Keuzelijst met invoervak17]

Application.FollowHyperlink "G:\Gevaarlijke stoffen registratie\MSDS Sheats\" & msdsid & ".pdf", , True

GoTo End_info

Err_info:
MsgBox ("Geen VIB beschikbaar")
Exit Sub


End_info:
End Sub

Maar deze code houdt in dat de gebruiker die een stof toevoegt elke keer de pdf dezelfde naam moet geven als het id van de stof. Mijn vraag is dus is er een manier waarbij ik op het invulformulier om stoffen toe te voegen bijvoorbeeld een bladeren knop krijg en dat ik dan de pdf kan selecteren die voortaan geopend kan worden met een knop als die record geselecteerd is?

Alvast bedankt,

Sjoerd Redeker

 

[mindgame112]

niemand een idee ??

 

[OctaFish]

Ik gebruik in deze db (o.a.) een manier om te bladeren via een dialoogvenster.
Als je in de code van het frmSplits kijkt, zie je een knop waarmee je kunt bladeren. Door in het VBA deel de bestandsextensie te veranderen, kun je naar PDF'jes bladeren.

 

[mindgame112]

Ok ja ik kan de bijlagen hier niet openen op me stage maar ik ga vavavond ff kijken in ieder geval bedankt voor de hulp alvast !!

Gr Sjoerd

 

[OctaFish]

Veel plezier alvast, ik zie het wel als je vragen hebt.

 

[mindgame112]

Ik heb de oplossing al voor elkaar gedoctord hoor. Niet veel code zelf geschreven maar heb deze module gebruikt :

'.Browse Files Module
'.Copyright 1999 Tribble Software.  All rights reserved.
'.Phone        : (616) 455-2055
'.E-mail       : carltribble@earthlink.net

Option Compare Database
Option Explicit

Private Declare Function ts_apiGetOpenFileName Lib "comdlg32.dll" _
 Alias "GetOpenFileNameA" (tsFN As tsFileName) As Boolean

Private Declare Function ts_apiGetSaveFileName Lib "comdlg32.dll" _
 Alias "GetSaveFileNameA" (tsFN As tsFileName) As Boolean

Private Declare Function CommDlgExtendedError Lib "comdlg32.dll" () As Long

Private Type tsFileName
   lStructSize As Long
   hwndOwner As Long
   hInstance As Long
   strFilter As String
   strCustomFilter As String
   nMaxCustFilter As Long
   nFilterIndex As Long
   strFile As String
   nMaxFile As Long
   strFileTitle As String
   nMaxFileTitle As Long
   strInitialDir As String
   strTitle As String
   flags As Long
   nFileOffset As Integer
   nFileExtension As Integer
   strDefExt As String
   lCustData As Long
   lpfnHook As Long
   lpTemplateName As String
End Type

' Flag Constants
Public Const tscFNAllowMultiSelect = &H200
Public Const tscFNCreatePrompt = &H2000
Public Const tscFNExplorer = &H80000
Public Const tscFNExtensionDifferent = &H400
Public Const tscFNFileMustExist = &H1000
Public Const tscFNPathMustExist = &H800
Public Const tscFNNoValidate = &H100
Public Const tscFNHelpButton = &H10
Public Const tscFNHideReadOnly = &H4
Public Const tscFNLongNames = &H200000
Public Const tscFNNoLongNames = &H40000
Public Const tscFNNoChangeDir = &H8
Public Const tscFNReadOnly = &H1
Public Const tscFNOverwritePrompt = &H2
Public Const tscFNShareAware = &H4000
Public Const tscFNNoReadOnlyReturn = &H8000
Public Const tscFNNoDereferenceLinks = &H100000

Public Function tsGetFileFromUser( _
    Optional ByRef rlngflags As Long = 0&, _
    Optional ByVal strInitialDir As String = "", _
    Optional ByVal strFilter As String = "All Files (*.*)" & vbNullChar & "*.*", _
    Optional ByVal lngFilterIndex As Long = 1, _
    Optional ByVal strDefaultExt As String = "", _
    Optional ByVal strFileName As String = "", _
    Optional ByVal strDialogTitle As String = "", _
    Optional ByVal fOpenFile As Boolean = True) As Variant
On Error GoTo tsGetFileFromUser_Err
    
    Dim tsFN As tsFileName
    Dim strFileTitle As String
    Dim fResult As Boolean

    ' Allocate string space for the returned strings.
    strFileName = Left(strFileName & String(256, 0), 256)
    strFileTitle = String(256, 0)

    ' Set up the data structure before you call the function
    With tsFN
        .lStructSize = Len(tsFN)
        .hwndOwner = Application.hWndAccessApp
        .strFilter = strFilter
        .nFilterIndex = lngFilterIndex
        .strFile = strFileName
        .nMaxFile = Len(strFileName)
        .strFileTitle = strFileTitle
        .nMaxFileTitle = Len(strFileTitle)
        .strTitle = strDialogTitle
        .flags = rlngflags
        .strDefExt = strDefaultExt
        .strInitialDir = strInitialDir
        .hInstance = 0
        .strCustomFilter = String(255, 0)
        .nMaxCustFilter = 255
        .lpfnHook = 0
    End With
   
    ' Call the function in the windows API
    If fOpenFile Then
        fResult = ts_apiGetOpenFileName(tsFN)
    Else
        fResult = ts_apiGetSaveFileName(tsFN)
    End If

    ' If the function call was successful, return the FileName chosen
    ' by the user.  Otherwise return null.  Note, the CancelError property
    ' used by the ActiveX Common Dialog control is not needed.  If the
    ' user presses Cancel, this function will return Null.
    If fResult Then
        rlngflags = tsFN.flags
        tsGetFileFromUser = tsTrimNull(tsFN.strFile)
    Else
        tsGetFileFromUser = Null
    End If

tsGetFileFromUser_End:
    On Error GoTo 0
    Exit Function

tsGetFileFromUser_Err:
    Beep
    MsgBox Err.Description, , "Error: " & Err.Number _
    & " in function basBrowseFiles.tsGetFileFromUser"
    Resume tsGetFileFromUser_End

End Function

' Trim Nulls from a string returned by an API call.
Private Function tsTrimNull(ByVal strItem As String) As String
On Error GoTo tsTrimNull_Err
    Dim I As Integer
   
    I = InStr(strItem, vbNullChar)
    If I > 0 Then
        tsTrimNull = Left(strItem, I - 1)
    Else
        tsTrimNull = strItem
    End If
    
tsTrimNull_End:
    On Error GoTo 0
    Exit Function

tsTrimNull_Err:
    Beep
    MsgBox Err.Description, , "Error: " & Err.Number _
    & " in function basBrowseFiles.tsTrimNull"
    Resume tsTrimNull_End

End Function

En dan vervolgens deze code onder een knop gezet :

Public Sub Knop122_Click()

On Error GoTo tsGetFileFromUserTest_Err
   
    Dim strFilter As String
    Dim lngFlags As Long
    Dim varFileName As Variant

'   strFilter = "Access (*.mdb)" & vbNullChar & "*.mdb" _
'    & vbNullChar & "All Files (*.*)" & vbNullChar & "*.*"
    strFilter = "All Files (*.*)" & vbNullChar & "*.*"

    lngFlags = tscFNPathMustExist Or tscFNFileMustExist Or tscFNHideReadOnly
   
    varFileName = tsGetFileFromUser( _
    fOpenFile:=True, _
    strFilter:=strFilter, _
    rlngflags:=lngFlags, _
    strDialogTitle:="Kies het veiligheidsblad en druk op Openen")
   
    If IsNull(varFileName) Then
        Debug.Print "User pressed 'Cancel'."
    Else
        Debug.Print varFileName
        Forms![Stoffen_invoegen]![MSDS] = varFileName
    
    End If

tsGetFileFromUserTest_End:
    On Error GoTo 0
    Exit Sub

tsGetFileFromUserTest_Err:
    Beep
    MsgBox Err.Description, , "Error: " & Err.Number _
     & " in sub basBrowseFiles.tsGetFileFromUserTest"
    Resume tsGetFileFromUserTest_End

End Sub

Waarbij hij het pad van de pdf opslaat in de kolom MSDS en die kan opgevraagd worden met een knop die deze code heeft :

Private Sub Knop37_Click()
On Error GoTo Err_info

Application.FollowHyperlink [MSDS], , True

GoTo End_info

Err_info:
MsgBox ("Geen VIB beschikbaar")
Exit Sub


End_info:
End Sub

En dat werkt echt perfect!! Ik weet dat het een hele hoop tekst is maar voor de mensen die hetzelfde probleem hebben kan dit wel handig zijn denk ik ?

Groetjes Sjoerd

 

[OctaFish]

Tis niet de meest fraaie oplossing die ik ooit heb gezien, hij is dan ook al uit 1999, maar als het werkt, werkt het! Mocht je ooit een fraaiere, minder gecompliceerde oplossing willen: die zijn er ook! En zelfs hier op het forum te vinden...

 

[mindgame112]

Tis niet de meest fraaie oplossing die ik ooit heb gezien, hij is dan ook al uit 1999, maar als het werkt, werkt het! Mocht je ooit een fraaiere, minder gecompliceerde oplossing willen: die zijn er ook! En zelfs hier op het forum te vinden...

ow ik heb wel echt gezocht maar kon het echt niet vinden hier op t forum. als je misschien de code hebt van een betere oplossing zie ik hem nog graag hier misschien hoor!!

Met vr. gr.

Sjoerd Redeker

 

[OctaFish]

Deze bijvoorbeeld:

Dit op de knop:

Private Sub cmd_DirectorySelect_Click()

    Dim strValue As String
    Dim strFoundFile As String
    
    If Me.txt_SelectedDirectory = "" Or IsNull(Me.txt_SelectedDirectory) _
    Then
        Me.txt_SelectedDirectory = BrowseFolder
    Else
        Dim strStartDirectory As String
        strStartDirectory = BrowseFolder("", CStr(Me.txt_SelectedDirectory))
        Me.txt_SelectedDirectory = strStartDirectory
    End If
    
    If Me.txt_SelectedDirectory = "" Or IsNull(Me.txt_SelectedDirectory) Then
        Me.txt_SelectedDirectory = "C:\"
    End If
    
    strFoundFile = Dir(Me.txt_SelectedDirectory & "/*.*")
    Do Until strFoundFile = ""
        strValue = strValue & strFoundFile & ";"
        strFoundFile = Dir
    Loop
    
    Me.lst_FilesInDirectory.RowSourceType = "Value List"
    Me.lst_FilesInDirectory.RowSource = strValue
    
    Me.txt_SelectedDirectory.Visible = True
    Me.lst_FilesInDirectory.Visible = True
    Me.lbl_NextStep.Visible = True
    Me.grp_OpenStatus.Visible = True
    
End Sub

En dit is de functie:

Option Compare Database
Option Explicit

Private Type BROWSEINFO
  hOwner As Long
  pidlRoot As Long
  pszDisplayName As String
  lpszTitle As String
  ulFlags As Long
  lpfn As Long
  lParam As Long
  iImage As Long
  strInitialDir As String
End Type

Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias _
            "SHGetPathFromIDListA" (ByVal pidl As Long, _
            ByVal pszPath As String) As Long
            
Private Declare Function SHBrowseForFolder Lib "shell32.dll" Alias _
            "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) _
            As Long
            
Private Const BIF_RETURNONLYFSDIRS = &H1

Public Function BrowseFolder(Optional szDialogTitle As String, _
                            Optional szInitialDir As String) As String

  Dim x As Long, bi As BROWSEINFO, dwIList As Long
  Dim szPath As String, wPos As Integer
  
    With bi
        .hOwner = hWndAccessApp
        .lpszTitle = szDialogTitle
        .strInitialDir = szInitialDir
        .ulFlags = BIF_RETURNONLYFSDIRS
    End With
    
    dwIList = SHBrowseForFolder(bi)
    szPath = Space$(512)
    x = SHGetPathFromIDList(ByVal dwIList, ByVal szPath)
    
    If x Then
        wPos = InStr(szPath, Chr(0))
        BrowseFolder = left$(szPath, wPos - 1)
    Else
        BrowseFolder = ""
    End If
End Function

Zie bijgaand voorbeeld voor de praktijk.

En er is nog wel meer, (zelfs mooier en kleiner) maar daar kan ik nu even niet bij, omdat mijn 2007 niet meer start. (de code is niet afhankelijk van 2007)

 

[mindgame112]

Deze bijvoorbeeld:

Dit op de knop:

Private Sub cmd_DirectorySelect_Click()

    Dim strValue As String
    Dim strFoundFile As String
    
    If Me.txt_SelectedDirectory = "" Or IsNull(Me.txt_SelectedDirectory) _
    Then
        Me.txt_SelectedDirectory = BrowseFolder
    Else
        Dim strStartDirectory As String
        strStartDirectory = BrowseFolder("", CStr(Me.txt_SelectedDirectory))
        Me.txt_SelectedDirectory = strStartDirectory
    End If
    
    If Me.txt_SelectedDirectory = "" Or IsNull(Me.txt_SelectedDirectory) Then
        Me.txt_SelectedDirectory = "C:\"
    End If
    
    strFoundFile = Dir(Me.txt_SelectedDirectory & "/*.*")
    Do Until strFoundFile = ""
        strValue = strValue & strFoundFile & ";"
        strFoundFile = Dir
    Loop
    
    Me.lst_FilesInDirectory.RowSourceType = "Value List"
    Me.lst_FilesInDirectory.RowSource = strValue
    
    Me.txt_SelectedDirectory.Visible = True
    Me.lst_FilesInDirectory.Visible = True
    Me.lbl_NextStep.Visible = True
    Me.grp_OpenStatus.Visible = True
    
End Sub

En dit is de functie:

Option Compare Database
Option Explicit

Private Type BROWSEINFO
  hOwner As Long
  pidlRoot As Long
  pszDisplayName As String
  lpszTitle As String
  ulFlags As Long
  lpfn As Long
  lParam As Long
  iImage As Long
  strInitialDir As String
End Type

Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias _
            "SHGetPathFromIDListA" (ByVal pidl As Long, _
            ByVal pszPath As String) As Long
            
Private Declare Function SHBrowseForFolder Lib "shell32.dll" Alias _
            "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) _
            As Long
            
Private Const BIF_RETURNONLYFSDIRS = &H1

Public Function BrowseFolder(Optional szDialogTitle As String, _
                            Optional szInitialDir As String) As String

  Dim x As Long, bi As BROWSEINFO, dwIList As Long
  Dim szPath As String, wPos As Integer
  
    With bi
        .hOwner = hWndAccessApp
        .lpszTitle = szDialogTitle
        .strInitialDir = szInitialDir
        .ulFlags = BIF_RETURNONLYFSDIRS
    End With
    
    dwIList = SHBrowseForFolder(bi)
    szPath = Space$(512)
    x = SHGetPathFromIDList(ByVal dwIList, ByVal szPath)
    
    If x Then
        wPos = InStr(szPath, Chr(0))
        BrowseFolder = left$(szPath, wPos - 1)
    Else
        BrowseFolder = ""
    End If
End Function

Zie bijgaand voorbeeld voor de praktijk.

En er is nog wel meer, (zelfs mooier en kleiner) maar daar kan ik nu even niet bij, omdat mijn 2007 niet meer start. (de code is niet afhankelijk van 2007)

Hij geeft bij mij de foutmelding dat hij de methode of het gegevenslid niet kan vinden en dan wijst hij aan bij de knop de code Me.txt_SelectedDirectory ?

Doe ik iets fout ? heb nu precies deze code overgenomen maar kan ook neit vinden waar hij het pad van het bestand wegschrijft. Kan bijlage trouwens niet openen want hier op stage is geen winrar..

 

[OctaFish]

Het (licht irritante) verhaal waarschijnlijk, dat de bibliotheken niet goed zijn geladen, of ontbreken.... :evil:
De foutmelding wordt zelden veroorzaakt door een fout, al zou dat best kunnen, een typefoutje of ontbrekende spatie zit er zo in...
Probeer eens via <Foutopsporing>, < .... compileren> te kijken waar er eventueel fouten zitten, en of je bibliotheken er ongeveer uitzien als bijgaand plaatje.