17.08.2010

Prozesse!

In der Mittagspause kam mir die Idee schnell einen Prozessviewer zu coden. Prozesse werden angezeigt, gekillt, geschlosssen bzw. gecheckt. Da in Visual Studio 2010 mit VB programmiert, ist das NET Framework auf dem Client natürlich nötig.

Prozesse auflisten, killen, beenden, checken... [ZIP, 80 KB]

Beim Killen VORSICHT! DATENVERLUST! Ist manchmal ganz nützlich wenn beim rumprobieren auf einmal viele Excelinstanzen - oder welches Programm auch immer - vorhanden sind.



Beim Schließen habe ich noch die Möglichkeit Daten zu speichern.



Na ja - die Form schließen!



Ist die Liste recht lang kann man über die OptionButton bzw. über Buchstabe in Textfeld eingeben und Return drücken die Liste eingrenzen.



Datei checken klingt ganz schön großkotzig. Ist aber nichts anderes, als eine Suche des Dateinamens über Google. Der erste Eintrag zeigt mir in der Regel dann schon um was es sich handelt.

16.08.2010

Leere Ordner!

Ab einem wählbaren Startordner soll das gesamte Verzeichnis inklusive aller Unterordner nach leeren Ordnern durchsucht werden - diese werden im "Direktfenster" (VBA-Editor Strg+G) aufgelistet. Zwei Versionen - einmal für Excel ab XP (2002) und einmal für Excel97.

Leere Ordner auflisten... [ZIP, 110 KB]

Code ab Excel XP (2002):

Option Explicit
Private Declare Function GetCurrentDirectory Lib "kernel32" _
Alias "GetCurrentDirectoryA" _
(ByVal nBufferLength&, ByVal lpBuffer$) As Long
Private Declare Function SetCurrentDirectory Lib "kernel32" _
Alias "SetCurrentDirectoryA" (ByVal lpPathName$) As Long
Dim objSubFolder As Object
Dim objTMPFolder As Object
Dim objFolder As Object
Dim objFSO As Object
Public Sub Emty_Folder_List()
Dim strDirOld As String
Dim strTMP As String
On Error GoTo Fin
strDirOld$ = String(255, 0)
Call GetCurrentDirectory(255, strDirOld$)
strDirOld$ = Left(strDirOld$, _
InStr(1, strDirOld$, vbNullChar) - 1)
Set objFSO = CreateObject("Scripting.FileSystemObject")
strTMP = fncFolder("C:\")
If strTMP <> "" Then getSubFolders strTMP
Fin:
If Err.Number <> 0 Then MsgBox "Fehler: " & _
Err.Number & " " & Err.Description
Call SetCurrentDirectory(strDirOld$)
Set objSubFolder = Nothing
Set objFolder = Nothing
Set objFSO = Nothing
End Sub
Private Function getSubFolders(strTMPPath)
Set objFolder = objFSO.GetFolder(strTMPPath)
Set objSubFolder = objFolder.SubFolders
For Each objTMPFolder In objSubFolder
If objTMPFolder.Files.Count = 0 And _
objTMPFolder.SubFolders.Count = 0 Then
Debug.Print objTMPFolder.Path
End If
getSubFolders objTMPFolder.Path
Next
End Function
Private Function fncFolder(strPath As String) As String
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = strPath
.Title = "Folder"
.ButtonName = "Select..."
.InitialView = msoFileDialogViewList
If .Show = -1 Then
strPath = .SelectedItems(1)
If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
Else
fncFolder = "": Exit Function
End If
End With
fncFolder = strPath
End Function



Code Excel 97:

Option Explicit
Private Declare Function GetCurrentDirectory Lib "kernel32" _
Alias "GetCurrentDirectoryA" _
(ByVal nBufferLength&, ByVal lpBuffer$) As Long
Private Declare Function SetCurrentDirectory Lib "kernel32" _
Alias "SetCurrentDirectoryA" (ByVal lpPathName$) As Long
Dim objSubFolder As Object
Dim objTMPFolder As Object
Dim objFolder As Object
Dim objFSO As Object
Public Sub Emty_Folder_List_97()
Dim strDirOld As String
Dim objShell As Object
Dim varDir As Variant
Dim strTMP As String
Set objShell = CreateObject("Shell.Application")
Set varDir = objShell.BrowseForFolder(0, "Folder", &H4000, 17)
On Error Resume Next
strTMP = varDir.Self.Path
On Error GoTo 0
On Error GoTo Fin
strDirOld$ = String(255, 0)
Call GetCurrentDirectory(255, strDirOld$)
strDirOld$ = Left(strDirOld$, InStr(1, strDirOld$, vbNullChar) - 1)
Set objFSO = CreateObject("Scripting.FileSystemObject")
If strTMP <> "" Then getSubFolders strTMP
Fin:
If Err.Number <> 0 Then MsgBox Err.Number & " " & Err.Description
Call SetCurrentDirectory(strDirOld$)
Set objSubFolder = Nothing
Set objFolder = Nothing
Set objFSO = Nothing
Set varDir = Nothing
Set objShell = Nothing
End Sub
Private Function getSubFolders(strTMPPath)
Set objFolder = objFSO.GetFolder(strTMPPath)
Set objSubFolder = objFolder.SubFolders
For Each objTMPFolder In objSubFolder
If objTMPFolder.Files.Count = 0 And _
objTMPFolder.SubFolders.Count = 0 Then
Debug.Print objTMPFolder.Path
End If
getSubFolders objTMPFolder.Path
Next
End Function

11.08.2010

Werte verteilen!

Eine Liste soll auf mehrere Tabellenblätter aufgeteilt werden. Die Kriterienspalte ist Spalte A. Die Überschriftenzeile soll auf jedem Tabellenblatt erscheinen. Bei erneutem ausführen des Makros sollen die angelegten Tabellenblätter zuerst gelöscht werden. Es gibt dazu zwei Beispielcodes und eine Beispieldatei:

Liste auf mehrere Tabellenblätter aufteilen... [ZIP, 60 KB]

Dann noch ein Link auf das Thema - dort gibt es auch Formellösungen:

Liste aufteilen...

Code1:

Option Explicit
Public Sub Aufteilen()
Dim wksSheet As Worksheet
Dim wksTMP As Worksheet
Dim rngRange As Range
Dim rngTMP As Range
Dim lngRow As Long
On Error GoTo Fin
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
For Each wksTMP In ThisWorkbook.Worksheets
If wksTMP.Name Like "Klasse*" Then
wksTMP.Delete
End If
Next wksTMP
Set wksSheet = ThisWorkbook.Worksheets("Gesamt")
With wksSheet
Set rngRange = .Range("A1").CurrentRegion
rngRange.Sort Key1:=.Range("A2"), Order1:=xlAscending, Header:=xlYes
lngRow = 2
Do Until IsEmpty(rngRange.Cells(lngRow, 1))
If rngRange.Cells(lngRow, 1) <> rngRange.Cells(lngRow - 1, 1) Then
rngRange.AutoFilter field:=1, _
Criteria1:=rngRange.Cells(lngRow, 1)
Set rngTMP = rngRange.SpecialCells(xlCellTypeVisible)
Worksheets.Add.Move After:=Worksheets(Worksheets.Count)
ActiveSheet.Name = "Klasse_" & rngRange.Cells(lngRow, 1)
rngTMP.Copy Range("A1")
End If
lngRow = lngRow + 1
Loop
End With
Fin:
wksSheet.AutoFilterMode = False
With Application
.Goto wksSheet.Range("A1"), True
.ScreenUpdating = True
.DisplayAlerts = True
End With
Set rngRange = Nothing
Set wksSheet = Nothing
End Sub



Code2:

Option Explicit
Public Sub Aufteilen_1()
Dim wksKriterienSheet As Worksheet
Dim wksQuellSheet As Worksheet
Dim rngKriterium As Range
Dim wksNew As Worksheet
Dim wksTMP As Worksheet
Dim lngLastRow As Long
On Error GoTo Fin
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
For Each wksTMP In ThisWorkbook.Worksheets
If wksTMP.Name Like "#*" Then
wksTMP.Delete
End If
Next wksTMP
' Tabellenblatt mit Daten - Name ANPASSEN
Set wksQuellSheet = Worksheets("Gesamt")
Set wksKriterienSheet = Worksheets.Add
wksKriterienSheet.Move After:= _
ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
lngLastRow = wksQuellSheet.Range("A" & Rows.Count).End(xlUp).Row
wksQuellSheet.Range("A1:A" & lngLastRow).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=wksKriterienSheet.Range("A1"), Unique:=True
Set rngKriterium = wksKriterienSheet.Range("A2")
While rngKriterium.Value <> ""
Set wksNew = Worksheets.Add
wksQuellSheet.Range("A1:N" & lngLastRow).AdvancedFilter _
Action:=xlFilterCopy, _
CriteriaRange:=rngKriterium.Offset(-1).Resize(2), _
CopyToRange:=wksNew.Range("A1"), Unique:=True
wksNew.Name = rngKriterium.Text
rngKriterium.EntireRow.Delete
Set rngKriterium = wksKriterienSheet.Range("A2")
Wend
wksKriterienSheet.Delete
Fin:
With Application
.Goto wksQuellSheet.Range("A1"), True
.ScreenUpdating = True
.DisplayAlerts = True
End With
Set wksKriterienSheet = Nothing
Set wksQuellSheet = Nothing
Set rngKriterium = Nothing
Set wksNew = Nothing
End Sub

ActiveX ComboBox erstellen - befüllen!

Eine ComboBox aus Steuerelemente (ActiveX) soll in der gerade aktiven Zelle erstellt und mit einem Wert bzw. mehreren Werten befüllt werden.

Option Explicit
Public Sub Test()
Dim objXbox As Object
With Tabelle1 ' Anpassen
Set objXbox = .OLEObjects.Add(ClassType:="Forms.ComboBox.1")
With objXbox
.Object.AddItem ("Teil1")
.PrintObject = False
.Left = ActiveCell.Left
.Top = ActiveCell.Top
.Width = ActiveCell.Width
.Height = ActiveCell.Height
End With
End With
End Sub
Public Sub Test_1()
Dim objXbox As Object
Dim varArr As Variant
varArr = Array("Teil1", "Teil2", "Teil3", "Teil4")
With Tabelle1 ' Anpassen
Set objXbox = .OLEObjects.Add(ClassType:="Forms.ComboBox.1")
With objXbox
'.Object.AddItem ("Teil1")
.Object.List = varArr
.PrintObject = False
.Left = ActiveCell.Left
.Top = ActiveCell.Top
.Width = ActiveCell.Width
.Height = ActiveCell.Height
End With
End With
End Sub

03.08.2010

BuiltinDocumentProperties - Word!

Über eine UserForm in Excel können die "BuiltinDocumentProperties" aus einer Worddatei gelesen bzw. geschrieben werden. In der ZIP-Datei im Download ist eine Testworddatei enthalten.

BuiltinDocumentProperties... [ZIP, 60 KB]

Code gehört in den Codebereich der UserForm:

Option Explicit
Dim objWDD As Object
Dim objWD As Object
Private Sub UserForm_Activate()
TextBox1.Text = _
"OptionButton ""Schreiben..."" oder ""Lesen..."". " & _
vbCrLf & "Dann Worddatei über Button rechts auswählen..."
OptionButton1.Value = True
CommandButton3.Enabled = False
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
If CloseMode = 0 Then MsgBox "ESC-Button nutzen!": Cancel = True
End Sub
Private Sub CommandButton2_Click()
Unload Me
End Sub
Private Sub CommandButton3_Click()
Call Los
End Sub
Private Sub CommandButton1_Click()
Dim varFile As Variant
varFile = Application.GetOpenFilename _
(FileFilter:="Word (*.doc*), *.doc*")
If VarType(varFile) <> vbBoolean Then
TextBox1.Text = varFile
CommandButton3.Enabled = True
Else
TextBox1.Text = "Keine Datei ausgewählt..."
End If
End Sub
Private Sub Los()
On Error Resume Next
Set objWD = GetObject(, "Word.Application")
Select Case Err.Number
Case 429
Err.Clear
Set objWD = CreateObject("Word.Application")
If Err.Number > 0 Then
MsgBox Err.Number & " " & Err.Description
Set objWD = Nothing
Exit Sub
End If
Case 0
Case Else
MsgBox Err.Number & " " & Err.Description
Set objWD = Nothing
Exit Sub
End Select
On Error GoTo 0
On Error GoTo Fin
If OptionButton1.Value = True Then
Call Read_Word
Else
Call Write_Word
End If
Fin:
objWD.Quit
Set objWDD = Nothing
Set objWD = Nothing
If Err.Number <> 0 Then MsgBox Err.Number & " " & Err.Description
End Sub
Private Sub Read_Word()
objWD.Documents.Open (TextBox1.Text)
Set objWDD = objWD.Documents(1)
With objWDD
TextBox2.Text = .BuiltinDocumentProperties("Title").Value
TextBox3.Text = .BuiltinDocumentProperties("Author").Value
TextBox4.Text = .BuiltinDocumentProperties("Company").Value
TextBox5.Text = .BuiltinDocumentProperties("Manager").Value
TextBox6.Text = .BuiltinDocumentProperties("Subject").Value
TextBox7.Text = .BuiltinDocumentProperties("Category").Value
TextBox8.Text = .BuiltinDocumentProperties("Hyperlink base").Value
TextBox9.Text = .BuiltinDocumentProperties("Comments").Value
TextBox10.Text = .BuiltinDocumentProperties("Keywords").Value
End With
objWD.ActiveDocument.Close False
End Sub
Private Sub Write_Word()
objWD.Documents.Open (TextBox1.Text)
Set objWDD = objWD.Documents(1)
With objWDD
.BuiltinDocumentProperties("Title").Value = TextBox2.Text
.BuiltinDocumentProperties("Author").Value = TextBox3.Text
.BuiltinDocumentProperties("Company").Value = TextBox4.Text
.BuiltinDocumentProperties("Manager").Value = TextBox5.Text
.BuiltinDocumentProperties("Subject").Value = TextBox6.Text
.BuiltinDocumentProperties("Category").Value = TextBox7.Text
.BuiltinDocumentProperties("Hyperlink base").Value = TextBox8.Text
.BuiltinDocumentProperties("Comments").Value = TextBox9.Text
.BuiltinDocumentProperties("Keywords").Value = TextBox10.Text
End With
objWD.ActiveDocument.Close True
End Sub

Formeln auf einer UserForm in einer TextBox darstellen...

Formeln auf einer UserForm in einer TextBox anzeigen. Z. B. "Formula", "FormulaLocal"... und wie muss die Formel in VBA ...