ja, nach Jahren der Abstinenz "verirre" ich mich auch mal wieder hier her :-)
Und dann seh ich auch glatt noch so altbekannte Namen wie Hajo Zi,
da wird einem doch glatt warm ums Herz ;-)
Ich hätte da ein kleines Problemchen, da ich meinen Uraltcode aus dem Jahr 2003
etwas aufbohren muss, damit nun auch das Öffnen von Dateien die auf dem Sharepoint liegen möglich wird.
Ich hab mir da schon was rausgesucht, das in anderer Kombi auch schon gut funktioniert hat - die Funktion Parse_Resource() die mir die URL in WEBDAV übersetzt...
Leider bekomme ich in meinem alten Code eine Fehlermeldung "Kein ByRef möglich"
Wäre nett, wenn sich einer erbarmt und mir nen Tip gibt.
Ciao
Nike
Sub Analyse()
Dim arrFilenames As Variant
Dim wbkArr As Workbook
Dim wbkBasis As Workbook
Set wbkBasis = ActiveWorkbook
Selection:
' Zu öffnende Dateien erfragen
arrFilenames = Application.GetOpenFilename( _
"Excelfiles (*.xlsm), *.xlsm, All Files (*.*), *.*", 1, _
"Select Excel files...", MultiSelect:=True)
'Add selected files to an array field
If VarType(arrFilenames) = vbBoolean Then
If MsgBox("No files were selected. Do you want to exit the Makro?", vbYesNo, "Exit?") = _
_
vbNo Then
GoTo Selection
Else
Set wbkBasis = Nothing
Exit Sub
End If
End If
Application.ScreenUpdating = False
'Hide Makro activity to gain speed
For i = 1 To UBound(arrFilenames) ' Durchläuft die Anzahl der Dateien
'Wenn Datei noch nicht geöffnet
'If FileOpenYet(Dir$(arrFilenames(i))) = False Then
If FileOpenYet(Parse_Resource(arrFilenames(i))) = False Then
'dann öffnen
'Workbooks.Open FileName:=arrFilenames(i)
Workbooks.Open FileName:=Parse_Resource(arrFilenames(i))
Else
'oder Aktivieren
Workbooks(arrFilenames(i)).Activate
End If
Set wbkArr = ActiveWorkbook
'hier kommt dann der Code rein, der die ausgewählten Dateien
'betrifft. Die Ursprungsdatei ist über wbkBasis ansprechbar.
wkbbasis.Worksheets(1).Cells(i, 1) = wbkArr.Worksheets(1).Range("F32")
wkbbasis.Worksheets(1).Cells(i, 2) = wbkArr.Name
wbkArr.Close savechanges:=False 'Datei schließen
Set wbkArr = Nothing
Next i
Set wbkArr = Nothing
wbkBasis.Activate
Set wbkBasis = Nothing
Application.ScreenUpdating = True
End Sub
Function FileOpenYet(FileName As String) As Boolean
'eine Funktion, die Prüft ob eine Datei schon geöffnet ist.
Dim s As String
On Error GoTo Nonexistent
s = Workbooks(FileName).Name
FileOpenYet = True
Exit Function
Nonexistent:
FileOpenYet = False
End Function
Public Function Parse_Resource(URL As String)
'Uncomment the below line to test locally without calling the function & remove argument above
'Dim URL As String
Dim SplitURL() As String
Dim i As Integer
Dim WebDAVURI As String
'Check for a double forward slash in the resource path. This will indicate a URL
If Not InStr(1, URL, "//", vbBinaryCompare) = 0 Then
'Split the URL into an array so it can be analyzed & reused
SplitURL = Split(URL, "/", , vbBinaryCompare)
'URL has been found so prep the WebDAVURI string
WebDAVURI = "\\"
'Check if the URL is secure
If SplitURL(0) = "https:" Then
'The code iterates through the array excluding unneeded components of the URL
For i = 0 To UBound(SplitURL)
If Not SplitURL(i) = "" Then
Select Case i
Case 0
'Do nothing because we do not need the HTTPS element
Case 1
'Do nothing because this array slot is empty
Case 2
'This should be the root URL of the site. Add @ssl to the WebDAVURI
WebDAVURI = WebDAVURI & SplitURL(i) & "@ssl"
Case Else
'Append URI components and build string
WebDAVURI = WebDAVURI & "\" & SplitURL(i)
End Select
End If
Next i
Else
'URL is not secure
For i = 0 To UBound(SplitURL)
'The code iterates through the array excluding unneeded components of the URL
If Not SplitURL(i) = "" Then
Select Case i
Case 0
'Do nothing because we do not need the HTTPS element
Case 1
'Do nothing because this array slot is empty
Case 2
'This should be the root URL of the site. Does not require an additional _
slash
WebDAVURI = WebDAVURI & SplitURL(i)
Case Else
'Append URI components and build string
WebDAVURI = WebDAVURI & "\" & SplitURL(i)
End Select
End If
Next i
End If
'Set the Parse_Resource value to WebDAVURI
Parse_Resource = WebDAVURI
Else
'There was no double forward slash so return system path as is
Parse_Resource = URL
End If
End Function