|
|
|
Prüfen, ob eine Dateinummer bereits verwendet wird
.Beschreibung
VBA bietet standardmässig keine Möglichkeit zum
Überprüfen, ob im Zusammenhang mit der Open-Anweisung eine bestimmte
Dateinummer bereits benutzt wird. Die folgenden Beispiele zeigen, wie man eine solche
Funktion selber programmieren kann.
Ablauflogik:
1. Abfragen, ob die nächste freie Dateinummer (VBA-Funktion FreeFile)
grösser ist als die zu überprüfende Dateinummer.
2. Abfragen, ob die nächste freie Dateinummer (VBA-Funktion FreeFile)
gleich ist wie die zu überprüfende Dateinummer.
3. Abfragen, ob die zu überprüfende Dateinummer verwendet werden kann.
- Laufzeitfehler 53: Datei nicht gefunden (bedeutet, dass die Dateinummer nicht verwendet wird)
- Laufzeitfehler 55: Datei bereits geöffnet (bedeutet, dass die Dateinummer bereits verwendet wird)
» Codebeispiel #1: Dieses exemplarische Beispiel öffnet als Ausgangslage zuerst die Datei "EineDatei.txt" drei Mal, mit den Dateinummern 1, 2 und 4. Überprüft wird, ob die Dateinummer 3 bereits verwendet wird (abgelegt als Konstante intFileNumberToCheck).
» Codebeispiel #2: Hier wurde die oben vorgestellte Ablauflogik in einer Funktion namens IsFileNumberFree gekapselt.
.VBA-Code #1
Public Sub CheckIfFileNumberIsUsed()
Const intFileNumberToCheck As Integer = 3
'Als Ausgangslage drei Dateinummern belegen
Open "C:\Daten\EineDatei.txt" For Input As #1
Open "C:\Daten\EineDatei.txt" For Input As #2
Open "C:\Daten\EineDatei.txt" For Input As #4
If FreeFile() > intFileNumberToCheck Then
MsgBox "Die Dateinummer " & CStr(intFileNumberToCheck)
& " wird bereits verwendet.", vbInformation
ElseIf FreeFile() = intFileNumberToCheck Then
MsgBox "Die Dateinummer " & CStr(intFileNumberToCheck)
& " wird nicht verwendet.", vbInformation
Else
On Error Resume Next
Open Environ("windir") & "\dummy" For Input As
#intFileNumberToCheck
If Err.Number = 0 Then
Close #intFileNumberToCheck
MsgBox "Die Dateinummer " &
CStr(intFileNumberToCheck) & " wird nicht verwendet.", vbInformation
ElseIf Err.Number = 53 Then
MsgBox "Die Dateinummer " &
CStr(intFileNumberToCheck) & " wird nicht verwendet.", vbInformation
ElseIf Err.Number = 55 Then
MsgBox "Die Dateinummer " &
CStr(intFileNumberToCheck) & " wird bereits verwendet.", vbInformation
Else
MsgBox "Fehler " & CStr(Err.Number) &
" aufgetreten!", vbExclamation
End If
End If
Reset
End Sub
.VBA-Code #2
Public Function IsFileNumberFree(ByVal FileNumber As
Integer) As Boolean
If FreeFile() > FileNumber Then
IsFileNumberFree = False
ElseIf FreeFile() = FileNumber Then
IsFileNumberFree = True
Else
On Error Resume Next
Open Environ("windir") & "\dummy" For Input As
#FileNumber
If Err.Number = 0 Then
Close #FileNumber
IsFileNumberFree = True
ElseIf Err.Number = 55 Then
IsFileNumberFree = False
ElseIf Err.Number = 53 Then
IsFileNumberFree = True
Else
IsFileNumberFree = False
End If
End If
On Error GoTo 0
End Function
'*** Aufruf ***
Sub TestCall()
MsgBox "Dateinummer frei? " & CStr(IsFileNumberFree(3))
End Sub
 |
Weitere Informationen |
 |
Verwandte Codebeispiele |
Prüfen, ob eine aktive Arbeitsmappe existiert
.Beschreibung
Gewöhnlich gibt es in Microsoft Excel eine so genannte aktive
Arbeitsmappe. Das ist immer diejenige Arbeitsmappe, die vom Benutzer gerade bearbeitet
wird. Allerdings gibt es mehrere Situationen, mindestens deren zwei, in denen keine aktive
Arbeitsmappe existiert. Diese Situationen sind folgende:
1. Es ist keine Arbeitsmappe geöffnet.
2. Es ist bzw. sind mehrere Arbeitsmappen geöffnet, wobei diese jedoch
ausgeblendet sind.
Der folgende Programmcode überprüft, ob es eine aktive Arbeitsmappe gibt.
.VBA-Code
Public Sub CheckIfActiveWorkbookExists()
If Not ActiveWorkbook Is Nothing Then
MsgBox "Es gibt eine aktive Arbeitsmappe.", vbInformation
Else
MsgBox "Es gibt keine aktive Arbeitsmappe.", vbInformation
End If
End Sub
|
Verwandte Codebeispiele |
Prüfen, ob ein externer Datenbereich beim Öffnen der Arbeitsmappe aktualisiert wird
.Beschreibung
Dieses Codebeispiel zeigt, wie man herausfindet, ob die Daten
eines externen Datenbereiches (einer so genannten QueryTable) automatisch aktualisiert
werden, wenn die Arbeitsmappe geöffnet wird. Das Beispiel geht davon aus, dass sich auf
dem aktiven Blatt ein externer Datenbereich befindet.
.VBA-Code
Public Sub GetRefreshDataOnWorkbookOpen()
If ActiveSheet.QueryTables(1).RefreshOnFileOpen = True Then
MsgBox "Externe Daten werden beim Öffnen der Arbeitsmappe
aktualisiert."
Else
MsgBox "Externe Daten werden beim Öffnen der Arbeitsmappe nicht
aktualisiert."
End If
End Sub
|
Verwandte Codebeispiele |
|
Aktualisierungseinstellung eines externen Datenbereiches beim Öffnen der Arbeitsmappe ändern
.Beschreibung
Diese Codebeispiele zeigen, wie man die Einstellung
"Aktualisieren beim Öffnen der Arbeitsmappe" eines externen Datenbereiches
ändert.
» Codebeispiel #1: Hier wird die Aktualisierungseinstellung aktiviert. Es wird der erste externe Datenbereich des aktiven Arbeitsblattes verwendet.
» Codebeispiel #2: Hier wird die Aktualisierungseinstellung deaktiviert. Es wird der erste externe Datenbereich des aktiven Arbeitsblattes verwendet.
» Codebeispiel #3: Hier wird die Aktualisierungseinstellung aktiviert. Es wird der externe Datenbereich mit der Bezeichnung "Aktienkurse" des aktiven Arbeitsblattes verwendet.
.VBA-Code #1
Public Sub ActivateRefreshDataOnWorkbookOpen()
ActiveSheet.QueryTables(1).RefreshOnFileOpen = True
End Sub
.VBA-Code #2
Public Sub DeactivateRefreshDataOnWorkbookOpen()
ActiveSheet.QueryTables(1).RefreshOnFileOpen = False
End Sub
.VBA-Code #3
Public Sub SetRefreshDataOnWorkbookOpen()
ActiveSheet.QueryTables("Aktienkurse").RefreshOnFileOpen = True
End Sub
|
Verwandte Codebeispiele |
|
.Beschreibung
Das nachstehende Codebeispiel fragt die Eigenschaft SaveData
eines externen Datenbereiches ab, die festlegt, ob die externen Daten vor dem Speichern
der Arbeitsmappe entfernt oder mitgespeichert werden.
Im Beispiel wird angenommen, dass sich der externe Datenbereich auf dem aktiven Arbeitsblatt befindet.
.VBA-Code
Public Sub GetSaveDataWithWorkbook()
MsgBox "Externe Daten speichern: " &
ActiveSheet.QueryTables(1).SaveData
End Sub
|
Verwandte Codebeispiele |
|
Prüfen, ob ein externer Datenbereich im Hintergrund aktualisiert wird
.Beschreibung
Die Eigenschaft BackgroundQuery legt fest, ob ein
externer Datenbereich im Hintergrund aktualisiert werden kann.
Im Beispiel wird angenommen, dass sich der externe Datenbereich auf dem aktiven Arbeitsblatt befindet.
.VBA-Code
Public Sub GetRefreshInBackground()
MsgBox "Externe Daten speichern: " &
ActiveSheet.QueryTables(1).BackgroundQuery
End Sub
Verbindungsinformation (Connection) eines externen Datenbereiches abfragen
.Beschreibung
Ein externer Datenbereich ist, wie der Name schon andeutet,
ein Bereich, dessen Daten aus einer externen Datenquelle stammen. Externe Daten können
gewöhnlich von einer Datenbankabfrage, einer Web-Abfrage oder einer Pivot-Tabelle
angefordert bzw. dargestellt werden. Immer wenn Daten aus einer Datenbank oder dem Web
stammen, wird eine so genannte Verbindungsinformation benutzt. Diese ist in der
Eigenschaft Connection abgelegt. Diese Eigenschaft existiert für zwei Objekte: PivotCache
und QueryTable.
» Das Codebeispiel #1 fragt die Connection-Eigenschaft von PivotCache ab. Wenn beispielsweise die Pivot-Tabelle auf einer Datenbankabfrage basiert, enthält Connection zum Beispiel
ODBC;DBQ=C:\Daten;DefaultDir=C:\Daten;Driver={Microsoft
Text Driver (*.txt; *.csv)};
DriverId=27;Extensions=None,asc,csv,dat,log,tab,txt;FIL=text;MaxBufferSize=2048;
MaxScanRows=25;PageTimeout=5;SafeTransactions=0;Threads=3;UserCommitSync=Yes;
» Das Codebeispiel #2 fragt die Connection-Eigenschaft von QueryTable ab. Wenn beispielsweise eine Web-Abfrage verwendet wird, enthält Connection zum Beispiel
URL;http://webservices.pcquote.com/cgi-bin/excel.exe.VBA-Code #1
Public Sub GetConnectionPivotCache()
MsgBox ActiveSheet.PivotTables(1).PivotCache.Connection
End Sub
.VBA-Code #2
Public Sub GetConnectionQueryTable()
MsgBox ActiveSheet.QueryTables(1).Connection
End Sub
|
Verwandte Codebeispiele |
SQL-Query eines externen Datenbereiches abfragen
.Beschreibung
Externe Datenbereiche, die auf einer Datenbankabfrage
basieren, können einen SQL-Query besitzen. Der Datenbereich kann dabei eine Pivot-Tabelle
(PivotCache) oder eine so genannten QueryTable sein.
MsgBox ActiveSheet.PivotTables(1).PivotCache.SQL
Beispiel von SQL einer Datenbank-Abfrage:
SELECT Textdatei1.Name, Textdatei2.Vorname_Nachname FROM
Textdatei1.txt Textdatei1, Textdatei2.txt Textdatei2 WHERE Textdatei1.Name =
Textdatei2.Vorname_Nachname
.VBA-Code #1
Public Sub GetSQLPivotCache()
MsgBox ActiveSheet.PivotTables(1).PivotCache.SQL
End Sub
.VBA-Code #2
Public Sub GetSQLQueryTable()
MsgBox ActiveSheet.QueryTables(1).SQL
End Sub
|
Weitere Informationen |
|
Verwandte Codebeispiele |
|
Dateiname der Datenquelle eines externen Datenbereiches abfragen
.Beschreibung
Eine Pivot-Tabelle kann Daten darstellen, deren Quelle
- eine MS Excel-Datenbank oder -Liste,
- eine externe Datenquelle,
- mehrere Konsolidierungsbereiche oder
- eine andere Pivot-Tabelle
ist.
Wenn eine Pivot-Tabelle Daten aus einer anderen Arbeitsmappe ("MS Excel-Datenbank/-Liste") darstellt, enthält die Eigenschaft SourceData einen externen Bezug, der sich aus Dateiname, Blattname und Zellbereich zusammensetzt. Wenn die andere Mappe in einem anderen Verzeichnis als die Mappe mit der Pivot-Tabelle liegt, ist zusätzlich der relative Pfad zur anderen Mappendatei enthalten.
[PivoTest.xls]Tabelle1!Z5S1:Z26S5
'\Daten\[Pivot-Test 2.xls]Tabelle2'!Z1S1:Z7S3
.VBA-Code
Public Sub GetSourceDataFilename()
End Sub
|
Verwandte Codebeispiele |
Datenbankabfrage ausführen und als externer Datenbereich in ein Arbeitsblatt einfügen
.Beschreibung
Dieses Codebeispiel fügt einen neuen externen Datenbereich
bei Zelle A1 des aktiven Arbeitsblattes ein. Die Daten werden von einer bestehenden
Datenbankabfrage namens "Query1.dqy" geliefert.
.VBA-Code
Public Sub AddQueryTableFromDatabaaeQuery()
With ActiveSheet.QueryTables.Add(Connection:= _
"FINDER;C:\Programme\Microsoft
Office\Abfragen\Query1.dqy", _
Destination:=Range("A1"))
.FieldNames = True
.RefreshStyle = xlInsertDeleteCells
.RowNumbers = False
.FillAdjacentFormulas = False
.RefreshOnFileOpen = False
.HasAutoFormat = True
.BackgroundQuery = True
.TablesOnlyFromHTML = True
.Refresh BackgroundQuery:=False
.SavePassword = True
.SaveData = True
End With
End Sub
|
Verwandte Codebeispiele |
|
Web-Abfrage ausführen und als externer Datenbereich in ein Arbeitsblatt einfügen
.Beschreibung
Dieses Codebeispiel fügt einen neuen externen Datenbereich in
das aktive Arbeitsblatt ein. Die Daten werden von einer bestehenden Web-Abfrage geliefert.
.VBA-Code
Public Sub AddQueryTableFromWebQuery()
End Sub
|
Verwandte Codebeispiele |
|
Arbeitsmappendateien eines bestimmten Autors auflisten
.Beschreibung
Dieses Codebeispiel listet alle Arbeitsmappen eines Ordners
auf, die von einem bestimmten Autor erstellt wurden.
Die Konstante strFolder enthält den zu durchsuchenden Ordner. Sie können auch mehrere Ordner angeben, indem Sie die einzelnen Ordnerpfade durch Semikolons trennen (zum Beispiel "C:\Daten;C:\Excel\Dateien;D:\Statistik"). Die Konstante strProperty enthält die gesuchte Eigenschaft. In strPropertyValue ist der Eigenschaftswert abgelegt.
.VBA-Code
Public Sub ListWorkbookFilesOfAuthor()
Const strFolder As String = "C:\Daten"
Const strProperty As String = "Autor"
Const strPropertyValue As String = "Philipp von Wartburg"
Dim lngFiles As Integer
Dim wksSheet As Worksheet
With Application.FileSearch
.NewSearch
.LookIn = strFolder
.SearchSubFolders = False
.FileType = msoFileTypeExcelWorkbooks
.FileName = "*.xls"
.PropertyTests.Add Name:=strProperty, Condition:=msoConditionIsExactly,
_
Value:=strPropertyValue,
Connector:=msoConnectorAnd
If .Execute() > 0 Then
Set wksSheet = ActiveWorkbook.Worksheets.Add
With wksSheet
.Range("A3:B3").Value =
Array("Nr.", "Datei")
.Range("A3:B3").Font.Bold = True
End With
For lngFiles = 1 To .FoundFiles.Count
wksSheet.Cells(lngFiles + 3, 1).Value =
lngFiles
wksSheet.Cells(lngFiles + 3, 2).Value =
.FoundFiles(lngFiles)
Next lngFiles
With wksSheet
.Columns("A:B").AutoFit
.Range("A1").Value = "Dateiliste
(" & strProperty & " " & strPropertyValue & ")"
.Range("A1").Font.Bold = True
.Range("A1").Font.Size =
.Range("A1").Font.Size + 1
End With
Set wksSheet = Nothing
Else
MsgBox "Es wurden keine Dateien mit diesen
Suchkriterien gefunden.", vbInformation
End If
End With
End Sub
.Hinweis
Wenn die Suche eine Datei findet, auf die nicht
zugegriffen werden kann, erscheint der Laufzeitfehler 70 "Zugriff verweigert".
Der Fehler tritt bei der Codezeile
wksSheet.Cells(lngFiles + 3, 2).Value = .FoundFiles(lngFiles)
auf, beispielsweise wenn der Benutzer keine Leseberechtigung für die betroffene Datei besitzt.
|
Weitere Informationen |
Arbeitsmappendateien eines bestimmten Bearbeiters auflisten
.Beschreibung
Dieses Codebeispiel erstellt eine Liste derjenigen
Arbeitsmappendateien eines Ordners, die von einem bestimmten Benutzer bearbeitet wurden.
Da die Arbeitsmappen bearbeitet wurden, wurden sie folglich von dem Benutzer zuletzt
gespeichert. Das heisst, dass die Dokument-Eigenschaft "Zuletzt gespeichert von"
gefiltert werden muss.
Die Konstante strFolder enthält den zu durchsuchenden Ordner. Sie können auch mehrere Ordner angeben, indem Sie die einzelnen Ordnerpfade durch Semikolons trennen (zum Beispiel "C:\Daten;C:\Excel\Dateien;D:\Statistik"). Die Konstante strProperty enthält die gesuchte Eigenschaft. In strPropertyValue ist der Eigenschaftswert abgelegt.
.VBA-Code
Public Sub ListWorkbookFilesOfLastEditedBy()
Const strFolder As String = "C:\Daten"
Const strProperty As String = "Zuletzt gespeichert von"
Const strPropertyValue As String = "Philipp von Wartburg"
Dim lngFiles As Integer
Dim wksSheet As Worksheet
With Application.FileSearch
.NewSearch
.LookIn = strFolder
.SearchSubFolders = False
.FileType = msoFileTypeExcelWorkbooks
.FileName = "*.xls"
.PropertyTests.Add Name:=strProperty, Condition:=msoConditionIsExactly,
_
Value:=strPropertyValue,
Connector:=msoConnectorAnd
If .Execute() > 0 Then
Set wksSheet = ActiveWorkbook.Worksheets.Add
With wksSheet
.Range("A3:B3").Value =
Array("Nr.", "Datei")
.Range("A3:B3").Font.Bold = True
End With
For lngFiles = 1 To .FoundFiles.Count
wksSheet.Cells(lngFiles + 3, 1).Value =
lngFiles
wksSheet.Cells(lngFiles + 3, 2).Value =
.FoundFiles(lngFiles)
Next lngFiles
With wksSheet
.Columns("A:B").AutoFit
.Range("A1").Value = "Dateiliste
(" & strProperty & " " & strPropertyValue & ")"
.Range("A1").Font.Bold = True
.Range("A1").Font.Size =
.Range("A1").Font.Size + 1
End With
Set wksSheet = Nothing
Else
MsgBox "Es wurden keine Dateien mit diesen
Suchkriterien gefunden.", vbInformation
End If
End With
End Sub
.Hinweis
Wenn die Suche eine Datei findet, auf die nicht
zugegriffen werden kann, erscheint der Laufzeitfehler 70 "Zugriff verweigert".
Der Fehler tritt bei der Codezeile
wksSheet.Cells(lngFiles + 3, 2).Value = .FoundFiles(lngFiles)
auf, beispielsweise wenn der Benutzer keine Leseberechtigung für die betroffene Datei besitzt.
|
Weitere Informationen |
|
Verwandte Codebeispiele |
|
Arbeitsmappendateien eines bestimmten Benutzers auflisten
.Beschreibung
Dieses Codebeispiel erstellt eine Liste der Arbeitsmappen, die
von einem bestimmten Benutzer zuletzt verwendet wurden. Es werden folgedessen auch alle
Exceldateien aufgelistet, die durch den Benutzer lediglich geöffnet wurden, ohne dass sie
der Benutzer gespeichert hat.
.VBA-Code
Public Sub ListWorkbookFilesOfUser()
End Sub
|
Weitere Informationen |
|
Verwandte Codebeispiele |
|
Arbeitsmappendateien einer bestimmten Firma auflisten
.Beschreibung
Mit diesem Codebeispiel wird eine Liste der Arbeitsmappen
erstellt, die im Feld "Firma" der Dokument-Eigenschaften einen bestimmten
Begriff enthalten. Im Beispiel wird als Firma "Muster AG" verwendet. Durchsucht
wird der Ordner "C:\Daten" (ohne Unterverzeichnisse).
.VBA-Code
Public Sub ListWorkbookFilesOfCompany()
Const strFolder As String = "C:\Daten"
Const strProperty As String = "Firma"
Const strPropertyValue As String = "Muster AG"
Dim lngFiles As Integer
Dim wksSheet As Worksheet
With Application.FileSearch
.NewSearch
.LookIn = strFolder
.SearchSubFolders = False
.FileType = msoFileTypeExcelWorkbooks
.FileName = "*.xls"
.PropertyTests.Add Name:=strProperty, Condition:=msoConditionIsExactly,
_
Value:=strPropertyValue,
Connector:=msoConnectorAnd
If .Execute() > 0 Then
Set wksSheet = ActiveWorkbook.Worksheets.Add
With wksSheet
.Range("A3:B3").Value =
Array("Nr.", "Datei")
.Range("A3:B3").Font.Bold = True
End With
For lngFiles = 1 To .FoundFiles.Count
wksSheet.Cells(lngFiles + 3, 1).Value =
lngFiles
wksSheet.Cells(lngFiles + 3, 2).Value =
.FoundFiles(lngFiles)
Next lngFiles
With wksSheet
.Columns("A:B").AutoFit
.Range("A1").Value = "Dateiliste
(" & strProperty & " " & strPropertyValue & ")"
.Range("A1").Font.Bold = True
.Range("A1").Font.Size =
.Range("A1").Font.Size + 1
End With
Set wksSheet = Nothing
Else
MsgBox "Es wurden keine Dateien mit diesen
Suchkriterien gefunden.", vbInformation
End If
End With
End Sub
.Hinweis
Wenn die Suche eine Datei findet, auf die nicht
zugegriffen werden kann, erscheint der Laufzeitfehler 70 "Zugriff verweigert".
Der Fehler tritt bei der Codezeile
wksSheet.Cells(lngFiles + 3, 2).Value = .FoundFiles(lngFiles)
auf, beispielsweise wenn der Benutzer keine Leseberechtigung für die betroffene Datei besitzt.
|
Weitere Informationen |
|
Verwandte Codebeispiele |
Arbeitsmappendateien eines bestimmten Themas auflisten
.Beschreibung
Mit diesem Codebeispiel wird eine Liste der Arbeitsmappen
erstellt, die im Feld "Thema" der Dokument-Eigenschaften einen bestimmten
Begriff enthalten. Im Beispiel wird der Begriff "Bilanz" verwendet. Durchsucht
wird der Ordner "C:\Daten" (ohne Unterverzeichnisse).
.VBA-Code
Public Sub ListWorkbookFilesOfTopic()
Const strFolder As String = "C:\Daten"
Const strProperty As String = "Thema"
Const strPropertyValue As String = "Bilanz"
Dim lngFiles As Integer
Dim wksSheet As Worksheet
With Application.FileSearch
.NewSearch
.LookIn = strFolder
.SearchSubFolders = False
.FileType = msoFileTypeExcelWorkbooks
.FileName = "*.xls"
.PropertyTests.Add Name:=strProperty, Condition:=msoConditionIsExactly,
_
Value:=strPropertyValue,
Connector:=msoConnectorAnd
If .Execute() > 0 Then
Set wksSheet = ActiveWorkbook.Worksheets.Add
With wksSheet
.Range("A3:B3").Value =
Array("Nr.", "Datei")
.Range("A3:B3").Font.Bold = True
End With
For lngFiles = 1 To .FoundFiles.Count
wksSheet.Cells(lngFiles + 3, 1).Value =
lngFiles
wksSheet.Cells(lngFiles + 3, 2).Value =
.FoundFiles(lngFiles)
Next lngFiles
With wksSheet
.Columns("A:B").AutoFit
.Range("A1").Value = "Dateiliste
(" & strProperty & " " & strPropertyValue & ")"
.Range("A1").Font.Bold = True
.Range("A1").Font.Size =
.Range("A1").Font.Size + 1
End With
Set wksSheet = Nothing
Else
MsgBox "Es wurden keine Dateien mit diesen
Suchkriterien gefunden.", vbInformation
End If
End With
End Sub
.Hinweis
Wenn die Suche eine Datei findet, auf die nicht
zugegriffen werden kann, erscheint der Laufzeitfehler 70 "Zugriff verweigert".
Der Fehler tritt bei der Codezeile
wksSheet.Cells(lngFiles + 3, 2).Value = .FoundFiles(lngFiles)
auf, beispielsweise wenn der Benutzer keine Leseberechtigung für die betroffene Datei besitzt.
|
Weitere Informationen |
|
Verwandte Codebeispiele |
Arbeitsmappendateien einer bestimmten Kategorie auflisten
.Beschreibung
Mit diesem Codebeispiel wird eine Liste der Arbeitsmappen
erstellt, die im Feld "Kategorie" der Dokument-Eigenschaften einen bestimmten
Begriff enthalten. Im Beispiel wird "Musterdatei" für die Kategorie verwendet.
Durchsucht wird der Ordner "C:\Daten" (ohne Unterverzeichnisse).
.VBA-Code
Public Sub ListWorkbookFilesOfCategory()
Const strFolder As String = "C:\Daten"
Const strProperty As String = "Kategorie"
Const strPropertyValue As String = "Musterdatei"
Dim lngFiles As Integer
Dim wksSheet As Worksheet
With Application.FileSearch
.NewSearch
.LookIn = strFolder
.SearchSubFolders = False
.FileType = msoFileTypeExcelWorkbooks
.FileName = "*.xls"
.PropertyTests.Add Name:=strProperty, Condition:=msoConditionIsExactly,
_
Value:=strPropertyValue,
Connector:=msoConnectorAnd
If .Execute() > 0 Then
Set wksSheet = ActiveWorkbook.Worksheets.Add
With wksSheet
.Range("A3:B3").Value =
Array("Nr.", "Datei")
.Range("A3:B3").Font.Bold = True
End With
For lngFiles = 1 To .FoundFiles.Count
wksSheet.Cells(lngFiles + 3, 1).Value =
lngFiles
wksSheet.Cells(lngFiles + 3, 2).Value =
.FoundFiles(lngFiles)
Next lngFiles
With wksSheet
.Columns("A:B").AutoFit
.Range("A1").Value = "Dateiliste
(" & strProperty & " " & strPropertyValue & ")"
.Range("A1").Font.Bold = True
.Range("A1").Font.Size =
.Range("A1").Font.Size + 1
End With
Set wksSheet = Nothing
Else
MsgBox "Es wurden keine Dateien mit diesen
Suchkriterien gefunden.", vbInformation
End If
End With
End Sub
.Hinweis
Wenn die Suche eine Datei findet, auf die nicht
zugegriffen werden kann, erscheint der Laufzeitfehler 70 "Zugriff verweigert".
Der Fehler tritt bei der Codezeile
wksSheet.Cells(lngFiles + 3, 2).Value = .FoundFiles(lngFiles)
auf, beispielsweise wenn der Benutzer keine Leseberechtigung für die betroffene Datei besitzt.
|
Weitere Informationen |
|
Verwandte Codebeispiele |
Arbeitsmappendateien eines Ordners auflisten
.Beschreibung
Mit den folgenden drei Codebeispielen können Sie eine Liste
der Arbeitsmappendateien eines Ordners erstellen. Alle drei Beispiele liefern das gleiche
Ergebnis, gehen jedoch bei der Überprüfung des Dateityps (Microsoft Excel-Arbeitsmappe)
unterschiedlich vor. Verwenden Sie dasjenige Beispiel, welches Ihnen am ehesten zusagt.
» Codebeispiel #1: Überprüft, ob die rechten vier Zeichen des Dateinamens ".xls" sind.
» Codebeispiel #2: Überprüft, ob der Dateityp "Microsoft Excel-Arbeitsmappe" ist.
» Codebeispiel #3: Überprüft, ob die Datennamenerweiterung "xls" ist.
.VBA-Code #1
Public Sub ListWorkbookFiles1()
Const strPath As String = "C:\Daten"
Dim objFolder As Object
Dim objFile As Object
Dim wksSheet As Worksheet
Dim intCounter As Integer
Set objFolder =
CreateObject("Scripting.FileSystemObject").GetFolder(strPath)
If objFolder.Files.Count = 0 Then
Set objFolder = Nothing
Exit Sub
End If
Set wksSheet = ActiveWorkbook.Worksheets.Add
For Each objFile In objFolder.Files
If LCase$(Right$(objFile.Name, 4)) = ".xls" Then
intCounter = intCounter + 1
wksSheet.Cells(intCounter, 1).Value = objFile.Name
End If
Next
wksSheet.Columns("A").AutoFit
Set objFolder = Nothing
Set wksSheet = Nothing
End Sub
.VBA-Code #2
Public Sub ListWorkbookFiles2()
Const strPath As String = "C:\Daten"
Dim objFolder As Object
Dim objFile As Object
Dim wksSheet As Worksheet
Dim intCounter As Integer
Set objFolder =
CreateObject("Scripting.FileSystemObject").GetFolder(strPath)
If objFolder.Files.Count = 0 Then
Set objFolder = Nothing
Exit Sub
End If
Set wksSheet = ActiveWorkbook.Worksheets.Add
For Each objFile In objFolder.Files
If objFile.Type = "Microsoft Excel-Arbeitsmappe" Then
intCounter = intCounter + 1
wksSheet.Cells(intCounter, 1).Value = objFile.Name
End If
Next
wksSheet.Columns("A").AutoFit
Set objFolder = Nothing
Set wksSheet = Nothing
End Sub
.VBA-Code #3
Public Sub ListWorkbookFiles3()
Const strPath As String = "C:\Daten"
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim wksSheet As Worksheet
Dim intCounter As Integer
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(strPath)
If objFolder.Files.Count = 0 Then
Set objFolder = Nothing
Set objFSO = Nothing
Exit Sub
End If
Set wksSheet = ActiveWorkbook.Worksheets.Add
For Each objFile In objFolder.Files
If LCase$(objFSO.GetExtensionName(objFile.Path)) = "xls" Then
intCounter = intCounter + 1
wksSheet.Cells(intCounter, 1).Value = objFile.Name
End If
Next
wksSheet.Columns("A").AutoFit
Set objFolder = Nothing
Set objFSO = Nothing
Set wksSheet = Nothing
End Sub
|
Weitere Informationen |
|
Verwandte Codebeispiele |
Öffnen des in der Zelle angegebenen Ordners im Explorer mittels Doppelklick
.Beschreibung
Hier wird eine Lösung vorgestellt, wie ein in einer Zelle
eingetragener Ordner im Windows Explorer geöffnet wird, indem man einen Doppelklick auf
die Zelle ausführt. Im Beispiel wird davon ausgegangen, dass ein Arbeitsblatt mit dem
Namen "Tabelle1" vorhanden ist.
Beim Öffnen der Arbeitsmappe wird durch das Auto_Open-Makro eingestellt, dass ein Doppelklick auf eine Zelle des Blattes "Tabelle1" an die Prozedur OpenExplorer weitergeleitet wird. Diese Einstellung wird beim Schliessen der Mappe wieder aufgehoben. Über Application.Caller erhält man den Inhalt der Zelle, auf die ein Doppelklick ausgeführt wurde. Anstelle der Konstante vbNormalFocus kann man auch eine andere Konstante für den Fensterstil angeben.
TODO: Windows Explorer öffnen mit FollowHyperlink
.VBA-Code
'Codemodul
Public Sub Auto_Open()
Worksheets("Tabelle1").OnDoubleClick = "OpenExplorer"
End Sub
Public Sub Auto_Close()
Worksheets("Tabelle1").OnDoubleClick = ""
End Sub
Public Sub OpenExplorer()
Shell "Explorer.exe " & Application.Caller, vbNormalFocus
End Sub
.Hinweis
Die Shell-Anweisung bzw. die Befehlszeile des Windows
Explorers kann auch relative Pfade entgegennehmen.
|
Weitere Informationen |
Detaillierte Informationen über die
Befehlszeilen-Parameters des Windows Explorers erhalten Sie hier:
Command-Line Switches for Windows
Explorer
http://support.microsoft.com/?kbid=130510
.Beschreibung
Mit der API-Funktion ExitWindowEx kann man den
Computer neu starten. Dazu muss für das erste Funktionsargument (Flags) die Zahl
2 angegeben werden.
.VBA-Code
'Deklarationsbereich
Declare Function ExitWindowsEx Lib "user32"
(ByVal Flags As Long, _
ByVal Reserved As Long) As Long
'Codemodul
Sub RebootComputer()
ExitWindowsEx 2, 0
End Sub
|
Verwandte Codebeispiele |
Computer herunterfahren und ausschalten
.Beschreibung
Mit der API-Funktion ExitWindowEx kann man den
Computer herunterfahren und ausschalten. Das erste Funktionsargument Flags wird
dazu auf den Wert 1 gestellt.
.VBA-Code
'Deklarationsbereich
Declare Function ExitWindowsEx Lib "user32"
(ByVal Flags As Long, _
ByVal Reserved As Long) As Long
'Codemodul
Sub ShutdownComputer()
ExitWindowsEx 1, 0
End Sub
|
Verwandte Codebeispiele |
Name der aktiven Arbeitsmappe abfragen
.Beschreibung
Der Name der aktiven Arbeitsmappe wird mit der Name-Eigenschaft
des Workbook-Objektes abgefragt. ActiveWorkbook ist eine Eigenschaft von
Application, die das Workbook-Objekt der aktiven Mappe liefert. Wenn es
keine aktive Arbeitsmappe gibt, tritt der Laufzeitfehler 91 "Objektvariable oder
With-Blockvariable nicht festgelegt" auf.
.VBA-Code
Public Sub GetActiveWorkbookName()
MsgBox "Name der aktiven Arbeitsmappe: " & ActiveWorkbook.Name
End Sub
|
Weitere Informationen |
|
Verwandte Codebeispiele |
|
Name der codeausführenden Arbeitsmappe abfragen
.Beschreibung
...
Bei ThisWorkbook in einem VBA-Programm kann nie ein Laufzeitfehler auftreten, weil es immer eine codeausführende Arbeitsmappe beziehungsweise ein geöffnetes VBA-Projekt gibt. Nur wenn man ThisWorkbook im Direktfenster des VBA-Editors verwendet und weder eine Arbeitsmappe noch ein Add-In geladen ist, erscheint der Laufzeitfehler 1004 "Anwendungs- oder objektdefinierter Fehler".
.VBA-Code
Public Sub GetThisWorkbookName()
MsgBox "Name der codeausführenden Arbeitsmappe: " &
ThisWorkbook.Name
End Sub
|
Weitere Informationen |
|
Verwandte Codebeispiele |
|
Name des aktiven Arbeitsblattes abfragen
.Beschreibung
Der Name des aktiven Arbeitsblattes wird mit der Name-Eigenschaft
des Worksheet-Objektes abgefragt. ActiveSheet ist eine Eigenschaft von Application,
die das Worksheet-Objekt des aktiven Blattes liefert. Wenn es kein aktives
Arbeitsblatt gibt, tritt der Laufzeitfehler 91 "Objektvariable oder
With-Blockvariable nicht festgelegt" auf.
.VBA-Code
Public Sub GetActiveWorksheetName()
MsgBox "Name des aktiven Arbeitsblattes: " & ActiveSheet.Name
End Sub
|
Weitere Informationen |
|
Verwandte Codebeispiele |
Name des aktiven VBA-Projektes abfragen
.Beschreibung
Der Name des aktiven VBA-Projektes ist der Name-Eigenschaft
des Projektes abgelegt. Der Zugriff erfolgt via ActiveVBProject.
.VBA-Code
Public Sub GetActiveVBProjectName()
MsgBox "Name des aktiven VBA-Projektes: " &
Application.VBE.ActiveVBProject.Name
End Sub
|
Weitere Informationen |
|
Verwandte Codebeispiele |
|
Name des VBA-Projektes der aktiven Arbeitsmappe abfragen
.Beschreibung
Der Name des aktiven VBA-Projektes ist der Name-Eigenschaft
des Projektes abgelegt. Der Zugriff erfolgt via ActiveWorkbook.VBProject.
.VBA-Code
Public Sub GetActiveWorkbookVBProjectName()
MsgBox "Name des VBA-Projektes der aktiven Arbeitsmappe: " &
ActiveWorkbook.VBProject.Name
End Sub
|
Weitere Informationen |
|
Verwandte Codebeispiele |
|
Typ des aktiven Arbeitsblattes abfragen
.Beschreibung
Jedes Arbeitsblatt einer Arbeitsmappe besitzt einen bestimmten
Typ, wobei es insgesamt fünf verschiedene Typen gibt. Den Typ erhalten Sie durch Abfragen
der Type-Eigenschaft des Worksheet-Objektes.
| XlSheetType-Konstante | Wert |
| xlWorksheet | -4167 |
| xlChart | -4109 |
| xlDialog | -4116 |
Bei Diagrammblättern wird ein falscher Wert ausgegeben (3 statt -4109; 3 steht eigentlich für xlExcel4MacroSheet)!
Sheet.Type geht auch.
Als Alternative kann man auch die TypeName-Funktion von VBA einsetzen:
z.B. TypeName(ActiveSheet)
| Blatt | TypeName liefert... |
| Tabelle | Worksheet |
| Diagramm | Chart |
| Excel 4.0-Makrovorlage | Worksheet |
| Internationale Makrovorlage | Worksheet |
| Excel 5.0-Dialog | DialogSheet |
Wenn kein aktives Blatt existiert, gibt TypeName den Wert "Nothing" zurück.
.VBA-Code #1
Public Sub GetActiveWorksheetType1()
MsgBox ActiveSheet.Type
End Sub
.VBA-Code #2
Public Sub GetActiveWorksheetType2()
MsgBox TypeName(ActiveSheet)
End Sub
|
Verwandte Codebeispiele |
Typ eines Arbeitsblattes abfragen
.Beschreibung
Jedes Arbeitsblatt einer Arbeitsmappe besitzt einen bestimmten
Typ, wobei es insgesamt fünf verschiedene Typen gibt. Den Typ erhalten Sie durch Abfragen
der Type-Eigenschaft des Worksheet-Objektes.
| XlSheetType-Konstante | Wert |
| xlWorksheet | -4167 |
| xlChart | -4109 |
| xlDialog | -4116 |
Bei Diagrammblättern wird ein falscher Wert ausgegeben (3 statt -4109; 3 steht eigentlich für xlExcel4MacroSheet)!
Sheet.Type geht auch.
» Codebeispiel #1: Diese Prozedur gibt den Typ eines Arbeitsblattes aus. Im Beispiel wird das aktive Arbeitsblatt verwendet (ActiveSheet).
» Codebeispiel #2: Wie Codebeispiel #1, jedoch als Funktion gekapselt. Das Argument objSheet muss mit Object deklariert sein (d.h. nicht mit Worksheet), da sonst bei einem Dialogblatt bereits beim Aufrufen der Funktion ein Laufzeitfehler auftritt! Im Beispiel wird der Typ des zweiten Blattes der aktiven Arbeitsmappe abgefragt.
.VBA-Code #1
Public Sub GetSheetType()
Dim intSheetType As Integer
On Error Resume Next
intSheetType = ActiveSheet.Type
If Err.Number = 0 Then
Select Case intSheetType
Case -4167
MsgBox "Tabellenblatt"
Case 3
If ActiveSheet.ChartType >= 0 Then
If Err.Number = 0 Then
MsgBox
"Diagrammblatt"
Else
Err.Clear
MsgBox
"Makroblatt"
End If
End If
Case 4
MsgBox "Intl. Makroblatt"
End Select
Else
Err.Clear
MsgBox "Dialogblatt"
End If
End Sub
.VBA-Code #2
Public Function GetSheetTypeName(objSheet As Object) As
String
Dim intSheetType As Integer
On Error Resume Next
intSheetType = objSheet.Type
If Err.Number = 0 Then
Select Case intSheetType
Case -4167
GetSheetTypeName = "Tabellenblatt"
Case 3
If objSheet.ChartType >= 0 Then
If Err.Number = 0 Then
GetSheetTypeName =
"Diagrammblatt"
Else
Err.Clear
GetSheetTypeName =
"Makroblatt"
End If
End If
Case 4
GetSheetTypeName = "Intl. Makroblatt"
Case Else
GetSheetTypeName = "Unbekannt"
End Select
Else
Err.Clear
GetSheetTypeName = "Dialogblatt"
End If
End Function
'*** Aufruf ***
Sub TestCall()
MsgBox "Blatttyp: " & GetSheetTypeName(ActiveWorkbook.Sheets(2))
End Sub
|
Verwandte Codebeispiele |
Prozeduren und Funktionen eines VBA-Projektes auflisten
.Beschreibung
Der hier vorgestellte Programmcode erstellt eine Liste
sämtlicher in einem VBA-Projekt enthaltenen Prozeduren (Subs) und Funktionen (Functions).
Die Liste wird auf einem neuen Arbeitsblatt der aktiven Arbeitsmappe erstellt. Pro Modul
des VBA-Projektes wird eine Spalte des Arbeitsblattes verwendet. Es können daher die
Prozeduren und Funktionen von maximal 256 Modulen aufgelistet werden.
Es werden alle Codezeilen sämtlicher Module des VBA-Projektes durchlaufen (CountOfLines) und der Prozedurname jeder Zeile abgefragt. Jeder gefundene Name wird auf dem Arbeitsblatt aufgelistet.
Im Beispiel wird das VBA-Projekt der aktiven Arbeitsmappe verwendet.
.VBA-Code
Public Sub ListVBProjectProcedures()
Dim wksSheet As Worksheet
Dim objComponent As VBComponent
Dim intColumn As Integer
Dim intRow As Integer
Dim intLine As Integer
Dim strProcName As String
Set wksSheet = ActiveWorkbook.Worksheets.Add
For Each objComponent In ActiveWorkbook.VBProject.VBComponents
If objComponent.Type = vbext_ct_ClassModule Or objComponent.Type =
vbext_ct_Document Or objComponent.Type = vbext_ct_StdModule Then
intRow = 1
intColumn = intColumn + 1
If intColumn > 256 Then
MsgBox "Das VBA-Projekt enthält mehr
Module als Tabellenspalten zur Verfügung stehen.", vbInformation
Exit For
End If
With wksSheet.Cells(intRow, intColumn)
.Value = objComponent.Name
.Font.Bold = True
End With
With objComponent.CodeModule
For intLine = 1 To .CountOfLines
If .ProcOfLine(intLine,
vbext_pk_Proc) > "" Then
strProcName =
.ProcOfLine(intLine, vbext_pk_Proc)
If strProcName <>
wksSheet.Cells(intRow, intColumn).Value Then
intRow =
intRow + 1
wksSheet.Cells(intRow, intColumn).Value = strProcName
End If
End If
Next intLine
End With
End If
Next objComponent
wksSheet.Range(wksSheet.Cells(1, 1), wksSheet.Cells(1,
intColumn)).EntireColumn.AutoFit
Set wksSheet = Nothing
End Sub
|
Verwandte Codebeispiele |
API-Deklarationen eines VBA-Projektes auflisten
.Beschreibung
Dieser Programmcode dient zum Erstellen einer Liste der in
einem VBA-Projekt enthaltenen API-Deklarationen. Die Liste wird auf einem neuen
Arbeitsblatt der aktiven Arbeitsmappe erstellt. Pro Modul des VBA-Projektes wird eine
Spalte des Arbeitsblattes verwendet. Es können daher die API-Deklarationen von maximal
256 Modulen aufgelistet werden.
Eine API-Deklaration befindet sich immer im Deklarationsbereich eines Moduls. Daher werden alle Zeilen des Deklarationsbereiches durchlaufen (CountOfDeclarationLines) und überprüft, ob das Word "Declare" vorkommt. Ist das Wort enthalten, und die Zeile beginnt weder mit einem Apostroph-Zeichen noch mit Rem, so handelt es sich um eine Deklarationszeile. Hier ein Beispiel einer deklarierten API-Funktion:
Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Im Beispiel wird das VBA-Projekt der aktiven Arbeitsmappe verwendet.
.VBA-Code
Public Sub ListVBProjectAPIDeclarations()
Dim wksSheet As Worksheet
Dim objComponent As VBComponent
Dim intColumn As Integer
Dim intRow As Integer
Dim intLine As Integer
Set wksSheet = ActiveWorkbook.Worksheets.Add
For Each objComponent In ActiveWorkbook.VBProject.VBComponents
If objComponent.Type = vbext_ct_ClassModule Or objComponent.Type =
vbext_ct_Document Or objComponent.Type = vbext_ct_StdModule Then
intRow = 1
intColumn = intColumn + 1
If intColumn > 256 Then
MsgBox "Das VBA-Projekt enthält mehr
Module als Tabellenspalten zur Verfügung stehen.", vbInformation
Exit For
End If
With wksSheet.Cells(intRow, intColumn)
.Value = objComponent.Name
.Font.Bold = True
End With
With objComponent.CodeModule
For intLine = 1 To .CountOfDeclarationLines
If InStr(.Lines(intLine, 1),
"Declare") > 0 Then
If
Left$(LTrim$(.Lines(intLine, 1)), 1) <> "'" And
Left$(LTrim$(.Lines(intLine, 1)), 3) <> "Rem" Then
intRow =
intRow + 1
wksSheet.Cells(intRow, intColumn).Value = .Lines(intLine, 1)
End If
End If
Next intLine
End With
End If
Next objComponent
wksSheet.Range(wksSheet.Cells(1, 1), wksSheet.Cells(1,
intColumn)).EntireColumn.AutoFit
Set wksSheet = Nothing
End Sub
|
Verwandte Codebeispiele |
Datei eines zuletzt bearbeiteten Dokumentes von Windows öffnen
.Beschreibung
Im Windows-Startmenü gibt es den Menüeintrag
"Dokumente", welcher eine Liste mit den zuletzt bearbeiteten Dokumenten zeigt.
Das folgende Codebeispiel zeigt, wie man eine in der Liste enthaltene Dokumentdatei
öffnen kann.
...
.VBA-Code
Public Sub OpenFileOfRecentDocumentsList()
End Sub
|
Weitere Informationen |
Prüfen, ob eine Arbeitsmappe in der Liste der zuletzt verwendeten Dateien eingetragen ist
.Beschreibung
Im Menü "Datei" von Microsoft Excel befinden sich
bis zu 9 Einträge mit den Namen der zuletzt verwendeten Dateien. Dieses Codebeispiel
überprüft, ob eine bestimmte Datei in der Liste eingetragen ist.
.VBA-Code
Public Sub IsWorkbookInRecentFilesList()
End Sub
|
Weitere Informationen |
|
Verwandte Codebeispiele |
|
Prüfen, ob eine Datei in der Liste der zuletzt bearbeiteten Dokumente von Windows eingetragen ist
.Beschreibung
Dieser Programmcode überprüft, ob eine bestimmte Datei in
der Liste der zuletzt bearbeiteten Dokumente von Windows eingetragen ist. Diese Liste
erreicht man über das Menüelement "Dokumente" der Windows Start-Schaltfläche.
.VBA-Code
Public Sub IsFileInRecentDocumentsList()
End Sub
|
Weitere Informationen |
Screenshot des aktiven Fensters in die Zwischenablage kopieren
.Beschreibung
In Windows lässt sich jederzeit ein Screenshot des aktiven
Fensters erzeugen, indem man die Tastenkombination Alt+Druck (Print
Screen) drückt. Möchte man das gleiche mittels VBA-Programm machen, so benötigt
man ziemlich viel Code.
Die "Application.Wait"-Codezeile dient nur zu Demonstrationszwecken. Sie bewirkt, dass zwischen Prozedurausführung und Erstellung des Screenshots 5 Sekunden lang gewartet wird. Sie haben dadurch Zeit, ein beliebiges Fenster zu aktivieren. Ohne dieses Warten würde der Screenshot unmittelbar nach dem Prozedurstart und folgedessen immer vom VBA-Editor-Fenster erstellt. Die Codezeile muss in der operativen Version des Programmcodes entfernt werden.
.VBA-Code
'Deklarationsbereich
Type RECT_Type
left As Long
top As Long
right As Long
bottom As Long
End Type
Declare Function GetForegroundWindow Lib "User32" () As Long
Declare Function GetDesktopWindow Lib "User32" () As Long
Declare Sub GetWindowRect Lib "User32" (ByVal Hwnd As Long, lpRect As RECT_Type)
Declare Function GetDC Lib "User32" (ByVal Hwnd As Long) As Long
Declare Function CreateCompatibleDC Lib "Gdi32" (ByVal hdc As Long) As Long
Declare Function CreateCompatibleBitmap Lib "Gdi32" (ByVal hdc As Long, ByVal
nWidth As Long, _
ByVal nHeight As Long) As Long
Declare Function SelectObject Lib "Gdi32" (ByVal hdc As Long, ByVal hObject As
Long) As Long
Declare Function BitBlt Lib "Gdi32" (ByVal hDestDC As Long, ByVal X As Long,
ByVal Y As Long, _
ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, _
ByVal XSrc As Long, ByVal YSrc As Long, ByVal dwRop As Long) As Long
Declare Function OpenClipboard Lib "User32" (ByVal Hwnd As Long) As Long
Declare Function EmptyClipboard Lib "User32" () As Long
Declare Function SetClipboardData Lib "User32" (ByVal wFormat As Long, ByVal
hMem As Long) As Long
Declare Function CloseClipboard Lib "User32" () As Long
Declare Function ReleaseDC Lib "User32" (ByVal Hwnd As Long, ByVal hdc As Long)
As Long
Declare Function DeleteDC Lib "Gdi32" (ByVal hdc As Long) As Long
Const SRCCOPY = &HCC0020
Const CF_BITMAP = 2
'Codemodul
Public Sub MakeScreenshot()
Dim FormHwnd As Long
Dim DeskHwnd As Long
Dim hdc As Long
Dim hdcMem As Long
Dim rect As RECT_Type
Dim junk As Long
Dim fwidth As Long
Dim fheight As Long
Dim hBitmap As Long
Application.Wait Now + TimeValue("0:00:05") '<- Diese Zeile dient nur zu Demonstrationszwecken
DeskHwnd = GetDesktopWindow()
FormHwnd = GetForegroundWindow()
Call GetWindowRect(FormHwnd, rect)
fwidth = rect.right - rect.left
fheight = rect.bottom - rect.top
hdc = GetDC(DeskHwnd)
hdcMem = CreateCompatibleDC(hdc)
hBitmap = CreateCompatibleBitmap(hdc, fwidth, fheight)
If hBitmap <> 0 Then
junk = SelectObject(hdcMem, hBitmap)
junk = BitBlt(hdcMem, 0, 0, fwidth, fheight, hdc, rect.left, rect.top,
SRCCOPY)
junk = OpenClipboard(DeskHwnd)
junk = EmptyClipboard()
junk = SetClipboardData(CF_BITMAP, hBitmap)
junk = CloseClipboard()
End If
junk = DeleteDC(hdcMem)
junk = ReleaseDC(DeskHwnd, hdc)
End Sub
Screenshot eines Fensters in die Zwischenablage kopieren
.Beschreibung
In Windows lässt sich jederzeit ein Screenshot des aktiven
Fensters erzeugen, indem man die Tastenkombination Alt+Druck (Print
Screen) drückt. Möchte man das gleiche mittels VBA-Programm machen, so benötigt
man ziemlich viel Code.
Die "Application.Wait"-Codezeile dient nur zu Demonstrationszwecken. Sie bewirkt, dass zwischen Prozedurausführung und Erstellung des Screenshots 5 Sekunden lang gewartet wird. Sie haben dadurch Zeit, ein beliebiges Fenster zu aktivieren. Ohne dieses Warten würde der Screenshot unmittelbar nach dem Prozedurstart und folgedessen immer vom VBA-Editor-Fenster erstellt. Die Codezeile muss in der operativen Version des Programmcodes entfernt werden.
.VBA-Code
'Deklarationsbereich
Type RECT_Type
left As Long
top As Long
right As Long
bottom As Long
End Type
Declare Function GetForegroundWindow Lib "User32" () As Long
Declare Function GetDesktopWindow Lib "User32" () As Long
Declare Sub GetWindowRect Lib "User32" (ByVal Hwnd As Long, lpRect As RECT_Type)
Declare Function GetDC Lib "User32" (ByVal Hwnd As Long) As Long
Declare Function CreateCompatibleDC Lib "Gdi32" (ByVal hdc As Long) As Long
Declare Function CreateCompatibleBitmap Lib "Gdi32" (ByVal hdc As Long, ByVal
nWidth As Long, _
ByVal nHeight As Long) As Long
Declare Function SelectObject Lib "Gdi32" (ByVal hdc As Long, ByVal hObject As
Long) As Long
Declare Function BitBlt Lib "Gdi32" (ByVal hDestDC As Long, ByVal X As Long,
ByVal Y As Long, _
ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, _
ByVal XSrc As Long, ByVal YSrc As Long, ByVal dwRop As Long) As Long
Declare Function OpenClipboard Lib "User32" (ByVal Hwnd As Long) As Long
Declare Function EmptyClipboard Lib "User32" () As Long
Declare Function SetClipboardData Lib "User32" (ByVal wFormat As Long, ByVal
hMem As Long) As Long
Declare Function CloseClipboard Lib "User32" () As Long
Declare Function ReleaseDC Lib "User32" (ByVal Hwnd As Long, ByVal hdc As Long)
As Long
Declare Function DeleteDC Lib "Gdi32" (ByVal hdc As Long) As Long
Const SRCCOPY = &HCC0020
Const CF_BITMAP = 2
'Codemodul
Public Sub MakeScreenshot()
Dim FormHwnd As Long
Dim DeskHwnd As Long
Dim hdc As Long
Dim hdcMem As Long
Dim rect As RECT_Type
Dim junk As Long
Dim fwidth As Long
Dim fheight As Long
Dim hBitmap As Long
Application.Wait Now + TimeValue("0:00:05") '<- Diese Zeile dient nur zu Demonstrationszwecken
DeskHwnd = GetDesktopWindow()
FormHwnd = GetForegroundWindow()
Call GetWindowRect(FormHwnd, rect)
fwidth = rect.right - rect.left
fheight = rect.bottom - rect.top
hdc = GetDC(DeskHwnd)
hdcMem = CreateCompatibleDC(hdc)
hBitmap = CreateCompatibleBitmap(hdc, fwidth, fheight)
If hBitmap <> 0 Then
junk = SelectObject(hdcMem, hBitmap)
junk = BitBlt(hdcMem, 0, 0, fwidth, fheight, hdc, rect.left, rect.top,
SRCCOPY)
junk = OpenClipboard(DeskHwnd)
junk = EmptyClipboard()
junk = SetClipboardData(CF_BITMAP, hBitmap)
junk = CloseClipboard()
End If
junk = DeleteDC(hdcMem)
junk = ReleaseDC(DeskHwnd, hdc)
End Sub
Formatvorlagen "Hyperlink" und "Besuchter Hyperlink" einer Arbeitsmappe löschen
.Beschreibung
Sobald man einer Zelle einen Hyperlink hinzufügt, erstellt
Microsoft Excel automatisch eine Formatvorlage namens "Hyperlink". Wenn Sie
erstmals auf den Hyperlink klicken, wird eine weitere Formatvorlage "Besuchter
Hyperlink" angelegt. Wenn Sie jedoch den Hyperlink entfernen, wird die Formatvorlage
bzw. werden die Formatvorlagen nicht automatisch gelöscht.
Dieses Codebeispiel entfernt die beiden genannten Formatvorlagen aus der aktiven Arbeitsmappe.
.VBA-Code
Public Sub DeleteHyperlinkStyles()
ActiveWorkbook.Styles("Hyperlink").Delete
ActiveWorkbook.Styles("Besuchter Hyperlink").Delete
End Sub
|
Weitere Informationen |
|
Verwandte Codebeispiele |
|
Prüfen, ob die Formatvorlagen "Hyperlink" und "Besuchter Hyperlink" in einer Arbeitsmappe existieren
.Beschreibung
Mit dieser Prozedur wird überprüft, ob sich die beiden
Formatvorlagen "Hyperlink" und "Besuchter Hyperlink" in einer
Arbeitsmappe befinden. Im Beispiel wird die aktive Arbeitsmappe verwendet.
.VBA-Code
Public Sub CheckIfHyperlinkStylesExist()
End Sub
|
Weitere Informationen |
|
Verwandte Codebeispiele |
|
Druckbereich eines Arbeitsblattes festlegen/aufheben
.Beschreibung
In Microsoft Excel kann man via Menübefehl
"Druckbereich" des Menüs "Datei" den Druckbereich eines
Arbeitsblattes festlegen beziehungsweise aufheben. Die nachfolgenden Codebeispiele zeigen
die verschiedenen Möglichkeiten.
» Codebeispiel #1: Legt den Zellbereich A1:C4 als Druckbereich für das aktive Arbeitsblatt fest.
» Codebeispiel #2: Legt den benannten Zellbereich "Mitarbeiter" als Druckbereich für das aktive Arbeitsblatt fest.
» Codebeispiel #3: Legt die Vereinigungsmenge (analog Union) der beiden Zellbereiche A1:C4 und E6:F10 als Druckbereich für das aktive Arbeitsblatt fest.
» Codebeispiel #4: Legt die Schnittmenge (analog Intersect) der beiden Zellbereiche A1:E7 und D4:F10 als Druckbereich für das aktive Arbeitsblatt fest.
» Codebeispiel #5: Legt den Zellbereich A1:C4 als Druckbereich für das Arbeitsblatt "Statistik" fest.
» Codebeispiel #6: Hebt den Druckbereich des aktiven Arbeitsblattes auf.
.VBA-Code #1
Public Sub SetPrintArea1()
ActiveSheet.PageSetup.PrintArea = "A1:C4"
End Sub
.VBA-Code #2
Public Sub SetPrintArea2()
ActiveSheet.PageSetup.PrintArea = "Mitarbeiter"
End Sub
.VBA-Code #3
Public Sub SetPrintArea3()
ActiveSheet.PageSetup.PrintArea = "A1:C4,E6:F10"
End Sub
.VBA-Code #4
Public Sub SetPrintArea4()
ActiveSheet.PageSetup.PrintArea = "A1:E7 D4:F10"
End Sub
.VBA-Code #5
Public Sub SetPrintArea5()
Worksheets("Statistik").PageSetup.PrintArea = "A1:C4"
End Sub
.VBA-Code #6
Public Sub RemovePrintArea()
ActiveSheet.PageSetup.PrintArea = ""
End Sub
|
Weitere Informationen |
|
Verwandte Codebeispiele |
|
Druckbereich eines Arbeitsblattes unter Berücksichtigung vorhandener Zeichnungsobjekte festlegen
.Beschreibung
Wenn man mit VBA den Druckbereich eines Tabellenblattes
festlegen möchte, verwendet man gewöhnlich die UsedRange-Eigenschaft des
Tabellenblattes, welche den benutzten Zellbereich darstellt. Das funktioniert ohne
Probleme, so lange das Blatt keine Objekte enthält, die sich ganz oder teilweise
ausserhalb des benutzten Zellbereiches befinden.
Diese Prozedur ermittelt den Druckbereich unter Berücksichtigung aller Objekte wie AutoFormen, Diagramme, Formular-Steuerelemente, ActiveX-Steuerelemente, eingebettete Dokumente und dergleichen.
.VBA-Code
Public Sub SetPrintArea()
End Sub
|
Weitere Informationen |
Druckbereich eines Arbeitsblattes basierend auf den vorhandenen Zeichnungsobjekten festlegen
.Beschreibung
...
.VBA-Code #1
Public Sub SetPrintAreaForShapes1()
Dim rngPrintArea As Range
Dim rngRangeCheck As Range
Dim intCounter As Integer
With ActiveSheet
Set rngPrintArea = .Range("A1")
For intCounter = 1 To .Shapes.Count
If .Shapes(intCounter).Type <> msoComment Then
Set rngRangeCheck =
Application.Intersect(.Range(rngPrintArea.Address), .Shapes(intCounter).BottomRightCell)
If rngRangeCheck Is Nothing Then
If
.Shapes(intCounter).BottomRightCell.Row - rngPrintArea.Rows.Count > 0 Then
Set rngPrintArea =
rngPrintArea.Resize(.Shapes(intCounter).BottomRightCell.Row)
End If
If
.Shapes(intCounter).BottomRightCell.Column - rngPrintArea.Columns.Count > 0 Then
Set rngPrintArea =
rngPrintArea.Resize(, .Shapes(intCounter).BottomRightCell.Column)
End If
End If
End If
Next intCounter
If rngPrintArea.Cells.Count > 1 Then
.PageSetup.PrintArea = rngPrintArea.Address
End If
End With
Set rngRangeCheck = Nothing
Set rngPrintArea = Nothing
End Sub
.VBA-Code #2
Public Sub SetPrintAreaForShapes2()
Dim rngPrintArea As Range
Dim rngRangeCheck As Range
Dim intCounter As Integer
With ActiveSheet
Set rngPrintArea = .Range("A1")
For intCounter = 1 To .Shapes.Count
If .Shapes(intCounter).Type <> msoComment Then
Set rngRangeCheck =
Application.Intersect(.Range(rngPrintArea.Address), .Shapes(intCounter).BottomRightCell)
If rngRangeCheck Is Nothing Then
Set rngPrintArea =
Application.Union(rngPrintArea, .Range("A1:" &
.Shapes(intCounter).BottomRightCell.Address))
End If
End If
Next intCounter
If rngPrintArea.Cells.Count > 1 Then
.PageSetup.PrintArea = rngPrintArea.Address
End If
End With
Set rngRangeCheck = Nothing
Set rngPrintArea = Nothing
End Sub
|
Weitere Informationen |
Kopf-/Fusszeile eines Arbeitsblattes auf andere Arbeitsblätter übernehmen
.Beschreibung
Das Übernehmen der Kopf- bzw. Fusszeile eines bestimmten
Blattes auf andere Blätter ist äusserst einfach.
.VBA-Code
Public Sub ApplyHeaderFooter()
End Sub
|
Weitere Informationen |
|
Verwandte Codebeispiele |
|
Pfad einer Arbeitsmappe in die Kopf-/Fusszeile eines Arbeitsblattes eintragen
.Beschreibung
In den älteren Versionen von Microsoft Excel kann man nur den
Dateinamen der Arbeitsmappe in die Kopf- bzw. Fusszeile eines Arbeitsblattes einfügen.
Der vollständige Dateipfad steht nicht zur Verfügung.
.VBA-Code
Public Sub AddFilePathToHeaderFooter()
End Sub
|
Weitere Informationen |
|
Verwandte Codebeispiele |
|
Prüfen, ob ein Drucker vorhanden ist
.Beschreibung
Dieses Codebeispiel überprüft, ob ein bestimmter Drucker
vorhanden ist. Diese Information ist insbesondere dann wichtig, wenn Sie den aktiven
Drucker anhand der ActivePrinter-Eigenschaft ändern möchten.
.VBA-Code
Public Sub CheckPrinterAvailable()
End Sub
|
Weitere Informationen |
|
Verwandte Codebeispiele |
Port des aktuell verwendeten Druckers abfragen
.Beschreibung
Dieses Codebeispiel gibt den Port des aktiven Druckers aus.
» Codebeispiel #1: VBA/Excel
» Codebeispiel #2: Visual Basic
.VBA-Code #1
Public Sub GetActivePrinterPort1()
End Sub
.VBA-Code #2
Public Sub GetActivePrinterPort2()
MsgBox "Druckerport: " & Printer.Port
End Sub
|
Weitere Informationen |
|
Verwandte Codebeispiele |
Fenster-Handle (hwnd) eines Steuerelementes ermitteln
.Beschreibung
Noch keine Lösung gefunden!
.VBA-Code
Public Sub GetWindowHandleOfObject()
End Sub
|
Weitere Informationen |
|
Verwandte Codebeispiele |
Ordner-Verknüpfung auf dem Windows Desktop erstellen
.Beschreibung
...
.VBA-Code
Public Sub CreateFolderShortcutOnWindowsDesktop()
End Sub
|
Weitere Informationen |
|
Verwandte Codebeispiele |
Ordner-Verknüpfung im Windows-Startmenü erstellen
.Beschreibung
Das Windows-Startmenü wird geöffnet, indem man auf die
Schaltfläche "Start" der Windows Task-Leiste klickt. Diesem Menü lassen sich
eigene Verknüpfungen hinzufügen, beispielsweise eine Verknüpfung zu einem Ordner.
Dieses Beispiel erstellt eine Verknüpfung zur Datei "Textdatei.txt", die sich im Verzeichnis "C:\Dateien" befindet. Als Arbeitsverzeichnis wird ebenfalls "C:\Dateien" verwendet und der Fensterstil "Normales Fenster" benutzt. Beachten Sie, dass der Verknüpfung eine globale Tastenkombination Strg+Alt+W zugewiesen wird (kann weggelassen werden). Der Pfad des Startmenüs, welches technisch gesehen nichts anderes als ein Ordner ist, wird mit der SpecialFolders-Eigenschaft ermittelt.
.VBA-Code
Public Sub CreateFolderShortcutInWindowsStartMenu()
End Sub
|
Weitere Informationen |
|
Verwandte Codebeispiele |
|
Datei-Verknüpfung im Windows-Startmenü erstellen
.Beschreibung
Das Windows-Startmenü wird geöffnet, indem man auf die
Schaltfläche "Start" der Windows Task-Leiste klickt. Diesem Menü lassen sich
eigene Verknüpfungen hinzufügen, beispielsweise eine Verknüpfung zu einer Datei.
Dieses Beispiel erstellt eine Verknüpfung zur Datei "Textdatei.txt", die sich im Verzeichnis "C:\Dateien" befindet. Als Arbeitsverzeichnis wird ebenfalls "C:\Dateien" verwendet und der Fensterstil "Normales Fenster" benutzt. Beachten Sie, dass der Verknüpfung eine globale Tastenkombination Strg+Alt+W zugewiesen wird (kann weggelassen werden). Der Pfad des Startmenüs, welches technisch gesehen nichts anderes als ein Ordner ist, wird mit der SpecialFolders-Eigenschaft ermittelt.
.VBA-Code
Public Sub CreateFileShortcutInWindowsStartMenu()
Dim objWSHShell As Object
Dim objWSHShortcut As Object
Set objWSHShell = CreateObject("WScript.Shell")
Set objWSHShortcut =
objWSHShell.CreateShortcut(objWSHShell.SpecialFolders("Startmenu") &
"\Dateilink.lnk")
With objWSHShortcut
.TargetPath = "C:\Dateien\Textdatei.txt"
.Hotkey = "ALT+CTRL+W"
.WorkingDirectory = "C:\Dateien"
.WindowStyle = 1 '1=Normales Fenster
.Save
End With
Set objWSHShortcut = Nothing
Set objWSHShell = Nothing
End Sub
|
Weitere Informationen |
|
Verwandte Codebeispiele |
|
Datei-Verknüpfung im Eigene Dateien-Ordner erstellen
.Beschreibung
Dieses Beispiel zeigt, wie man dem Ordner "Eigene
Dateien" eine neue Datei-Verknüpfung hinzufügen kann.
.VBA-Code
Public Sub CreateFileShortcutInMyDocumentsFolder()
End Sub
|
Weitere Informationen |
|
Verwandte Codebeispiele |
Internet-Verknüpfung im Windows-Startmenü erstellen
.Beschreibung
Dieses Beispiel zeigt, wie man dem Windows-Startmenü eine
neue Internet-Verknüpfung hinzufügen kann.
.VBA-Code
Public Sub CreateWebShortcutInWindowsStartMenu()
End Sub
|
Weitere Informationen |
|
Verwandte Codebeispiele |
Systemweite Tastenkombination für eine Datei-Verknüpfung erstellen
.Beschreibung
Windows unterstützt Tastenkombinationen, die systemweit
erkannt werden. Dazu muss man lediglich eine Tastenkombination einer Datei-Verknüpfung im
Windows-Startmenü zuweisen.
.VBA-Code
Public Sub CreateGlobalShortcut()
End Sub
|
Weitere Informationen |
|
Verwandte Codebeispiele |
|
AutoFilter vor dem Speichern einer Arbeitsmappe ausschalten
.Beschreibung
Es gibt zwei gute Gründe, weshalb man einen AutoFilter vor
dem Speichern der Arbeitsmappe ausschalten sollte:
1. Die Arbeitsmappendatei ist kleiner. Alle Datenspalten besitzen beim AutoFilter einen DropDown-Pfeil. Jeder DropDown-Pfeil ist ein kleines grafisches Objekt, das in der xls-Datei gespeichert wird und zirka 300 Bytes Platz beansprucht. Wenn beispielsweise alle 256 Spalten eines Tabellenblattes gefiltert werden können, ist die Exceldatei etwa 76 KB grösser als ohne AutoFilter (256 Spalten × 300 Bytes).
2. Die Arbeitsmappe wird schneller geöffnet. Beim Öffnen einer Mappe mit AutoFilter wird zuerst die Tabelle geladen und dann der AutoFilter angewendet.
...
.VBA-Code
Public Sub DeactivateAutoFilter()
End Sub
|
Weitere Informationen |
Zusätzliche Mappenfenster vor dem Speichern einer Arbeitsmappe schliessen
.Beschreibung
Beim Öffnen einer Arbeitsmappe werden so viele Mappenfenster
geöffnet, wie beim letzten Speichern der Mappe vorhanden waren. Mit diesem Programmcode
werden alle zusätzlichen Fenster der aktiven Arbeitsmappe geschlossen.
.VBA-Code
Public Sub CloseAdditionalWorkbookWindows()
Dim intCounter As Integer
For intCounter = 1 To ActiveWorkbook.Windows.Count - 1
ActiveWorkbook.Windows(1).Close
Next intCounter
End Sub
|
Weitere Informationen |
|
Verwandte Codebeispiele |
Datei als eingebettetes Objekt in ein Arbeitsblatt einfügen
.Beschreibung
In Microsoft Excel werden Objekte anhand des Menübefehls Einfügen/Objekt
in ein Arbeitsblatt eingefügt. Das lässt sich auch mit VBA-Code machen.
.VBA-Code
Public Sub InsertOLEObject()
End Sub
|
Weitere Informationen |
|
Verwandte Codebeispiele |
|
Datei als eingebettetes verknüpftes Objekt in ein Arbeitsblatt einfügen
.Beschreibung
In Microsoft Excel werden Objekte anhand des Menübefehls Einfügen/Objekt
in ein Arbeitsblatt eingefügt. Das lässt sich auch mit VBA-Code machen.
.VBA-Code
Public Sub InsertLinkedOLEObject()
End Sub
|
Weitere Informationen |
|
Verwandte Codebeispiele |
WordArt-Objekt in ein Arbeitsblatt einfügen
.Beschreibung
Dieses Codebeispiel zeigt, wie man ein WordArt-Objekt in ein
Arbeitsblatt einfügen kann.
AddTextEffect-Methode des Shape-Objektes.
.VBA-Code
Public Sub InsertWordArtObject()
End Sub
|
Weitere Informationen |
|
Verwandte Codebeispiele |
Bilddatei in ein Arbeitsblatt einfügen
.Beschreibung
Mit diesem Codebeispiel wird eine Bilddatei in ein
Arbeitsblatt eingefügt.
.VBA-Code
Public Sub InsertPictureObject()
End Sub
|
Weitere Informationen |
|
Verwandte Codebeispiele |
Prüfen, ob eine Schriftart installiert ist
.Beschreibung
Dieses Codebeispiel überprüft, ob eine bestimmte Schriftart
auf dem Computer vorhanden ist.
vbTextCompare, damit Gross-/Kleinschreibung nicht berücksichtigt wird.
Die Konstante strFontname (Prozedur TestCall) enthält die zu überprüfende Schriftart. Im Beispiel wird "Verdana" verwendet.
.VBA-Code
Public Function CheckFont(ByVal strFont As String) As
Boolean
Dim intFonts As Integer
Dim intResult As Integer
Dim objControl As CommandBarComboBox
strFont = Trim$(strFont)
Set objControl = Application.CommandBars.FindControl(Id:=1728)
For intFonts = 0 To objControl.ListCount - 1
intResult = StrComp(strFont, objControl.List(intFonts + 1),
vbTextCompare)
If intResult = 0 Then
CheckFont = True
Exit Function
ElseIf intResult = -1 Then
CheckFont = False
Exit Function
End If
Next intFonts
Set objControl = Nothing
End Function
'*** Aufruf ***
Sub TestCall()
Const strFontname As String = "Verdana"
If CheckFont(strFontname) = True Then
MsgBox "Schriftart '" & strFontname & "' ist
vorhanden.", vbInformation
Else
MsgBox "Schriftart '" & strFontname & "' ist
nicht vorhanden.", vbInformation
End If
End Sub
|
Verwandte Codebeispiele |
Prüfen, ob über den Datei öffnen-Dialog eine Arbeitsmappe geöffnet wurde
.Beschreibung
Immer wenn man dem Benutzer die Möglichkeit anbietet, via
Dialogfenster "Datei öffnen" eine Arbeitsmappendatei auszuwählen und zu
öffnen, sollte man unbedingt überprüfen, ob daraufhin wirklich eine Arbeitsmappe
geöffnet wurde. Allein die Tatsache, dass der Benutzer eine (Arbeitsmappen-)Datei
selektiert und dann die Öffnen-Schaltfläche geklickt hat, bedeutet nämlich noch nicht,
dass die Arbeitsmappe geöffnet und in Form eines Mappenfensters in Microsoft Excel
sichtbar gemacht werden konnte.
.VBA-Code
Public Sub CheckFileOpen()
End Sub
Anführungszeichen in einem Dateipfad entfernen
.Beschreibung
Dateipfade können unter Umständen am Anfang und Ende je ein
Anführungszeichen (") besitzen. Dies ist insbesondere der Fall, wenn der Pfad
Leerzeichen enthält.
Mit dieser Prozedur werden die Anführungszeichen entfernt.
.VBA-Code
Public Sub RemoveHyphen()
End Sub
|
Weitere Informationen |
|
Verwandte Codebeispiele |
Hochkommas am Anfang und Ende eines Dateipfades entfernen
.Beschreibung
...
.VBA-Code
Public Sub RemoveLeadingAndTrailingHyphen()
End Sub
|
Weitere Informationen |
|
Verwandte Codebeispiele |
Dokument-Eigenschaft einer geschlossenen Datei ändern
.Beschreibung
Bei einer geschlossenen Dokument-Datei können folgende
Dokument-Eigenschaften geändert werden (Liste alphabetisch sortiert):
- Autor (Author)
- Kategorie (Category)
- Kommentar (Comments)
- Firma (Company)
- Stichwörter (Keywords)
- Manager (Manager)
- Thema (Subject)
- Titel (Title)
- Zuletzt gespeichert von (LastEditedBy)
- Präsentationsformat (PresentationFormat)
.VBA-Code
Public Sub ModifyDocumentProperty()
End Sub
|
Weitere Informationen |
|
Verwandte Codebeispiele |
|
Benutzerdefinierte Dokument-Eigenschaft einer geschlossenen Datei ändern
.Beschreibung
Das Entfernen einer benutzerdefinierten Dokument-Eigenschaft
einer geschlossenen Dokument-Datei...
.VBA-Code
Public Sub ModifyCustomDocumentProperty()
End Sub
|
Weitere Informationen |
|
Verwandte Codebeispiele |
|
Benutzerdefinierte Dokument-Eigenschaft einer geschlossenen Datei löschen
.Beschreibung
In diesem Beispiel wird angenommen, dass die betroffene Datei
geschlossen, d.h. nicht in Microsoft Excel geöffnet ist. Das Entfernen einer
benutzerdefinierten Dokument-Eigenschaft einer geschlossenen Dokument-Datei erfolgt
mittels Remove-Methode.
.VBA-Code #1
Public Sub DeleteCustomDocumentProperty1()
End Sub
.VBA-Code #2
Public Sub DeleteCustomDocumentProperty2()
CreateObject("DSOleFile.PropertyReader").GetDocumentProperties("C:\Daten\EineMappe.xls").
_
CustomProperties("Ablage").Remove
End Sub
|
Weitere Informationen |
|
Verwandte Codebeispiele |
|
Benutzerdefinierte Dokument-Eigenschaft einer Arbeitsmappe löschen
.Beschreibung
...
.VBA-Code
Public Sub DeleteCustomDocumentProperty()
End Sub
|
Weitere Informationen |
|
Verwandte Codebeispiele |
|
Datei-Verknüpfung im Favoriten-Ordner löschen
.Beschreibung
Dieses Codebeispiel zeigt, wie man eine vorhandene
Datei-Verknüpfung im Favoriten-Ordner löschen kann.
.VBA-Code
Public Sub DeleteLinkInFavoritesFolder()
End Sub
|
Weitere Informationen |
|
Verwandte Codebeispiele |
|
Datei-Verknüpfung im 'Senden an'-Menü des Windows Explorers löschen
.Beschreibung
Wenn man im Windows Explorer eine Datei markiert und dann die
rechte Maustaste drückt, erscheint ein Menü, welches unter anderem das Menüelement
'Senden an' enthält. Wählt man dieses aus, wird eine Liste mit den vorhandenen Zielen
angezeigt, an die die Datei gesendet werden kann. Jedes Ziel ist nichts anderes als eine
Datei-Verknüpfung, die im Unterordner "Senden an" des Profil-Ordners des
aktuellen Benutzers gespeichert ist.
Dieses Codebeispiel zeigt, wie man eine vorhandene Datei-Verknüpfung im 'Senden an'-Menü beziehungsweise in dessen Ordner löschen kann. Als Beispiel wird die Verknüpfung "Editor" verwendet. Da Verknüpfungen immer mit der Dateinamenerweiterung "lnk" angegeben werden müssen, ist die zu löschende Datei-Verknüpfung "Editor.lnk".
.VBA-Code
Public Sub DeleteLinkInSendToFolder()
Const strFilename As String = "Editor.lnk"
Dim objWSHShell As Object
Dim strSendToFolder As String
Set objWSHShell = CreateObject("WScript.Shell")
strSendToFolder = objWSHShell.SpecialFolders("sendto")
If Dir(strSendToFolder & "\" & strFilename, vbHidden) <>
"" Then
Kill strSendToFolder & "\" & strFilename
MsgBox "Die Datei '" & strFilename & " wurde
gelöscht.", vbInformation
Else
MsgBox "Im Senden an-Menü existiert keine Datei '" &
strFilename & "!", vbExclamation
End If
Set objWSHShell = Nothing
End Sub
|
Weitere Informationen |
Dateien des 'Senden an'-Menüs des Windows Explorers auflisten
.Beschreibung
Dieser VBA-Programmcode erstellt eine Liste der Dateien
beziehungsweise Datei-Verknüpfungen des 'Senden an'-Menüs des Windows Explorers. Die
Liste wird auf einem neuen Arbeitsblatt der aktiven Arbeitsmappe erstellt.
.VBA-Code
Public Sub ListFilesInSendToFolder()
End Sub
|
Weitere Informationen |
Eigenes 'Senden an'-Menü bauen
.Beschreibung
...
Nachbauen des 'Senden an'-Menüs.
Der VBA-Code ist ausschliesslich für Visual Basic (Version 4.0 bis 6.0).
Vorbereitung:
- Form hinzufügen.
- Menü mnuSendToParentMenu erstellen, welches ein Untermenü mnuSendToMenu enthält.
- Im Untermenü mnuSendToMenu 15 Menübefehle mit Name mnuSendToLink mit Index 0 bis 15 erstellen.
| KontextMenü | mnuSendToParentMenu | ||||
| Senden an | (Leer) | mnuSendToMenu | mnuSendToLink(0) | ||
| (Leer) | mnuSendToLink(1) | ||||
| (Leer) | mnuSendToLink(2) | ||||
| ... | ... | ||||
| (Leer) | mnuSendToLink(14) |
.VBA-Code
Private Sub mnuSendToParentMenu_Click()
Dim strSendToFolder As String
Dim intCounter As Integer
Dim strFile As String
Dim strLink As String
Dim intChar As Integer
Dim intCharsToRemove As Integer
'Alle 15 Submenü-Elemente des Senden an-Menübefehls
zurücksetzen
For intCounter = 14 To 1 Step -1 'Nicht To 0,
weil mindestens ein Element sichtbar sein muss
mnuSendToLink(intCounter).Visible = False
mnuSendToLink(intCounter).Caption = ""
mnuSendToLink(intCounter).Tag = ""
Next intCounter
mnuSendToLink(0).Visible = True
mnuSendToLink(0).Caption = "(Leer)"
mnuSendToLink(0).Tag = ""
strSendToFolder =
CreateObject("WScript.Shell").SpecialFolders("sendto")
strFile = Dir(strSendToFolder & "\*.*")
intCounter = 0
Do While strFile <> ""
If strFile <> "" Then
intCharsToRemove = 0
For intChar = Len(strFile) To 1 Step -1
If Mid$(strFile, intChar, 1) = "."
Then
intCharsToRemove = Len(strFile) -
intChar
Exit For
End If
Next intChar
strLink = Left$(strFile, Len(strFile) - intCharsToRemove -
1)
mnuSendToLink(intCounter).Visible = True
mnuSendToLink(intCounter).Caption = strLink
mnuSendToLink(intCounter).Tag = strFile
Else
Exit Do
End If
intCounter = intCounter + 1
If intCounter > 14 Then Exit Do
strFile = Dir()
Loop
End Sub
Private Sub mnuSendToLink_Click(Index As Integer)
Dim strFileToSend As String
strFileToSend = "C:\Daten\EineDatei.txt"
CreateObject("WScript.Shell").Run
CreateObject("WScript.Shell").SpecialFolders("sendto") & _
"\" & mnuSendToLink(Index).Tag &
" " & Chr$(34) & strFileToSend & Chr$(34)
End Sub
|
Weitere Informationen |
Prüfen, ob der Benutzer die Berechtigung 'Vollzugriff' für eine bestimmte Datei besitzt
.Beschreibung
Mit diesem Programmcode können Sie überprüfen, ob der
aktuelle Windows-Benutzer sämtliche Berechtigungen (Vollzugriff) für eine bestimmte
Datei besitzt.
Wenn das Dateisystem oder das angesprochene Laufwerk keine Benutzer-Berechtigungen unterstützt, wird davon ausgegangen, dass der Benutzer uneingeschränkten Zugriff besitzt.
.VBA-Code
Public Sub CheckRightsFullAccess()
End Sub
|
Weitere Informationen |
Prüfen, ob der Benutzer die Berechtigung 'Lesen' für eine bestimmte Datei besitzt
.Beschreibung
Mit diesem Programmcode können Sie überprüfen, ob der
aktuelle Windows-Benutzer die Datei-Berechtigungen 'Lesen' für eine bestimmte Datei
besitzt. Es wird ausschliesslich diese Berechtigung kontrolliert. Die Lesen-Berechtigung
regelt das Lesen/Öffnen einer Datei. Wenn diese Berechtigung fehlt, können weder
Dateiinhalt noch Dokument-Eigenschaften (zum Beispiel Titel, Thema, Autor etc. bei einer
Microsoft Excel-Arbeitsmappe) gelesen werden. Eine Arbeitsmappendatei kann ohne die
Lesen-Berechtigung nicht mit Microsoft Excel geöffnet werden. Bei anderen Dateitypen,
beispielsweise bei ausführbaren Dateien, können die Versionsinformationen nicht
angezeigt werden.
Wenn das Dateisystem oder das angesprochene Laufwerk keine Benutzer-Berechtigungen unterstützt, wird davon ausgegangen, dass der Benutzer uneingeschränkten Zugriff besitzt.
.VBA-Code
Public Sub CheckRightsRead()
End Sub
|
Weitere Informationen |
Prüfen, ob der Benutzer die Berechtigung 'Schreiben' für eine bestimmte Datei besitzt
.Beschreibung
Mit diesem Programmcode können Sie überprüfen, ob der
aktuelle Windows-Benutzer die Datei-Berechtigungen 'Schreiben' für eine bestimmte Datei
besitzt. Es wird ausschliesslich diese Berechtigung kontrolliert. Die
Schreiben-Berechtigung regelt das Ändern einer Datei. Wenn diese Berechtigung fehlt, kann
die Datei zwar umbenannt, aber weder ihr Inhalt noch die Datei-Attribute geändert werden.
Wenn bei einer Arbeitsmappendatei die Lesen- aber keine Schreiben-Berechtigung vorhanden
ist, wird die Arbeitsmappe schreibgeschützt geöffnet.
Wenn das Dateisystem oder das angesprochene Laufwerk keine Benutzer-Berechtigungen unterstützt, wird davon ausgegangen, dass der Benutzer uneingeschränkten Zugriff besitzt.
.VBA-Code
Public Sub CheckRightsWrite()
End Sub
|
Weitere Informationen |
Prüfen, ob der Benutzer die Berechtigung 'Löschen' für eine bestimmte Datei besitzt
.Beschreibung
Mit diesem Programmcode können Sie überprüfen, ob der
aktuelle Windows-Benutzer die Datei-Berechtigungen 'Löschen' für eine bestimmte Datei
besitzt. Es wird ausschliesslich diese Berechtigung kontrolliert. Die
Löschen-Berechtigung bestimmt, ob der Benutzer die Datei löschen kann.
Wenn das Dateisystem oder das angesprochene Laufwerk keine Benutzer-Berechtigungen unterstützt, wird davon ausgegangen, dass der Benutzer uneingeschränkten Zugriff besitzt.
.VBA-Code
Public Sub CheckRightsDelete()
End Sub
|
Weitere Informationen |
Prüfen, ob der Benutzer die Berechtigung 'Ausführen' für eine bestimmte Datei besitzt
.Beschreibung
Mit diesem Programmcode können Sie überprüfen, ob der
aktuelle Windows-Benutzer die Datei-Berechtigungen 'Ausführen' für eine bestimmte Datei
besitzt. Es wird ausschliesslich diese Berechtigung kontrolliert. Die
Ausführen-Berechtigung legt fest, ob der Benutzer die (Programm-)Datei ausführen kann.
Bei nicht vorhandener Berechtigung erscheint beim Versuch, die Datei auszuführen, die
Fehlermeldung "Der Zugriff auf das angegebene Gerät, den Pfad oder die Datei wurde
verweigert".
Wenn das Dateisystem oder das angesprochene Laufwerk keine Benutzer-Berechtigungen unterstützt, wird davon ausgegangen, dass der Benutzer uneingeschränkten Zugriff besitzt.
.VBA-Code
Public Sub CheckRightsExecute()
End Sub
|
Weitere Informationen |
Prüfen, ob der Benutzer die Berechtigung 'Besitz übernehmen' für eine bestimmte Datei besitzt
.Beschreibung
Mit diesem Programmcode können Sie überprüfen, ob der
aktuelle Windows-Benutzer die Datei-Berechtigungen 'Besitz übernehmen' für eine
bestimmte Datei besitzt. Es wird ausschliesslich diese Berechtigung kontrolliert. Die
Besitz übernehmen-Berechtigung bestimmt, ob der aktuelle Benutzer den Besitz einer Datei
übernehmen kann.
Wenn das Dateisystem oder das angesprochene Laufwerk keine Benutzer-Berechtigungen unterstützt, wird davon ausgegangen, dass der Benutzer uneingeschränkten Zugriff besitzt.
.VBA-Code
Public Sub CheckRightsChangeOwner()
End Sub
|
Weitere Informationen |
Dateien eines Ordners mit Datei-Berechtigungen des Benutzers auflisten
.Beschreibung
Die beiden hier vorgestellten Codebeispiele erstellen eine
Liste der Dateien eines Ordners. Zu jeder Datei wird angegeben, welche
Datei-Berechtigungen der aktuelle Benutzer besitzt.
| Berechtigung | Buchstabe | Konstante |
| Vollzugriff | F | FILE_ALL_ACCESS |
| Lesen | R | FILE_GENERIC_READ |
| Schreiben | W | FILE_GENERIC_WRITE |
| Ausführen | X | FILE_GENERIC_EXECUTE |
| Löschen | D | DELETE |
| Besitz übernehmen | O | WRITE_OWNER |
.VBA-Code #1
Public Sub ListFilesWithAccessRights1()
Dim objFolder As Object
Dim objFile As Object
Dim wksSheet As Worksheet
Dim intCounter As Integer
Set objFolder =
CreateObject("Scripting.FileSystemObject").GetFolder("C:\Daten")
If objFolder.Files.Count = 0 Then
MsgBox "Der Ordner enthält keine Dateien.", vbInformation
Set objFolder = Nothing
Exit Sub
End If
Set wksSheet = ActiveWorkbook.Worksheets.Add
With wksSheet
.Range("A1").Value = "Dateien von Ordner " &
objFolder.Path
.Range("A1").Font.Bold = True
.Range("A3:B3").Value = Array("Datei",
"Berechtigungen")
.Range("A3:B3").Font.Bold = True
End With
intCounter = 3
For Each objFile In objFolder.Files
intCounter = intCounter + 1
With wksSheet
.Cells(intCounter, 1).Value = objFile.Name
If CheckFileAccess(objFile.Path, FILE_ALL_ACCESS) =
FILE_ALL_ACCESS Then
.Cells(intCounter, 2).Value = "F"
Else
If CheckFileAccess(objFile.Path,
FILE_GENERIC_READ) = FILE_GENERIC_READ Then
.Cells(intCounter, 2).Value =
.Cells(intCounter, 2).Value & "R"
End If
If CheckFileAccess(objFile.Path,
FILE_GENERIC_WRITE) = FILE_GENERIC_WRITE Then
.Cells(intCounter, 2).Value =
.Cells(intCounter, 2).Value & "W"
End If
If CheckFileAccess(objFile.Path,
FILE_GENERIC_EXECUTE) = FILE_GENERIC_EXECUTE Then
.Cells(intCounter, 2).Value =
.Cells(intCounter, 2).Value & "X"
End If
If CheckFileAccess(objFile.Path, DELETE) =
DELETE Then
.Cells(intCounter, 2).Value =
.Cells(intCounter, 2).Value & "D"
End If
If CheckFileAccess(objFile.Path, WRITE_OWNER) =
WRITE_OWNER Then
.Cells(intCounter, 2).Value =
.Cells(intCounter, 2).Value & "O"
End If
End If
End With
Next
wksSheet.Columns("A:B").AutoFit
Set objFolder = Nothing
Set wksSheet = Nothing
End Sub
.VBA-Code #2
Public Sub ListFilesWithAccessRights2()
Dim objFolder As Object
Dim objFile As Object
Dim wksSheet As Worksheet
Dim intCounter As Integer
Set objFolder =
CreateObject("Scripting.FileSystemObject").GetFolder("C:\Daten")
If objFolder.Files.Count = 0 Then
MsgBox "Der Ordner enthält keine Dateien.", vbInformation
Set objFolder = Nothing
Exit Sub
End If
Set wksSheet = ActiveWorkbook.Worksheets.Add
With wksSheet
.Range("A1").Value = "Dateien von Ordner " &
objFolder.Path
.Range("A1").Font.Bold = True
.Range("A3:G3").Value = Array("Datei",
"Vollzugriff (F)", "Lesen (R)", "Schreiben (W)", _
"Ausführen (X)",
"Löschen (D)", "Besitz übernehmen (O)")
.Range("A3:G3").Font.Bold = True
End With
intCounter = 3
For Each objFile In objFolder.Files
intCounter = intCounter + 1
With wksSheet
.Cells(intCounter, 1).Value = objFile.Name
.Cells(intCounter, 2).Value =
CBool(CheckFileAccess(objFile.Path, FILE_ALL_ACCESS) = FILE_ALL_ACCESS)
.Cells(intCounter, 3).Value =
CBool(CheckFileAccess(objFile.Path, FILE_GENERIC_READ) = FILE_GENERIC_READ)
.Cells(intCounter, 4).Value =
CBool(CheckFileAccess(objFile.Path, FILE_GENERIC_WRITE) = FILE_GENERIC_WRITE)
.Cells(intCounter, 5).Value =
CBool(CheckFileAccess(objFile.Path, FILE_GENERIC_EXECUTE) = FILE_GENERIC_EXECUTE)
.Cells(intCounter, 6).Value =
CBool(CheckFileAccess(objFile.Path, DELETE) = DELETE)
.Cells(intCounter, 7).Value =
CBool(CheckFileAccess(objFile.Path, WRITE_OWNER) = WRITE_OWNER)
End With
Next
wksSheet.Columns("A:G").AutoFit
Set objFolder = Nothing
Set wksSheet = Nothing
End Sub
Unterordner eines Ordners mit Verzeichnis-Berechtigungen des Benutzers auflisten
.Beschreibung
Die beiden hier vorgestellten Codebeispiele erstellen eine
Liste der in einem bestimmten Ordner enthaltenen Unterordner, und geben zu jedem
Unterordner die Berechtigungen des aktuellen Benutzers an.
.VBA-Code
Public Sub ListFoldersWithAccessRights()
End Sub
Datei-Berechtigungen des Benutzers für eine bestimmte Datei abfragen
.Beschreibung
Beschreibung folgt.
Abfragen, welche Berechtigungen der angemeldete Benutzer für eine bestimmte Datei besitzt.
Wenn
- das Betriebssystem nicht vom Typ Windows NT ist (d.h. Windows NT 4.0, Windows
2000 oder Windows XP) oder
- das Dateisystem des angesprochenen Laufwerkes keine Berechtigungen unterstützt
oder
- für die Datei keine Security-Informationen vorhanden sind,
dann gibt die Funktion CheckFileAccess generell Wahr (bzw. True)
zurück, weil der Benutzer uneingeschränkten Zugriff auf die Datei besitzt.
Diese Berechtigungen können für Dateien abgefragt werden:
| Berechtigung | Buchstabe | Konstante |
| Lesen | R | FILE_GENERIC_READ |
| Schreiben | W | FILE_GENERIC_WRITE |
| Ausführen | X | FILE_GENERIC_EXECUTE |
| Löschen | D | DELETE |
| Berechtigungen ändern | P | WRITE_DAC |
| Besitz übernehmen | O | WRITE_OWNER |
| Vollzugriff | - | FILE_ALL_ACCESS |
.Autor
Sergey Merzlikin (Anpassungen durch Philipp
von Wartburg)
.VBA-Code
'Deklarationsbereich
'''Desired access rights constants
Public Const MAXIMUM_ALLOWED As Long = &H2000000
Public Const DELETE As Long = &H10000
Public Const READ_CONTROL As Long = &H20000
Public Const WRITE_DAC As Long = &H40000
Public Const WRITE_OWNER As Long = &H80000
Public Const SYNCHRONIZE As Long = &H100000
Public Const STANDARD_RIGHTS_READ As Long = READ_CONTROL
Public Const STANDARD_RIGHTS_WRITE As Long = READ_CONTROL
Public Const STANDARD_RIGHTS_EXECUTE As Long = READ_CONTROL
Public Const STANDARD_RIGHTS_REQUIRED As Long = &HF0000
Public Const FILE_READ_DATA As Long = &H1
Public Const FILE_LIST_DIRECTORY As Long = &H1
Public Const FILE_ADD_FILE As Long = &H2
Public Const FILE_WRITE_DATA As Long = &H2
Public Const FILE_CREATE_PIPE_INSTANCE As Long = &H4
Public Const FILE_ADD_SUBDIRECTORY As Long = &H4
Public Const FILE_APPEND_DATA As Long = &H4
Public Const FILE_READ_EA As Long = &H8
Public Const FILE_READ_PROPERTIES As Long = FILE_READ_EA
Public Const FILE_WRITE_EA As Long = &H10
Public Const FILE_WRITE_PROPERTIES As Long = FILE_WRITE_EA
Public Const FILE_EXECUTE As Long = &H20
Public Const FILE_TRAVERSE As Long = &H20
Public Const FILE_DELETE_CHILD As Long = &H40
Public Const FILE_READ_ATTRIBUTES As Long = &H80
Public Const FILE_WRITE_ATTRIBUTES As Long = &H100
Public Const FILE_GENERIC_READ As Long = (STANDARD_RIGHTS_READ _
Or FILE_READ_DATA Or FILE_READ_ATTRIBUTES Or FILE_READ_EA Or
SYNCHRONIZE)
Public Const FILE_GENERIC_WRITE As Long = (STANDARD_RIGHTS_WRITE _
Or FILE_WRITE_DATA Or FILE_WRITE_ATTRIBUTES _
Or FILE_WRITE_EA Or FILE_APPEND_DATA Or SYNCHRONIZE)
Public Const FILE_GENERIC_EXECUTE As Long = (STANDARD_RIGHTS_EXECUTE _
Or FILE_READ_ATTRIBUTES Or FILE_EXECUTE Or SYNCHRONIZE)
Public Const FILE_ALL_ACCESS As Long = (STANDARD_RIGHTS_REQUIRED _
Or SYNCHRONIZE Or &H1FF&)
Public Const GENERIC_READ As Long = &H80000000
Public Const GENERIC_WRITE As Long = &H40000000
Public Const GENERIC_EXECUTE As Long = &H20000000
Public Const GENERIC_ALL As Long = &H10000000
'''Types, constants and functions to work with access rights
Public Const OWNER_SECURITY_INFORMATION As Long = &H1
Public Const GROUP_SECURITY_INFORMATION As Long = &H2
Public Const DACL_SECURITY_INFORMATION As Long = &H4
Public Const TOKEN_QUERY As Long = 8
Public Const SecurityImpersonation As Integer = 3
Public Const ANYSIZE_ARRAY = 1
Public Type GENERIC_MAPPING
GenericRead As Long
GenericWrite As Long
GenericExecute As Long
GenericAll As Long
End Type
Public Type LUID
LowPart As Long
HighPart As Long
End Type
Public Type LUID_AND_ATTRIBUTES
pLuid As LUID
Attributes As Long
End Type
Public Type PRIVILEGE_SET
PrivilegeCount As Long
Control As Long
Privilege(ANYSIZE_ARRAY) As LUID_AND_ATTRIBUTES
End Type
Public Declare Function GetFileSecurity Lib "advapi32.dll" _
Alias "GetFileSecurityA" (ByVal lpFileName As String, _
ByVal RequestedInformation As Long, pSecurityDescriptor As Byte, _
ByVal nLength As Long, lpnLengthNeeded As Long) As Long
Public Declare Function AccessCheck Lib "advapi32.dll" _
(pSecurityDescriptor As Byte, ByVal ClientToken As Long, _
ByVal DesiredAccess As Long, GenericMapping As GENERIC_MAPPING, _
PrivilegeSet As PRIVILEGE_SET, PrivilegeSetLength As Long, _
GrantedAccess As Long, Status As Long) As Long
Public Declare Function ImpersonateSelf Lib "advapi32.dll" _
(ByVal ImpersonationLevel As Integer) As Long
Public Declare Function RevertToSelf Lib "advapi32.dll" () As Long
Public Declare Sub MapGenericMask Lib "advapi32.dll" (AccessMask As Long, _
GenericMapping As GENERIC_MAPPING)
Public Declare Function OpenThreadToken Lib "advapi32.dll" _
(ByVal ThreadHandle As Long, ByVal DesiredAccess As Long, _
ByVal OpenAsSelf As Long, TokenHandle As Long) As Long
Public Declare Function GetCurrentThread Lib "kernel32" () As Long
Public Declare Function CloseHandle Lib "kernel32" _
(ByVal hObject As Long) As Long
'''Types, constants and functions for OS version detection
Public Type OSVERSIONINFO
dwOSVersionInfoSize As Long
dwMajorVersion As Long
dwMinorVersion As Long
dwBuildNumber As Long
dwPlatformId As Long
szCSDVersion As String * 128
End Type
Public Const VER_PLATFORM_WIN32_NT As Long = 2
Public Declare Function GetVersionEx Lib "kernel32" Alias
"GetVersionExA" _
(lpVersionInformation As OSVERSIONINFO) As Long
'''Constant and function for detection of support of access rights
by file system
Public Const FS_PERSISTENT_ACLS As Long = &H8
Public Declare Function GetVolumeInformation Lib "kernel32" _
Alias "GetVolumeInformationA" (ByVal lpRootPathName As
String, _
ByVal lpVolumeNameBuffer As String, ByVal nVolumeNameSize As Long, _
lpVolumeSerialNumber As Long, lpMaximumComponentLength As Long, _
lpFileSystemFlags As Long, ByVal lpFileSystemNameBuffer As String, _
ByVal nFileSystemNameSize As Long) As Long
'Codemodul
Public Function CheckFileAccess(Filename As String, ByVal
DesiredAccess As Long) As Long
'CheckFileAccess function checks access rights to given file.
'DesiredAccess - bitmask of desired access rights.
'The function returns bitmask, which contains those bits of desired bitmask,
'which correspond with existing access rights.
Dim r As Long, SecDesc() As Byte, SDSize As Long, hToken As Long
Dim PrivSet As PRIVILEGE_SET, GenMap As GENERIC_MAPPING
Dim Volume As String, FSFlags As Long
'Checking OS type
If Not IsNT() Then
'Rights not supported. Returning -1.
CheckFileAccess = -1
Exit Function
End If
'Checking access rights support by file system
If Left$(Filename, 2) = "\\" Then
'Path in UNC format. Extracting share name from
it
r = InStr(3, Filename, "\")
If r = 0 Then
Volume = Filename & "\"
Else
Volume = Left$(Filename, r)
End If
ElseIf Mid$(Filename, 2, 2) = ":\" Then
'Path begins with drive letter
Volume = Left$(Filename, 3)
Else
'If path not set, we are leaving Volume blank.
'It retutns information about current drive.
End If
'Getting information about drive
GetVolumeInformation Volume, vbNullString, 0, ByVal 0&, ByVal 0&,
FSFlags, vbNullString, 0
If (FSFlags And FS_PERSISTENT_ACLS) = 0 Then
'Rights not supported.
Returning -1.
CheckFileAccess = -1
Exit Function
End If
'Determination of buffer size
GetFileSecurity Filename, OWNER_SECURITY_INFORMATION Or GROUP_SECURITY_INFORMATION
_
Or DACL_SECURITY_INFORMATION, 0, 0, SDSize
If Err.LastDllError <> 122 Then
'Rights not supported.
Returning -1.
CheckFileAccess = -1
Exit Function
End If
If SDSize = 0 Then Exit Function
ReDim SecDesc(1 To SDSize)
'Once more call of function to obtain Security Descriptor
If GetFileSecurity(Filename, OWNER_SECURITY_INFORMATION Or
GROUP_SECURITY_INFORMATION _
Or DACL_SECURITY_INFORMATION, SecDesc(1), SDSize, SDSize) =
0 Then
'Error. We must return no access rights.
CheckFileAccess = -1
Exit Function
End If
'Adding Impersonation Token for thread
ImpersonateSelf SecurityImpersonation
'Opening of Token of current thread
OpenThreadToken GetCurrentThread(), TOKEN_QUERY, 0, hToken
If hToken <> 0 Then
'Filling GenericMask type
GenMap.GenericRead = FILE_GENERIC_READ
GenMap.GenericWrite = FILE_GENERIC_WRITE
GenMap.GenericExecute = FILE_GENERIC_EXECUTE
GenMap.GenericAll = FILE_ALL_ACCESS
'Conversion of generic rights to specific file
access rights
MapGenericMask DesiredAccess, GenMap
'Checking access
AccessCheck SecDesc(1), hToken, DesiredAccess, GenMap, PrivSet,
Len(PrivSet), CheckFileAccess, r
CloseHandle hToken
End If
'Deleting Impersonation Token
RevertToSelf
End Function
Public Function IsNT() As Boolean
'IsNT() function returns True, if the program works in
Windows NT,
'Windows 2000 or Windows XP operating system, and False otherwise.
Dim OSVer As OSVERSIONINFO
OSVer.dwOSVersionInfoSize = Len(OSVer)
GetVersionEx OSVer
IsNT = (OSVer.dwPlatformId = VER_PLATFORM_WIN32_NT)
End Function
'*** Aufruf ***
Sub TestCall()
Dim bolAccessRead As Boolean
Dim bolAccessWrite As Boolean
bolAccessRead = CheckFileAccess("C:\Daten\EineMappe.xls",
FILE_GENERIC_READ) = FILE_GENERIC_READ
MsgBox "Lesen-Berechtigung vorhanden: " & bolAccessRead
bolAccessWrite = CheckFileAccess("C:\Daten\EineMappe.xls",
FILE_GENERIC_WRITE) = FILE_GENERIC_WRITE
MsgBox "Schreiben-Berechtigung vorhanden: " & bolAccessWrite
End Sub
Verzeichnis-Berechtigungen des Benutzers für einen bestimmten Ordner abfragen
.Beschreibung
Abfragen, welche Berechtigungen der angemeldete Benutzer für
einen bestimmten Ordner besitzt.
Wenn
- das Betriebssystem nicht vom Typ Windows NT ist (d.h. Windows NT 4.0, Windows
2000 oder Windows XP) oder
- das Dateisystem des angesprochenen Laufwerkes keine Berechtigungen unterstützt
oder
- für den Ordner keine Security-Informationen vorhanden sind,
dann gibt die Funktion CheckFolderAccess generell Wahr (bzw. True)
zurück, weil der Benutzer uneingeschränkten Zugriff auf den Ordner besitzt.
Diese Berechtigungen können für Ordner abgefragt werden:
| Berechtigung | Buchstabe | Konstante |
| Lesen | R | FILE_GENERIC_READ |
| Schreiben | W | FILE_GENERIC_WRITE |
| Ausführen | X | FILE_GENERIC_EXECUTE |
| Berechtigungen ändern | P | WRITE_DAC |
| Besitz übernehmen | O | WRITE_OWNER |
| Anzeigen | V | FILE_LIST_DIRECTORY |
| Datei hinzufügen | A | FILE_ADD_FILE |
| Ordner hinzufügen | S | FILE_ADD_SUBDIRECTORY |
| Vollzugriff | - | FILE_ALL_ACCESS |
.VBA-Code
Public Sub ToDo()
End Sub
Prüfen, ob ein Laufwerk Datei-/Verzeichnis-Berechtigungen unterstützt
.Beschreibung
Nur neuere Dateisysteme wie unter anderem NTFS unterstützen
Zugriffsberechtigungen für Dateien und Verzeichnisse. Ältere Dateisysteme wie FAT oder
DOS dagegen bieten diese Unterstützung nicht. Dieses Codebeispiel zeigt, wie Sie
überprüfen können, ob ein bestimmtes Laufwerk solche Berechtigungen unterstützt.
Bevor man eine Datei öffnet, sollte man kontrollieren, ob der Benutzer genügend Berechtigungen für das Öffnen (sprich Lesen der Datei) besitzt. Noch vor dieser Kontrolle sollte man jedoch überprüfen, ob das Laufwerk, auf welchem sich die Datei befindet, überhaupt Berechtigungen unterstützt. Ist dies nämlich nicht der Fall, ist die Kontrolle der Lesen-Berechtigung hinfällig.
.VBA-Code
Public Sub CheckDriveRightsSupport()
End Sub
|
Verwandte Codebeispiele |
|
Prüfen, ob das Betriebssystem Datei-/Verzeichnis-Berechtigungen unterstützt
.Beschreibung
Nicht alle Betriebssysteme beziehungsweise Windows-Versionen
unterstützen Zugriffsberechtigungen für Dateien und Verzeichnisse. Unterstützt werden
diese nur von den Windows-Versionen vom Typ Windows NT, (d.h. Windows NT 4.0, Windows 2000
und Windows XP.
Bevor man eine Datei öffnet, sollte man kontrollieren, ob der Benutzer genügend Berechtigungen für das Öffnen (sprich Lesen der Datei) besitzt. Noch vor dieser Kontrolle sollte man jedoch überprüfen, ob das verwendete Betriebssystem überhaupt Berechtigungen unterstützt. Ist dies nämlich nicht der Fall, ist die Kontrolle der Lesen-Berechtigung hinfällig.
.VBA-Code
Public Sub CheckOSRightsSupport()
End Sub
|
Verwandte Codebeispiele |
|
Prüfen, ob eine Arbeitsmappe geschützt ist (Arbeitsmappenschutz)
.Beschreibung
Dieses Codebeispiel überprüft, ob eine Arbeitsmappe mit
einem Arbeitsmappenschutz versehen ist. Über die Benutzeroberfläche von Microsoft Excel
wird der Mappenschutz über den Menübefehl Extras/Schutz/Arbeitsmappe
aktiviert.
ProtectStructure
ProtectWindows
.VBA-Code
Public Sub CheckBookProtection()
End Sub
|
Weitere Informationen |
|
Verwandte Codebeispiele |
Prüfen, ob ein Arbeitsblatt geschützt ist (Blattschutz)
.Beschreibung
Die hier vorgestellten VBA-Codebeispiele überprüfen, ob ein
bestimmtes Arbeitsblatt mit einen Blattschutz versehen ist. Über die Benutzeroberfläche
von Microsoft Excel wird der Blattschutz über den Menübefehl Extras/Schutz/Blatt
aktiviert.
» Codebeispiel #1: Es existieren drei Eigenschaften des Worksheet-Objektes, die im Zusammenhang mit dem Blattschutz relevant sind: ProtectContents, ProtectDrawingObjects und ProtectScenarios. Wenn man wissen möchte, ob ein Blatt geschützt ist, muss man daher gewöhnlich alle drei Eigenschaften abfragen. Die Schwierigkeit dabei ist allerdings, dass nicht alle Blatttypen die drei Eigenschaften gleichermassen unterstützen. Die folgende Tabelle zeigt die jeweilige Verfügbarkeit pro Blatttyp (Spezialfälle sind rot markiert):
| Blatttyp | ProtectContents | ProtectDrawingObjects | ProtectScenarios |
| Tabellenblatt | Unterstützt | Unterstützt | Unterstützt |
| Diagrammblatt | Unterstützt | Unterstützt | Nicht unterstützt. Laufzeitfehler 438 "Objekt unterstützt diese Eigenschaft oder Methode nicht" tritt auf. |
| Excel 4.0-Makroblatt | Unterstützt | Unterstützt | Unterstützt. Bei aktivem Blattschutz immer True. |
| Internationales Makroblatt | Unterstützt | Unterstützt | Unterstützt. Bei aktivem Blattschutz immer True. |
| Dialogblatt | Unterstützt. Immer False (auch bei aktivem Blattschutz). |
Unterstützt | Unterstützt |
Beispielsweise bei einem Diagrammblatt führt der Zugriff auf ProtectScenarios zum Laufzeitfehler 438 "Objekt unterstützt diese Eigenschaft oder Methode nicht". Und die Eigenschaft ProtectContents gibt bei einem Dialogblatt immer False zurück, egal ob der Blattschutz aktiv ist oder nicht.
» Codebeispiel #2: Dieses Codebeispiel zeigt einen völlig anderen Lösungsansatz. Weil in Microsoft Excel je nach vorhandenem Blattschutz der Menübefehl für den Blattschutz unter Extras/Schutz automatisch korrekt beschriftet wird, kann man anhand dieser Beschriftung feststellen, ob das aktive Blatt geschützt ist. Das dazu benötigte Symbolleisten-Steuerelement besitzt die ID 893. Wenn die Menüelement-Beschriftung "Blatt..." lautet, dann ist kein Schutz vorhanden. Wenn sie dagegen "Blattschutz aufheben..." lautet, ist das Blatt geschützt.
Bitte beachten Sie, dass diese Lösung nur in einer deutschsprachigen Excelversion funktioniert. Ausserdem muss der benötigte Menüelement vorhanden sein. Wenn es beispielsweise durch den Benutzer entfernt wurde, tritt der Laufzeitfehler 91 "Objektvariable oder With-Blockvariable nicht festgelegt" auf. Trotz diesen beiden Einschränkungen ist diese Lösung sehr hilfreich, wenn man beispielsweise wissen möchte, ob bei einem Diagrammblatt nur die Benutzeroberfläche gesperrt ist. In diesem Fall geben die drei Eigenschaften ProtectContents, ProtectDrawingObjects und ProtectsScenarios False zurück, obwohl ein Blattschutz vorhanden ist.
.VBA-Code #1
'Codemodul
Function CheckSheetProtection(objSheet As Object) As
Boolean
Dim bolProtection As Boolean
On Error Resume Next
bolProtection = objSheet.ProtectContents
If Err.Number <> 0 Then
bolProtection = False
Err.Clear
End If
If bolProtection = True Then
CheckSheetProtection = True
Exit Function
End If
bolProtection = objSheet.ProtectDrawingObjects
If Err.Number <> 0 Then
bolProtection = False
Err.Clear
End If
If bolProtection = True Then
CheckSheetProtection = True
Exit Function
End If
bolProtection = objSheet.ProtectScenarios
If Err.Number <> 0 Then
bolProtection = False
Err.Clear
End If
If bolProtection = True Then
CheckSheetProtection = True
End If
End Function
'*** Aufruf ***
Sub TestCall()
MsgBox "Blattschutz aktiv: " & CheckSheetProtection(ActiveSheet)
End Sub
.VBA-Code #2
Public Sub CheckProtection()
If InStr(CommandBars.FindControl(Id:=893).Caption, "aufheben") Then
MsgBox "Das aktive Blatt ist geschützt.", vbInformation
Else
MsgBox "Das aktive Blatt ist nicht geschützt.",
vbInformation
End If
End Sub
|
Weitere Informationen |
|
Verwandte Codebeispiele |
Prüfen, ob ein Diagrammblatt geschützt ist (Blattschutz)
.Beschreibung
Dieses Codebeispiel findet heraus, ob ein Diagramm mit einem
Blattschutz versehen ist.
.VBA-Code
Public Sub CheckSheetProtection()
If InStr(Application.CommandBars.FindControl(Id:=893).Caption,
"aufheben") Then
MsgBox "Das aktive Blatt ist geschützt.", vbInformation
Else
MsgBox "Das aktive Blatt ist nicht geschützt.",
vbInformation
End If
End Sub
|
Weitere Informationen |
|
Verwandte Codebeispiele |
Prüfen, ob ein Arbeitsmappenschutz ein Kennwort verwendet
.Beschreibung
Dieses Codebeispiel ermittelt, ob der Arbeitsmappenschutz ein
Kennwort verwendet.
.VBA-Code
Public Sub CheckIfBookProtectionHasPassword()
End Sub
|
Weitere Informationen |
|
Verwandte Codebeispiele |
|
Prüfen, ob ein Blattschutz ein Kennwort verwendet
.Beschreibung
Dieses Codebeispiel ermittelt, ob ein Blattschutz ein Kennwort
verwendet.
.VBA-Code
Public Sub CheckIfSheetProtectionHasPassword()
End Sub
|
Weitere Informationen |
|
Verwandte Codebeispiele |
|
Blattschutz eines Arbeitsblattes entfernen
.Beschreibung
Dieses Codebeispiel entfernt den Blattschutz eines
Arbeitsblattes. Im Beispiel wird das aktive Arbeitsblatt verwendet.
.VBA-Code #1
Public Sub RemoveSheetProtection1()
ActiveSheet.Unprotect
End Sub
.VBA-Code #2
Public Sub RemoveSheetProtection2()
ActiveSheet.Unprotect "Sommer"
End Sub
|
Weitere Informationen |
|
Verwandte Codebeispiele |
|
Arbeitsmappenschutz einer Arbeitsmappe entfernen
.Beschreibung
Mit diesem VBA-Code wird der Schutz einer Arbeitsmappe
aufgehoben. Im Beispiel wird die aktive Arbeitsmappe verwendet.
.VBA-Code #1
Public Sub RemoveBookProtection1()
ActiveWorkbook.Unprotect
End Sub
.VBA-Code #2
Public Sub RemoveBookProtection2()
ActiveWorkbook.Unprotect "Sommer"
End Sub
|
Weitere Informationen |
|
Verwandte Codebeispiele |
|
Namen der exe-Dateien der installierten Programme zum Auswählen in ListBox füllen
.Beschreibung
Dieses Codebeispiel füllt eine ListBox (oder ComboBox) mit
den Namen der exe-Dateien der auf dem Computer installierten Programme.
Legen Sie ein VBA-Projekt mit einem Codemodul und einem Benutzerformular an. Ordnen Sie auf dem Benutzerformular eine ListBox an und geben dieser den Namen lstApps. Fügen Sie den nachstehenden Programmcode in die angegebenen Module ein.
Der VBA-Code funktioniert in allen Microsoft Office-Programmen. Er kann auch in einem Visual Basic-Projekt verwendet werden, wenn die Prozedur UserForm_Initialize in Form_Load umbenannt wird.
.VBA-Code
'Deklarationsbereich des Codemoduls
Public Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
Public Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias
"RegOpenKeyExA" _
(ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As
Long, _
ByVal samDesired As Long, phkResult As Long) As Long
Public Declare Function RegEnumKeyEx Lib "advapi32.dll" Alias
"RegEnumKeyExA" _
(ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpName As String, _
lpcbName As Long, ByVal lpReserved As Long, ByVal lpClass As String, _
lpcbClass As Long, lpftLastWriteTime As FILETIME) As Long
Public Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As
Long
'Codemodul
Public Function EnumInstalledApps() As Collection
Dim AddressofOpenKey As Long
Dim bolFunctionResult As Boolean
Dim udtFileTimeStruc As FILETIME
Dim strAppName As String
Dim strAppNameLen As Long
Dim intAppIndex As Integer
Const KEY_ENUMERATE_SUB_KEYS = &H8
Const HKEY_LOCAL_MACHINE = &H80000002
Set EnumInstalledApps = New Collection
intAppIndex = 0
bolFunctionResult = Not CBool(RegOpenKeyEx(hKey:=HKEY_LOCAL_MACHINE, _
lpSubKey:="SOFTWARE\Microsoft\Windows\CurrentVersion\App Paths", ulOptions:=0, _
samDesired:=KEY_ENUMERATE_SUB_KEYS,
phkResult:=AddressofOpenKey))
If bolFunctionResult = False Then GoTo ErrorHandler
Do
strAppNameLen = 255
strAppName = String(strAppNameLen, CStr(0))
bolFunctionResult = Not CBool(RegEnumKeyEx(hKey:=AddressofOpenKey,
dwIndex:=intAppIndex, _
lpName:=strAppName, lpcbName:=strAppNameLen,
lpReserved:=0, lpClass:=vbNullString, _
lpcbClass:=0,
lpftLastWriteTime:=udtFileTimeStruc))
If bolFunctionResult = False Then Exit Do
intAppIndex = intAppIndex + 1
strAppName = Left(strAppName, strAppNameLen)
On Error Resume Next
EnumInstalledApps.Add strAppName
On Error GoTo 0
Loop
Call RegCloseKey(AddressofOpenKey)
Exit Function
ErrorHandler:
If Not AddressofOpenKey = 0 Then
Call RegCloseKey(AddressofOpenKey)
End If
Set EnumInstalledApps = Nothing
End Function
'Codemodul des Benutzerformulares
Private Sub UserForm_Initialize()
Dim aApps As Variant
On Error Resume Next
For Each aApps In EnumInstalledApps
lstApps.AddItem aApps
Next aApps
End Sub
|
Weitere Informationen |
|
Verwandte Codebeispiele |
|
Pfade der exe-Dateien der installierten Programme zum Auswählen in ListBox füllen
.Beschreibung
Hier wird gezeigt, wie man die auf dem Computer installierten
Programme herausfinden kann und zu jedem Programm den Pfad der exe-Datei in eine ListBox
(oder ComboBox) eines Benutzerformulares einfüllt.
Legen Sie ein VBA-Projekt mit einem Codemodul und einem Benutzerformular an. Ordnen Sie auf dem Benutzerformular eine ListBox an und geben dieser den Namen lstApps. Fügen Sie den nachstehenden Programmcode in die angegebenen Module ein.
Der VBA-Code funktioniert in allen Microsoft Office-Programmen. Er kann auch in einem Visual Basic-Projekt verwendet werden, wenn die Prozedur UserForm_Initialize in Form_Load umbenannt wird.
.VBA-Code
'Deklarationsbereich des Codemoduls
Public Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
Public Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias
"RegOpenKeyExA" _
(ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As
Long, _
ByVal samDesired As Long, phkResult As Long) As Long
Public Declare Function RegEnumKeyEx Lib "advapi32.dll" Alias
"RegEnumKeyExA" _
(ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpName As String, _
lpcbName As Long, ByVal lpReserved As Long, ByVal lpClass As String, _
lpcbClass As Long, lpftLastWriteTime As FILETIME) As Long
Public Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As
Long
'Codemodul
Public Function EnumInstalledApps() As Collection
Dim AddressofOpenKey As Long
Dim bolFunctionResult As Boolean
Dim udtFileTimeStruc As FILETIME
Dim strAppName As String
Dim strAppNameLen As Long
Dim intAppIndex As Integer
Const KEY_ENUMERATE_SUB_KEYS = &H8
Const HKEY_LOCAL_MACHINE = &H80000002
Set EnumInstalledApps = New Collection
intAppIndex = 0
bolFunctionResult = Not CBool(RegOpenKeyEx(hKey:=HKEY_LOCAL_MACHINE, _
lpSubKey:="SOFTWARE\Microsoft\Windows\CurrentVersion\App Paths", ulOptions:=0, _
samDesired:=KEY_ENUMERATE_SUB_KEYS,
phkResult:=AddressofOpenKey))
If bolFunctionResult = False Then GoTo ErrorHandler
Do
strAppNameLen = 255
strAppName = String(strAppNameLen, CStr(0))
bolFunctionResult = Not CBool(RegEnumKeyEx(hKey:=AddressofOpenKey,
dwIndex:=intAppIndex, _
lpName:=strAppName, lpcbName:=strAppNameLen,
lpReserved:=0, lpClass:=vbNullString, _
lpcbClass:=0,
lpftLastWriteTime:=udtFileTimeStruc))
If bolFunctionResult = False Then Exit Do
intAppIndex = intAppIndex + 1
strAppName = Left(strAppName, strAppNameLen)
On Error Resume Next
EnumInstalledApps.Add strAppName
On Error GoTo 0
Loop
Call RegCloseKey(AddressofOpenKey)
Exit Function
ErrorHandler:
If Not AddressofOpenKey = 0 Then
Call RegCloseKey(AddressofOpenKey)
End If
Set EnumInstalledApps = Nothing
End Function
Public Function GetAppPath(ByVal strAppName As String)
As String
Dim objWSHShell As Object
On Error Resume Next
Set objWSHShell = CreateObject("WScript.Shell")
GetAppPath =
objWSHShell.RegRead("HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\App
Paths\" & strAppName & "\")
Set objWSHShell = Nothing
End Function
'Codemodul des Benutzerformulares
Private Sub UserForm_Initialize()
Dim aApps As Variant
On Error Resume Next
For Each aApps In EnumInstalledApps
lstApps.AddItem GetAppPath(aApps)
Next aApps
End Sub
|
Weitere Informationen |
|
Verwandte Codebeispiele |
|
Dateien eines Ordners und allen Unterordnern mit Anzahl auflisten
.Beschreibung
Dieses Codebeispiel erstellt eine Liste der Dateien eines
Ordners und seinen Unterordnern. Bei jeder Datei wird angegeben, wie viele Male sie
vorhanden ist. Massgebend ist nur der Dateiname (Gross-/Kleinschreibung egal).
Dateigrösse, Dateidatum usw. werden nicht berücksichtigt. Die Liste wird auf einem neuen
Arbeitsblatt der aktiven Arbeitsmappe erstellt.
Der Programmcode wird anhand der Prozedur ListFilesWithCount gestartet. Da ein Tabellenblatt 65'536 Zeilen besitzt, können maximal 65'527 Dateien aufgelistet werden. Das Überschreiten dieser Grenze ist im Programmcode abgefangen. Die restlichen 9 Zeilen werden für Titel, Spaltenüberschriften und anderes benötigt. Die Liste wird nach Spalte "Anzahl" aufsteigend sortiert.
Wenn nur diejenigen Dateien aufgelistet werden sollen, die mehr als einmal vorhanden sind, verwenden Sie bitte das Codebeispiel Mehrfach vorhandene Dateien eines Ordners und allen Unterordnern mit Anzahl auflisten.
Es können auch mehrere, beliebige Ordner und auch Dateien mit einem bestimmten Dateinamen (Platzhalter ? und * erlaubt!) durchsucht werden. Wie das geht, zeigt das Codebeispiel Bestimmte mehrfach vorhandene Dateien von bestimmten Ordnern und allen Unterordnern mit Anzahl auflisten.
.VBA-Code
'Deklarationsbereich des Codemoduls
Private objFSO As Object
Private objFolder As Object
Private lngFolders As Long
Private lngFiles As Long
Private colFiles As New Collection
'Codemodul
Sub ListFilesWithCount()
Const strBaseFolder As String = "C:\Daten"
Dim lngCounter As Long
Dim lngTotalFiles As Long
Dim varItem As Variant
Dim wksSheet As Worksheet
lngFolders = 0
lngFiles = 0
Set objFSO = CreateObject("Scripting.FileSystemObject")
FindFile strBaseFolder, "*.*"
Set objFSO = Nothing
Application.StatusBar = "Dateiliste wird erstellt..."
Set wksSheet = ActiveWorkbook.Worksheets.Add
With wksSheet
With .Range("A1")
.Value = "Dateien mit Anzahl"
.Font.Bold = True
End With
With .Range("A8:B8")
.Value = Array("Datei", "Anzahl")
.Font.Bold = True
End With
End With
Application.ScreenUpdating = False
For Each varItem In colFiles
lngCounter = lngCounter + 1
If lngCounter = 65528 Then
MsgBox "Es können nicht alle Dateien aufgelistet
werden, weil nicht genügend Zeilen zur Verfügung stehen.", vbInformation
Exit For
End If
With wksSheet
If lngCounter Mod 50 = 0 Then
Application.StatusBar = "Dateiliste wird
erstellt... (Datei " & lngCounter & " von " & lngFiles &
")"
End If
.Range("A" & lngCounter + 8 &
":B" & lngCounter + 8).Value = Array(Mid$(varItem, 7), Val(Left$(varItem,
5)))
lngTotalFiles = lngTotalFiles + Val(Left$(varItem, 5))
End With
Next
With wksSheet
.Range("A3").Value = "Basis-Ordner:"
.Range("B3").Value = strBaseFolder
.Range("A4").Value = "Anzahl Ordner:"
.Range("B4").Value = lngFolders
.Range("A5").Value = "Anzahl Dateien:"
.Range("B5").Value = lngTotalFiles
.Range("A6").Value = "Anzahl verschiedene Dateien:"
.Range("B6").Value = lngCounter
.Columns("A:B").AutoFit
.Range("A8").Sort Key1:=.Range("B9"),
Order1:=xlAscending, Header:=xlGuess
End With
Application.ScreenUpdating = True
Application.StatusBar = False
Set wksSheet = Nothing
Set colFiles = Nothing
End Sub
Function FindFile(ByVal sFolder As String, ByVal sFile
As String) As Long
Dim objTFolder As Object
Dim sFileName As String
Dim iCount As Integer
On Error GoTo ErrorHandler
Set objFolder = objFSO.GetFolder(sFolder)
If objFolder.Type <> "Dateiordner" Then
'Der Ordner ist kein Dateiordner
Exit Function
End If
sFileName = Dir(sFolder & "\" & sFile, vbHidden)
lngFolders = lngFolders + 1
While Len(sFileName) <> 0
lngFiles = lngFiles + 1
If lngFiles Mod 50 = 0 Then
Application.StatusBar = "Dateien werden analysiert...
(Ordner " & lngFolders & ", Datei " & lngFiles &
")"
End If
'Dateiname der Collection hinzufügen. Bei
bereits vorhandenem Key (Dateiname) tritt der Fehler 457 auf.
colFiles.Add "00001_" & LCase$(sFileName),
LCase$(sFileName)
sFileName = Dir()
Wend
If objFolder.SubFolders.Count > 0 Then
For Each objTFolder In objFolder.SubFolders
FindFile objTFolder.Path, sFile
Next
End If
Exit Function
ErrorHandler:
If Err.Number = 457 Then 'Key (Dateiname)
ist bereits vorhanden
'Letzte Anzahl dieser Datei abfragen
iCount = Val(Left$(colFiles.Item(LCase$(sFileName)), 5))
'Element aus der Collection entfernen
colFiles.Remove LCase$(sFileName)
'Dateiname mit Anzahl + 1 der Collection
hinzufügen
colFiles.Add Format$(iCount + 1, "00000") & "_"
& LCase$(sFileName), LCase$(sFileName)
lngFiles = lngFiles - 1
Resume Next
Else
sFileName = ""
Resume Next
End If
End Function
|
Weitere Informationen |
|
Verwandte Codebeispiele |
|
Mehrfach vorhandene Dateien eines Ordners und allen Unterordnern mit Anzahl auflisten
.Beschreibung
Mit diesem Codebeispiel wird eine Liste erstellt, die alle
Dateien zeigt, die mehrfach in einem Ordner und seinen Unterordnern vorhanden sind. Bei
jeder Datei wird angegeben, wie viele Male sie vorhanden ist. Massgebend ist nur der
Dateiname (Gross-/Kleinschreibung egal). Dateigrösse, Dateidatum usw. werden nicht
berücksichtigt. Die Liste wird auf einem neuen Arbeitsblatt der aktiven Arbeitsmappe
erstellt.
Dieses Codebeispiel ist vergleichbar mit dem Codebeispiel Dateien eines Ordners und allen Unterordnern mit Anzahl auflisten, nur dass hier ausschliesslich Dateien aufgelistet werden, die mehr als einmal vorhanden sind.
.VBA-Code
'Deklarationsbereich des Codemoduls
Private objFSO As Object
Private objFolder As Object
Private lngFolders As Long
Private lngFiles As Long
Private colFiles As New Collection
'Codemodul
Sub ListFilesWithCount()
Const strBaseFolder As String = "C:\Daten"
Dim lngCounter As Long
Dim lngTotalFiles As Long
Dim varItem As Variant
Dim wksSheet As Worksheet
lngFolders = 0
lngFiles = 0
Set objFSO = CreateObject("Scripting.FileSystemObject")
FindFile strBaseFolder, "*.*"
Set objFSO = Nothing
Application.StatusBar = "Dateiliste wird erstellt..."
Set wksSheet = ActiveWorkbook.Worksheets.Add
With wksSheet
With .Range("A1")
.Value = "Mehrfach vorhandene Dateien mit Anzahl"
.Font.Bold = True
End With
With .Range("A8:B8")
.Value = Array("Datei", "Anzahl")
.Font.Bold = True
End With
End With
Application.ScreenUpdating = False
For Each varItem In colFiles
If Val(Left$(varItem, 5)) > 1 Then
lngCounter = lngCounter + 1
If lngCounter = 65528 Then
MsgBox "Es können nicht alle Dateien
aufgelistet werden, weil nicht genügend Zeilen zur Verfügung stehen.",
vbInformation
Exit For
End If
With wksSheet
If lngCounter Mod 50 = 0 Then
Application.StatusBar =
"Dateiliste wird erstellt... (Datei " & lngCounter & " von "
& lngFiles & ")"
End If
.Range("A" & lngCounter + 8 &
":B" & lngCounter + 8).Value = Array(Mid$(varItem, 7), Val(Left$(varItem,
5)))
lngTotalFiles = lngTotalFiles +
Val(Left$(varItem, 5))
End With
End If
Next
With wksSheet
.Range("A3").Value = "Basis-Ordner:"
.Range("B3").Value = strBaseFolder
.Range("A4").Value = "Anzahl Ordner:"
.Range("B4").Value = lngFolders
.Range("A5").Value = "Anzahl Dateien:"
.Range("B5").Value = lngTotalFiles
.Range("A6").Value = "Anzahl verschiedene Dateien:"
.Range("B6").Value = lngCounter
.Columns("A:B").AutoFit
.Range("A8").Sort Key1:=.Range("B9"),
Order1:=xlAscending, Header:=xlGuess
End With
Application.ScreenUpdating = True
Application.StatusBar = False
Set wksSheet = Nothing
Set colFiles = Nothing
End Sub
Function FindFile(ByVal sFolder As String, ByVal sFile
As String) As Long
Dim objTFolder As Object
Dim sFileName As String
Dim iCount As Integer
On Error GoTo ErrorHandler
Set objFolder = objFSO.GetFolder(sFolder)
If objFolder.Type <> "Dateiordner" Then
'Der Ordner ist kein Dateiordner
Exit Function
End If
sFileName = Dir(sFolder & "\" & sFile, vbHidden)
lngFolders = lngFolders + 1
While Len(sFileName) <> 0
lngFiles = lngFiles + 1
If lngFiles Mod 50 = 0 Then
Application.StatusBar = "Dateien werden analysiert...
(Ordner " & lngFolders & ", Datei " & lngFiles &
")"
End If
'Dateiname der Collection hinzufügen. Bei
bereits vorhandenem Key (Dateiname) tritt der Fehler 457 auf.
colFiles.Add "00001_" & LCase$(sFileName),
LCase$(sFileName)
sFileName = Dir()
Wend
If objFolder.SubFolders.Count > 0 Then
For Each objTFolder In objFolder.SubFolders
FindFile objTFolder.Path, sFile
Next
End If
Exit Function
ErrorHandler:
If Err.Number = 457 Then 'Key (Dateiname)
ist bereits vorhanden
'Letzte Anzahl dieser Datei abfragen
iCount = Val(Left$(colFiles.Item(LCase$(sFileName)), 5))
'Element aus der Collection entfernen
colFiles.Remove LCase$(sFileName)
'Dateiname mit Anzahl + 1 der Collection
hinzufügen
colFiles.Add Format$(iCount + 1, "00000") & "_"
& LCase$(sFileName), LCase$(sFileName)
lngFiles = lngFiles - 1
Resume Next
Else
sFileName = ""
Resume Next
End If
End Function
|
Weitere Informationen |
|
Verwandte Codebeispiele |
|
|
.Beschreibung
Dieses Codebeispiel listet alle Dateien auf,
- die einen bestimmten Dateinamen (mit Mustervergleich, d.h. Platzhalter * und ?
erlaubt) besitzen und
- in bestimmten Ordnern oder deren Unterordner liegen und
- mehr als einmal vorhanden sind.
Bei jeder Datei wird angegeben, wie viele Male sie vorhanden ist. Massgebend ist nur der Dateiname (Gross-/Kleinschreibung egal). Dateigrösse, Dateidatum usw. werden nicht berücksichtigt. Die Liste wird auf einem neuen Arbeitsblatt der aktiven Arbeitsmappe erstellt.
.VBA-Code
'Deklarationsbereich des Codemoduls
Private objFSO As Object
Private objFolder As Object
Private lngFolders As Long
Private lngFiles As Long
Private colFiles As New Collection
'Codemodul
Sub ListFilesWithCount()
Const strBaseFolder1 As String = "C:\Daten"
Const strBaseFolder2 As String = "C:\Excel\Dateien"
Const strBaseFolder3 As String = "D:\Statistik"
Const strPattern As String = "*.xls"
Dim lngCounter As Long
Dim lngTotalFiles As Long
Dim varItem As Variant
Dim wksSheet As Worksheet
lngFolders = 0
lngFiles = 0
Set objFSO = CreateObject("Scripting.FileSystemObject")
FindFile strBaseFolder1, strPattern
FindFile strBaseFolder2, strPattern
FindFile strBaseFolder3, strPattern
Set objFSO = Nothing
Application.StatusBar = "Dateiliste wird erstellt..."
Set wksSheet = ActiveWorkbook.Worksheets.Add
With wksSheet
With .Range("A1")
.Value = "Mehrfach vorhandene Dateien mit Anzahl"
.Font.Bold = True
End With
With .Range("A8:B8")
.Value = Array("Datei", "Anzahl")
.Font.Bold = True
End With
End With
Application.ScreenUpdating = False
For Each varItem In colFiles
If Val(Left$(varItem, 5)) > 1 Then
lngCounter = lngCounter + 1
If lngCounter = 65528 Then
MsgBox "Es können nicht alle Dateien
aufgelistet werden, weil nicht genügend Zeilen zur Verfügung stehen.",
vbInformation
Exit For
End If
With wksSheet
If lngCounter Mod 50 = 0 Then
Application.StatusBar =
"Dateiliste wird erstellt... (Datei " & lngCounter & " von "
& lngFiles & ")"
End If
.Range("A" & lngCounter + 8 &
":B" & lngCounter + 8).Value = Array(Mid$(varItem, 7), Val(Left$(varItem,
5)))
lngTotalFiles = lngTotalFiles +
Val(Left$(varItem, 5))
End With
End If
Next
With wksSheet
.Range("A3").Value = "Basis-Ordner:"
.Range("B3").Value = strBaseFolder1 & ";" &
strBaseFolder2 & ";" & strBaseFolder3
.Range("A4").Value = "Anzahl Ordner:"
.Range("B4").Value = lngFolders
.Range("A5").Value = "Anzahl Dateien:"
.Range("B5").Value = lngTotalFiles
.Range("A6").Value = "Anzahl verschiedene Dateien:"
.Range("B6").Value = lngCounter
.Columns("A:B").AutoFit
.Range("A8").Sort Key1:=.Range("B9"),
Order1:=xlAscending, Header:=xlGuess
End With
Application.ScreenUpdating = True
Application.StatusBar = False
Set wksSheet = Nothing
Set colFiles = Nothing
End Sub
Function FindFile(ByVal sFolder As String, ByVal sFile
As String) As Long
Dim objTFolder As Object
Dim sFileName As String
Dim iCount As Integer
On Error GoTo ErrorHandler
Set objFolder = objFSO.GetFolder(sFolder)
If objFolder.Type <> "Dateiordner" Then
'Der Ordner ist kein Dateiordner
Exit Function
End If
sFileName = Dir(sFolder & "\" & sFile, vbHidden)
lngFolders = lngFolders + 1
While Len(sFileName) <> 0
lngFiles = lngFiles + 1
If lngFiles Mod 50 = 0 Then
Application.StatusBar = "Dateien werden analysiert...
(Ordner " & lngFolders & ", Datei " & lngFiles &
")"
End If
'Dateiname der Collection hinzufügen. Bei
bereits vorhandenem Key (Dateiname) tritt der Fehler 457 auf.
colFiles.Add "00001_" & LCase$(sFileName),
LCase$(sFileName)
sFileName = Dir()
Wend
If objFolder.SubFolders.Count > 0 Then
For Each objTFolder In objFolder.SubFolders
FindFile objTFolder.Path, sFile
Next
End If
Exit Function
ErrorHandler:
If Err.Number = 457 Then 'Key (Dateiname)
ist bereits vorhanden
'Letzte Anzahl dieser Datei abfragen
iCount = Val(Left$(colFiles.Item(LCase$(sFileName)), 5))
'Element aus der Collection entfernen
colFiles.Remove LCase$(sFileName)
'Dateiname mit Anzahl + 1 der Collection
hinzufügen
colFiles.Add Format$(iCount + 1, "00000") & "_"
& LCase$(sFileName), LCase$(sFileName)
lngFiles = lngFiles - 1
Resume Next
Else
sFileName = ""
Resume Next
End If
End Function
|
Weitere Informationen |
|
Verwandte Codebeispiele |
|
Druckvorschau/Seitenansicht anzeigen
.Beschreibung
Mit der PrintPreview-Methode wird in Microsoft Excel
die Seitenansicht angezeigt.
.VBA-Code
Public Sub ShowPrintPreview()
End Sub
|
Weitere Informationen |
|
Verwandte Codebeispiele |
Auffangbare Laufzeitfehler von VBA/VB auflisten
.Beschreibung
Dieses Codebeispiel listet alle auffangbaren
Fehler/Laufzeitfehler der Programmiersprache VBA/VB auf einem neuen Arbeitsblatt der
aktiven Arbeitsmappe auf.
.VBA-Code
Public Sub ListTrappableErrors()
Dim wksSheet As Worksheet
Dim lngError As Long
Dim lngCounter As Long
Set wksSheet = ActiveWorkbook.Worksheets.Add
With wksSheet
.Range("A3:B3").Value = Array("Code",
"Fehler")
.Range("A3:B3").Font.Bold = True
End With
lngCounter = 3
For lngError = 1 To 1000
If Error(lngError) <> "Anwendungs- oder objektdefinierter
Fehler" Then
lngCounter = lngCounter + 1
With wksSheet
.Cells(lngCounter, 1).Value = lngError
.Cells(lngCounter, 2).Value = Error(lngError)
End With
End If
Next lngError
With wksSheet
.Columns("A:B").AutoFit
.Range("A1").Value = "Auffangbare Fehler"
.Range("A1").Font.Bold = True
End With
Set wksSheet = Nothing
End Sub
|
Weitere Informationen |
.Beschreibung
Eine MIDI-Datei kann am einfachsten abgespielt werden, indem
man das ActiveX-Control "MediaPlayer" zu Hilfe nimmt.
.VBA-Code
Public Sub PlayMIDIFile()
End Sub
|
Weitere Informationen |
|
Verwandte Codebeispiele |
Drücken einer Taste auf der Tastatur simulieren
.Beschreibung
...
Es wird nicht einfach ein Tastenbefehl an das aktive Fenster gesendet, so wie es bei der SendKeys-Anweisung von VBA der Fall ist. Der hier vorgestellte Programmcode simuliert das Drücken einer Taste, indem ein Tastaturereignis ausgelöst wird.
.VBA-Code
'Deklarationsbereich
Const VER_PLATFORM_WIN32_NT = 2
Const VER_PLATFORM_WIN32_WINDOWS = 1
Const VK_ASTERICS = &H6A
Const KEYEVENTF_EXTENDEDKEY = &H1
Const KEYEVENTF_KEYUP = &H2
Type OSVERSIONINFO
dwOSVersionInfoSize As Long
dwMajorVersion As Long
dwMinorVersion As Long
dwBuildNumber As Long
dwPlatformId As Long
szCSDVersion As String * 128
End Type
Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" _
(lpVersionInformation As OSVERSIONINFO) As Long
Declare Sub Keybd_Event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, _
ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
Declare Function SetKeyboardState Lib "user32" (lppbKeyState As Byte) As Long
'Codemodul
Sub PressKey()
Dim bytKeys(255) As Byte
Dim typOS As OSVERSIONINFO
Dim lngRC As Long
typOS.dwOSVersionInfoSize = Len(typOS)
lngRC = GetVersionEx(typOS)
If typOS.dwPlatformId = VER_PLATFORM_WIN32_WINDOWS Then
'Win95/98
bytKeys(VK_ASTERICS) = 1
SetKeyboardState bytKeys(0)
Else
'WinNT/2000
keybd_event VK_ASTERICS, &H45, KEYEVENTF_EXTENDEDKEY Or 0, 0
keybd_event VK_ASTERICS, &H45, KEYEVENTF_EXTENDEDKEY Or
KEYEVENTF_KEYUP, 0
End If
End Sub
|
Weitere Informationen |
|
Verwandte Codebeispiele |
NumLock/CapsLock/ScrollLock aktivieren/deaktivieren
.Beschreibung
...
TODO: Code
.VBA-Code
'Deklarationsbereich
Const VER_PLATFORM_WIN32_NT = 2
Const VER_PLATFORM_WIN32_WINDOWS = 1
Const KEYEVENTF_EXTENDEDKEY = &H1
Const KEYEVENTF_KEYUP = &H2
Type OSVERSIONINFO
dwOSVersionInfoSize As Long
dwMajorVersion As Long
dwMinorVersion As Long
dwBuildNumber As Long
dwPlatformId As Long
szCSDVersion As String * 128
End Type
Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" _
(lpVersionInformation As OSVERSIONINFO) As Long
Declare Sub Keybd_Event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, _
ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
Declare Function SetKeyboardState Lib "user32" (lppbKeyState As Byte) As Long
'Codemodul
Sub PressKey()
End Sub
|
Weitere Informationen |
|
Verwandte Codebeispiele |
Zellbereich als HTML-Datei speichern
.Beschreibung
Dieses Codebeispiel speichert einen Zellbereich als eine neue
HTML-Datei (Dateinamenerweiterung "htm").
.VBA-Code
Public Sub SaveRangeAsHTMLFile()
End Sub
|
Weitere Informationen |
|
Verwandte Codebeispiele |
|
Verknüpfte Bereiche von Formular-Steuerelementen auflisten
.Beschreibung
Einige der in Microsoft Excel zur Verfügung stehenden
Formular-Steuerelemente können eine so genannte Ausgabeverknüpfung und zum Teil einen
Listenbereich besitzen. Diese Tabelle zeigt die Steuerelemente mit den erwähnten
Eigenschaften:
| Steuerelement (de) | Steuerelement (en) | Ausgabeverknüpfung | Listenbereich |
| Bildlaufleiste | ScrollBar | Ja | Nein |
| Drehfeld | SpinButton | Ja | Nein |
| Kombinationsfeld | DropDown | Ja | Ja |
| Kontrollkästchen | CheckBox | Ja | Nein |
| Listenfeld | ListBox | Ja | Ja |
| Optionsfeld | OptionButton | Ja | Nein |
» Codebeispiel #1: Dieses Codebeispiel erstellt eine Liste der Ausgabeverknüpfungen und Listenbereiche der Formular-Steuerelemente des aktiven Arbeitsblattes. Die Liste wird im Direktfenster des VBA-Editors ausgegeben.
» Codebeispiel #2: Bei diesem Codebeispiel wird ebenfalls die Liste erstellt, wobei hier jedoch sämtliche Arbeitsblätter der aktiven Arbeitsmappe berücksichtigt werden. Die Liste wird im Direktfenster des VBA-Editors ausgegeben.
.VBA-Code #1
Public Sub ListFormControlsLinksOfSheet()
Dim objFormControl As Object
Dim objShape As Shape
Dim strResult As String
On Error Resume Next
For Each objShape In ActiveSheet.Shapes
If objShape.Type = msoFormControl Then
Set objFormControl = objShape.DrawingObject
strResult = objFormControl.ListFillRange
If Err.Number = 0 Then
If strResult <> "" Then
Debug.Print objShape.Name &
": Listenbereich: " & strResult
Else
Debug.Print objShape.Name &
": Listenbereich: (Nicht festgelegt)"
End If
Else
Err.Clear
End If
strResult = objFormControl.LinkedCell
If Err.Number = 0 Then
If strResult <> "" Then
Debug.Print objShape.Name &
": Ausgabeverknüpfung: " & strResult
Else
Debug.Print objShape.Name &
": Ausgabeverknüpfung: (Nicht festgelegt)"
End If
Else
Err.Clear
End If
Set objFormControl = Nothing
End If
Next
End Sub
.VBA-Code #2
Public Sub ListFormControlsLinksOfBook()
Dim objFormControl As Object
Dim objShape As Shape
Dim wksSheet As Worksheet
Dim strResult As String
On Error Resume Next
For Each wksSheet In ActiveWorkbook.Worksheets
For Each objShape In wksSheet.Shapes
If objShape.Type = msoFormControl Then
Set objFormControl = objShape.DrawingObject
strResult = objFormControl.ListFillRange
If Err.Number = 0 Then
If strResult <> ""
Then
Debug.Print
wksSheet.Name & " > " & objShape.Name & ": Listenbereich:
" & strResult
Else
Debug.Print
wksSheet.Name & " > " & objShape.Name & ": Listenbereich:
(Nicht festgelegt)"
End If
Else
Err.Clear
End If
strResult = objFormControl.LinkedCell
If Err.Number = 0 Then
If strResult <> ""
Then
Debug.Print
wksSheet.Name & " > " & objShape.Name & ":
Ausgabeverknüpfung: " & strResult
Else
Debug.Print
wksSheet.Name & " > " & objShape.Name & ":
Ausgabeverknüpfung: (Nicht festgelegt)"
End If
Else
Err.Clear
End If
Set objFormControl = Nothing
End If
Next
Next
End Sub
|
Weitere Informationen |
|
Verwandte Codebeispiele |
|
|
.Beschreibung
Die nachstehende Prozedur analysiert alle Benutzerformulare
des VBA-Projektes der aktiven Arbeitsmappe und gibt zu jedem ListBox- und
ComboBox-Steuerelement den Inhalt der RowSource-Eigenschaft im Direktfenster des
VBA-Editors aus.
Damit der Programmcode ausgeführt werden kann, muss im VBA-Projekt ein Verweis auf die Objektbibliothek "Microsoft Visual Basic for Applications Extensibility" gesetzt werden (Menü Extras/Verweise).
.VBA-Code
Public Sub ListRowSources()
Dim objComponent As VBComponent
Dim objControl As Control
Dim strRowSource As String
On Error Resume Next
For Each objComponent In ActiveWorkbook.VBProject.VBComponents
If objComponent.Type = vbext_ct_MSForm Then
For Each objControl In objComponent.Designer.Controls
strRowSource = objControl.RowSource
If Err.Number = 0 Then
Debug.Print objComponent.Name &
" (" & objComponent.Properties("Caption") & _
")
> RowSource von " & objControl.Name & ": " & strRowSource
Else
Err.Clear
End If
Next objControl
End If
Next objComponent
End Sub
.Hinweis
Sie fragen sich vielleicht, welchen Zweck der obige
Programmcode besitzt. Nun, der Zweck ist folgender:
Auf einem Benutzerformular können sowohl in Microsoft Excel für Windows als in Microsoft Excel für Macintosh ListBox- und ComboBox-Steuerelemente verwendet werden. Die RowSource-Eigenschaft jedoch steht auf Macintosh-Systemen nicht zur Verfügung. Wenn diese Eigenschaft trotzdem verwendet wird, erscheint der Laufzeitfehler 380 mit dem Meldungstext "Eigenschaft RowSource konnte nicht gesetzt werden. Ungültiger Eigenschaftswert." (englisch "Could not set the RowSource property. Invalid property value.").
Wenn Sie also möchten, dass das VBA-Programm auch mit Microsoft Excel für Macintosh funktioniert, dürfen Sie RowSource nicht verwenden. Wenn Sie RowSource jedoch bereits 'ausgiebig' benutzt haben, können Sie anhand des obigen Codebeispiels alle noch benutzten RowSource-Eigenschaften in Ihrem VBA-Projekt aufspüren.
|
Weitere Informationen |
|
Zellbereiche der Konsolidierungen in einer Arbeitsmappe auflisten
.Beschreibung
Über den Menübefehl Daten/Konsolidieren
können Sie in Microsoft Excel mehrere Zellbereiche zu einer so genannten
Konsolidierungstabelle zusammenfassen. Dies ist die Tabelle mit den zusammengefassten
Ergebnissen, die im Zielbereich angezeigt wird. Microsoft Excel erstellt die
Konsolidierungstabelle durch Anwenden der ausgewählten zusammenfassenden Funktion auf die
angegeben Werte im Quellbereich.
Das folgende Codebeispiel erstellt eine ausführliche Liste aller in der aktiven Arbeitsmappe benutzten Konsolidierungen. Dazu werden alle Arbeitsblätter nach Konsolidierungen durchsucht und zu jeder gefundenen Konsolidierung eine Liste mit den verwendeten Zellbereichen (Quellen/Bezüge) ausgegeben. Zudem wird angegeben, ob die Quelldaten verknüpft sind oder nicht.
.VBA-Code
Public Sub ListSourcesOfAllConsolidations()
Dim wksReportSheet As Worksheet
Dim wksSheet As Worksheet
Dim avarSources As Variant
Dim intCounter As Integer
Dim lngRow As Long
lngRow = 2
Set wksReportSheet = Worksheets.Add
With wksReportSheet
.Range("A1").Value = "Konsolidierungen"
.Range("A1").Font.Bold = True
.Range("A1").Font.Size = .Range("A1").Font.Size + 2
For Each wksSheet In ActiveWorkbook.Worksheets
If wksSheet.Name <> wksReportSheet.Name Then
lngRow = lngRow + 1
.Cells(lngRow, 1).Value = wksSheet.Name
.Cells(lngRow, 1).Font.Bold = True
avarSources = wksSheet.ConsolidationSources
If IsEmpty(avarSources) Then
lngRow = lngRow + 1
.Cells(lngRow, 1).Value =
"(Keine Konsolidierung)"
Else
If wksSheet.ConsolidationOptions(3)
= True Then
lngRow = lngRow + 1
.Cells(lngRow, 1).Value
= "(Konsolidierung mit verknüpften Quelldaten)"
Else
lngRow = lngRow + 1
.Cells(lngRow, 1).Value
= "(Konsolidierung ohne verknüpfte Quelldaten)"
End If
For intCounter = 1 To
UBound(avarSources)
lngRow = lngRow + 1
.Cells(lngRow, 1).Value
= "Bezug " & CStr(intCounter) & ": " &
avarSources(intCounter)
Next intCounter
End If
lngRow = lngRow + 1
End If
Next
.Columns("A").AutoFit
End With
Set wksReportSheet = Nothing
End Sub
|
Weitere Informationen |
|
|
Verwandte Codebeispiele |
|
Zellbereiche und Eigenschaften einer Konsolidierung auflisten
.Beschreibung
Über den Menübefehl Daten/Konsolidieren
können Sie in Microsoft Excel mehrere Zellbereiche zu einer so genannten
Konsolidierungstabelle zusammenfassen. Dies ist die Tabelle mit den zusammengefassten
Ergebnissen, die im Zielbereich angezeigt wird. Microsoft Excel erstellt die
Konsolidierungstabelle durch Anwenden der ausgewählten zusammenfassenden Funktion auf die
angegeben Werte im Quellbereich.
Dieses Codebeispiel listet die Zellbereiche (Quellen/Bezüge) einer Konsolidierung auf. Zusätzlich wird angezeigt, ob die Quelldaten verknüpft sind oder nicht.
.VBA-Code
Public Sub ListConsolidationSettings()
Dim wksSheet As Worksheet
Dim avarSources As Variant
Dim avarOptions As Variant
Dim lngFunction As Long
Dim strFunctionName As String
Dim intCounter As Integer
avarSources = ActiveSheet.ConsolidationSources
If IsEmpty(avarSources) Then
MsgBox "Auf dem aktiven Blatt ist keine Konsolidierung
vorhanden.", vbInformation
Else
lngFunction = ActiveSheet.ConsolidationFunction
Select Case lngFunction
Case xlAverage
strFunctionName = "Mittelwert"
Case xlCount
strFunctionName = "Anzahl"
Case xlCountNums
strFunctionName = "Anzahl Zahlen"
Case xlMax
strFunctionName = "Maximum"
Case xlMin
strFunctionName = "Minimum"
Case xlProduct
strFunctionName = "Produkt"
Case xlStDev
strFunctionName = "Standardabweichung
(Stichprobe)"
Case xlStDevP
strFunctionName = "Standardabweichung
(Grundgesamtheit)"
Case xlSum
strFunctionName = "Summe"
Case xlVar
strFunctionName = "Varianz
(Stichprobe)"
Case xlVarP
strFunctionName = "Varianz
(Grundgesamtheit)"
End Select
avarOptions = ActiveSheet.ConsolidationOptions
Set wksSheet = Worksheets.Add
With wksSheet
.Range("A1").Value = "Konsolidierung von
" & ActiveSheet.Name
.Range("A1").Font.Bold = True
.Range("A3").Value =
"Konsolidierungsfunktion:"
.Range("A4").Value = "Beschriftung aus
oberster Zeile:"
.Range("A5").Value = "Beschriftung aus
linker Spalte:"
.Range("A6").Value = "Verknüpfungen mit
Quelldaten:"
.Range("B3").Value = strFunctionName
.Range("B4").Value = IIf(avarOptions(1) = True,
"Ja", "Nein")
.Range("B5").Value = IIf(avarOptions(2) = True,
"Ja", "Nein")
.Range("B6").Value = IIf(avarOptions(3) = True,
"Ja", "Nein")
.Range("A8").Value =
"Zellbereiche/Bezüge"
.Range("A8").Font.Bold = True
For intCounter = 1 To UBound(avarSources)
.Cells(intCounter + 8, 1).Value =
avarSources(intCounter)
Next intCounter
.Columns("A:B").AutoFit
End With
Set wksSheet = Nothing
End If
End Sub
|
Weitere Informationen |
|
|
Verwandte Codebeispiele |
|
.Beschreibung
Hier wird gezeigt, wie man mit VBA die Datenmaske von
Microsoft Excel öffnen kann. Über die Benutzeroberfläche wird dazu der Menübefehl
"Maske" des Menüs "Daten" benutzt.
ActiveSheet.ShowDataForm
Application.CommandBars.FindControl(Id:=860).Execute
.VBA-Code
Public Sub ShowDataForm()
End Sub
|
Weitere Informationen |
|
Verwandte Codebeispiele |
Datenmaske mit einem bestimmten Datensatz öffnen
.Beschreibung
Wenn man die Datenmaske öffnet, wird standardmässig der
erste Datensatz der Datenliste angezeigt. Anhand eines kleinen Tricks kann man erreichen,
dass ein bestimmter Datensatz angezeigt wird.
.VBA-Code
Public Sub ShowDataFormWithRecord()
End Sub
|
Weitere Informationen |
|
Verwandte Codebeispiele |
Zuletzt aktualisiert
am 4.03.2006 / 18:00 Uhr
© 2002-2006 by Philipp von Wartburg, CH-8916 Jonen
Alle Rechte vorbehalten
