VBA get template-path

Mit forslag ville være at gemme UNC versionen af stien i en af Templatens egenskaber.
Når man så åbner en ny mappe baseret på templaten, kan denne værdi hentes igen.
UNC-versioner er ligeglad med bogstaverne med bruger hele stien til det mappede drev.
Nedenstående kode indsættes i et alm modul i fx. Person.xls.
Templaten åbner og makroen InsertUNCPath køres. Templaten gemmes så og er klar til brug.

Når du ønsker at hive stien til templaten ud af din nye projektmappe kan du bruge den nederste makro GetTemplateFolder.
Bemærk at alt kun virker rigtig med netværksdrev.

Option Explicit
Declare Function WNetGetConnection32 Lib "MPR.DLL" Alias _
  "WNetGetConnectionA" (ByVal lpszLocalName As String, ByVal _
  lpszRemoteName As String, lSize As Long) As Long

Dim lpszRemoteName As String
Dim lSize As Long
Const NO_ERROR As Long = 0
Const lBUFFER_SIZE As Long = 255

Function GetNetPath(stPath As String) As String
    Dim stDriveLetter As String, stRest As String, cbRemoteName As Long
    Dim lStatus&
    stDriveLetter = Left(stPath, 2)
    stRest = Mid(stPath, 3, Len(stPath) - 1)
    cbRemoteName = lBUFFER_SIZE
    lpszRemoteName = lpszRemoteName & Space(lBUFFER_SIZE)
  ' Return the UNC path (\\Server\Share).
    lStatus& = WNetGetConnection32(stDriveLetter, lpszRemoteName, _
      cbRemoteName)
  ' Verify that the WNetGetConnection() succeeded. WNetGetConnection()
  ' returns 0 (NO_ERROR) if it successfully retrieves the UNC path.
    If lStatus& = NO_ERROR Then
      ' Display the UNC path.
      GetNetPath = Application.Trim(lpszRemoteName) & stRest
    Else
      ' Unable to obtain the UNC path.
      GetNetPath = stPath
    End If
End Function

Sub InsertUNCPath()
ActiveWorkbook.BuiltinDocumentProperties.Item(6).Value = GetNetPath(ActiveWorkbook.Path)
End Sub

Sub GetTemplateFolder()
TemplatePath = ActiveWorkbook.BuiltinDocumentProperties.Item(6).Value
'bla. bla.
'din egen kode
End Sub

tak for svaret.. jeg vil vende tilbage i morgen, når jeg har set på det..

jeg ved godt, jeg ikke har fået set på det endnu, jeg ved, det virker, så jeg modificerer scriptet ved lejlighed, så det passer til mig.. kan ikke se, hvorfor du ikke skal have point nu.. så du må gerne lægge en svar...

min endelige løsning blev sådan her:

Declare Function WNetGetConnectionA Lib "MPR.DLL" (ByVal lpszLocalName As String, ByVal lpszRemoteName As String, lSize As Long) As Long
Dim lpszRemoteName As String
Const BUFFER_SIZE As Long = 255

sub calendar()

lpszRemoteName = lpszRemoteName & Space(BUFFER_SIZE)
If WNetGetConnectionA(Left(ActiveWorkbook.Path, 2), lpszRemoteName, 255) = 0 Then
    ActiveWorkbook.BuiltinDocumentProperties.Item(6).value = Application.Trim(lpszRemoteName) & Mid(ActiveWorkbook.Path, 3, Len(ActiveWorkbook.Path) - 1) & "\"
End If

stConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & "Data Source=" & ActiveWorkbook.BuiltinDocumentProperties.Item(6) & "TCC_Test_requests_System_Testing.mdb;"

end sub


takker for hjælpen!!

/1

og smid lige et svar, hvis du vil have points...

ok,ok :-)

værs'go...