dotNETportal.cz

Dobry den,

Pomoci tohoto programu jsem schopen exportovat jednotlive cesty (Path) z OLE-objektu ale vysledna exportovana cesta, napriklad tato:

\\hamsrv01\COR\_KLAPP~1\MYSTER~1\TH7378~1.DOC

e kodovana? potrebuji ziskat uplnou cestu. Muze prosim nekdo pomoci ci dat tip? Dekuji.

 
Option Compare Database
Option Explicit
Function GetLinkedPath(objOLE As Variant) As Variant
  Dim strChunk As String
  Dim pathStart As Long
  Dim pathEnd As Long
  Dim Path As String
 
  If Not IsNull(objOLE) Then
     ' Convert string to Unicode.
     strChunk = StrConv(objOLE, vbUnicode)
     pathStart = InStr(1, strChunk, ":\", 1) - 1
 
     ' If mapped drive path not found, try UNC path.
     If pathStart <= 0 Then pathStart = InStr(1, strChunk, "\\", 1)
 
     ' If either drive letter path or UNC path found, determine
     ' the length of the path by searching for the first null
     ' character Chr(0) after the path was found.
     If pathStart > 0 Then
        pathEnd = InStr(pathStart, strChunk, Chr(0), 1)
        Path = Mid(strChunk, pathStart, pathEnd - pathStart)
        GetLinkedPath = Path
     End If
  Else
     '<GetLinkedPath = Null
  End If
End Function
Private Sub cmdUpdatePaths_Click()
  Dim rst As DAO.Recordset
  Dim db As DAO.Database
  Dim strPath As String
 
  Set db = CurrentDb
  'Set rst = db.OpenRecordset("Select [OLEfield], [NewPathField] From [MyTable]&quot<img src='../images/smiley/wink.gif' alt='Wink' style='vertical-align:middle;' />
  Set rst = db.OpenRecordset("Select [KLAPPENDATEI], [Pfad_KLAPPENDATEI] From [Stammdaten]&quot<img src='../images/smiley/wink.gif' alt='Wink' style='vertical-align:middle;' />
  While Not rst.EOF
    'strPath = GetLinkedPath(rst![OLEfield])
    strPath = GetLinkedPath(rst![KLAPPENDATEI])
    If Len(strPath) > 0 Then
      rst.Edit
      'rst.Fields("NewPathField&quot<img src='../images/smiley/wink.gif' alt='Wink' style='vertical-align:middle;' /> = strPath
      rst.Fields("Pfad_KLAPPENDATEI&quot<img src='../images/smiley/wink.gif' alt='Wink' style='vertical-align:middle;' /> = strPath
      rst.Update
    End If
    rst.MoveNext
  Wend
  Set rst = Nothing
  Set db = Nothing
End Sub