AW: Const strPath durch Makro ändern
05.12.2010 20:17:35
Josef
Hallo Dirk,
das geht z.B. so.
' **********************************************************************
' Modul: DieseArbeitsmappe Typ: Element der Mappe(Sheet, Workbook, ...)
' **********************************************************************
Option Explicit
Private Sub Workbook_Open()
strPath = GetCustProp(cstrPropertyName, cstrDefaultPath)
End Sub
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************
Option Explicit
'Name der Dateieigenschaft
Public Const cstrPropertyName As String = "Mein Pfad"
'Vorgabewert für den Pfad, falls noch keine dateieigneschaft angelegt
Public Const cstrDefaultPath As String = "C:\Dokumente und Einstellungen\Räder\Eigene Dateien"
Public strPath As String
Sub ordnerauswahl()
Dim BrowseDir As Object
On Error Resume Next
Set BrowseDir = CreateObject("Shell.Application").BrowseForFolder(0, _
"Ordner auswählen", &H4000, GetCustProp(cstrPropertyName, cstrDefaultPath))
If Not BrowseDir Is Nothing Then
SetCustProp cstrPropertyName, BrowseDir.self.Path
End If
Set BrowseDir = Nothing
End Sub
Sub test()
MsgBox GetCustProp(cstrPropertyName, cstrDefaultPath)
End Sub
Public Function GetCustProp(propName As String, Optional propValue As Variant) As Variant
' Wert aus Dateieigenschaft auslesen. Wenn nicht vorhanden
' Anlegen und Optional mit Startwert belegen
Dim propType As MsoDocProperties
If Not IsMissing(propValue) Then
Select Case VarType(propValue)
Case vbString
propType = msoPropertyTypeString
Case vbBoolean
propType = msoPropertyTypeBoolean
Case vbByte, vbInteger, vbLong
propType = msoPropertyTypeNumber
Case vbSingle, vbDouble
propType = msoPropertyTypeFloat
Case vbDate
propType = msoPropertyTypeDate
Case Else
End Select
End If
With ThisWorkbook
On Error GoTo NoName
GetCustProp = .CustomDocumentProperties(propName).Value
Exit Function
NoName:
If Err.Number = 5 Then
Err.Clear
.CustomDocumentProperties.Add _
Name:=propName, _
LinkToContent:=False, _
Type:=propType, _
Value:=propValue
GetCustProp = propValue
End If
End With
End Function
Public Function SetCustProp(propName As String, propValue As Variant)
' Wert in Dateieigenschaft schreiben. Wenn nicht vorhanden
' Anlegen und Wert eintragen
Dim propType As MsoDocProperties
Select Case VarType(propValue)
Case vbString
propType = msoPropertyTypeString
Case vbBoolean
propType = msoPropertyTypeBoolean
Case vbByte, vbInteger, vbLong
propType = msoPropertyTypeNumber
Case vbSingle, vbDouble
propType = msoPropertyTypeFloat
Case vbDate
propType = msoPropertyTypeDate
Case Else
End Select
With ThisWorkbook
On Error GoTo NoName
.CustomDocumentProperties(propName).Value = propValue
Exit Function
NoName:
If Err.Number = 5 Then
Err.Clear
.CustomDocumentProperties.Add _
Name:=propName, _
LinkToContent:=False, _
Type:=propType, _
Value:=propValue
End If
End With
End Function
Gruß Sepp