24.09.2008

Files and Folders!

So "Application.FileSearch" is under Excel 2007 not available the following is a possibility to listed files and folders. The codes differ only in the selection of the folder and whether an hyperlink is set or not. The files at the end of the article are Excelfiles of the version 2003 and 2007.


The following code belonged in "Module1"


Option Explicit
Private strList() As String
Private lngCount As Long
Public Sub Test()
lngCount = 0
SearchFiles "C:\Temp", "*.*" 'adapt
If lngCount = 0 Then
MsgBox "No file found"
Exit Sub
End If
With ThisWorkbook.Worksheets(1)
.Cells.Clear
.Range(.Cells(1, 1), Cells(lngCount, 1)) = _
WorksheetFunction.Transpose(strList)
End With
End Sub
Private Sub SearchFiles(strFolder As String, strFileName As String)
Dim objFolder As Object
Dim objFile As Object
Dim objFSO As Object
Set objFSO = CreateObject("Scripting.FileSystemObject")
For Each objFile In objFSO.GetFolder(strFolder).Files
If objFile.Name Like strFileName Then
Redim Preserve strList(lngCount)
strList(lngCount) = objFile.Name
lngCount = lngCount + 1
End If
Next
For Each objFolder In objFSO.GetFolder(strFolder).Subfolders
SearchFiles strFolder & "\" & objFolder.Name, strFileName
Next
End Sub

'The following code belonged in "Module2"

Option Explicit
Private strList() As String
Private strDir() As String
Private lngCount As Long
Public Sub Test_1()
lngCount = 0
SearchFiles "C:\Temp", "*.*" 'adapt
If lngCount = 0 Then
MsgBox "No file found"
Exit Sub
End If
With ThisWorkbook.Worksheets(1)
.Cells.Clear
.Range(.Cells(1, 2), Cells(lngCount, 2)) = _
WorksheetFunction.Transpose(strList)
.Range(.Cells(1, 1), Cells(lngCount, 1)) = _
WorksheetFunction.Transpose(strDir)
.Columns("A:B").AutoFit
End With
End Sub
Private Sub SearchFiles(strFolder As String, strFileName As String)
Dim objFolder As Object
Dim objFile As Object
Dim objFSO As Object
Set objFSO = CreateObject("Scripting.FileSystemObject")
For Each objFile In objFSO.GetFolder(strFolder).Files
If objFile.Name Like strFileName Then
Redim Preserve strList(lngCount)
Redim Preserve strDir(lngCount)
strList(lngCount) = objFile.Name
strDir(lngCount) = strFolder & "\"
lngCount = lngCount + 1
End If
Next
For Each objFolder In objFSO.GetFolder(strFolder).Subfolders
SearchFiles strFolder & "\" & objFolder.Name, strFileName
Next
End Sub

'The following code belonged in "Module3"

Option Explicit
Private strList() As String
Private strDir() As String
Private lngCount As Long
Public Sub Test_2()
Dim strTMP As String
lngCount = 0
strTMP = GetFolder()
If strTMP = "" Or Left(strTMP, 1) = ":" Then Exit Sub
SearchFiles strTMP, "*.*" 'adapt
If lngCount = 0 Then
MsgBox "No file found"
Exit Sub
End If
With ThisWorkbook.Worksheets(1)
.Cells.Clear
.Range(.Cells(1, 2), Cells(lngCount, 2)) = _
WorksheetFunction.Transpose(strList)
.Range(.Cells(1, 1), Cells(lngCount, 1)) = _
WorksheetFunction.Transpose(strDir)
.Columns("A:B").AutoFit
End With
End Sub
Private Function GetFolder() As String
Dim varFolder As Variant
Dim objShell As Object
Dim strPath As String
Set objShell = CreateObject("Shell.Application")
Set varFolder = objShell.BrowseForFolder(0, "Folder", &H10, 17)
If varFolder Is Nothing Then
Set varFolder = Nothing
Set objShell = Nothing
Exit Function
End If
GetFolder = varFolder.Self.Path
Set varFolder = Nothing
Set objShell = Nothing
End Function
Private Sub SearchFiles(strFolder As String, strFileName As String)
Dim objFolder As Object
Dim objFile As Object
Dim objFSO As Object
Set objFSO = CreateObject("Scripting.FileSystemObject")
For Each objFile In objFSO.GetFolder(strFolder).Files
If objFile.Name Like strFileName Then
Redim Preserve strList(lngCount)
Redim Preserve strDir(lngCount)
strList(lngCount) = objFile.Name
strDir(lngCount) = strFolder & "\"
lngCount = lngCount + 1
End If
Next
For Each objFolder In objFSO.GetFolder(strFolder).Subfolders
SearchFiles strFolder & "\" & objFolder.Name, strFileName
Next
End Sub

'The following code belonged in "Module4"

Option Explicit
Private strList() As String
Private strDir() As String
Private lngCount As Long
Public Sub Test_3()
Dim strTMP As String
lngCount = 0
strTMP = GetFolder()
If strTMP = "" Or Left(strTMP, 1) = ":" Then Exit Sub
SearchFiles strTMP, "*.*" 'adapt
If lngCount = 0 Then
MsgBox "No file found"
Exit Sub
End If
With ThisWorkbook.Worksheets(1)
.Cells.Clear
.Range(.Cells(1, 2), Cells(lngCount, 2)) = _
WorksheetFunction.Transpose(strList)
.Range(.Cells(1, 1), Cells(lngCount, 1)) = _
WorksheetFunction.Transpose(strDir)
.Columns("A:B").AutoFit
End With
Call Make_Link
End Sub
Private Function GetFolder() As String
Dim varFolder As Variant
Dim objShell As Object
Dim strPath As String
Set objShell = CreateObject("Shell.Application")
Set varFolder = objShell.BrowseForFolder(0, "Folder", &H10, 17)
If varFolder Is Nothing Then
Set varFolder = Nothing
Set objShell = Nothing
Exit Function
End If
GetFolder = varFolder.Self.Path
Set varFolder = Nothing
Set objShell = Nothing
End Function
Private Sub SearchFiles(strFolder As String, strFileName As String)
Dim objFolder As Object
Dim objFile As Object
Dim objFSO As Object
Set objFSO = CreateObject("Scripting.FileSystemObject")
For Each objFile In objFSO.GetFolder(strFolder).Files
If objFile.Name Like strFileName Then
Redim Preserve strList(lngCount)
Redim Preserve strDir(lngCount)
strList(lngCount) = objFile.Name
strDir(lngCount) = strFolder & "\"
lngCount = lngCount + 1
End If
Next
For Each objFolder In objFSO.GetFolder(strFolder).Subfolders
SearchFiles strFolder & "\" & objFolder.Name, strFileName
Next
End Sub
Public Sub Make_Link()
Dim lngRow As Long
With ThisWorkbook.Worksheets(1)
lngRow = .Range("B" & .Rows.Count).End(xlUp).Row
For lngRow = 1 To lngRow
.Hyperlinks.Add Anchor:=.Cells(lngRow, 2), _
Address:=.Cells(lngRow, 1) & .Cells(lngRow, 2)
Next lngRow
End With
End Sub


Sample 2003

Sample 2007

23.09.2008

Information about Shapes!

In the following code different information about Shapes on the current worksheet is spent. If you need still more information, then you look with F2 into the object catalog or also in the "Local Window", if you go with F8 step by step through the code. The files at the end of the article are Excelfiles of the version 2003 and 2007.


The following code belonged In "Module1"

Option Explicit
Public Sub Shape_Info()
Dim wksSheetNew As Worksheet
Dim wksSheet As Worksheet
Dim wksTMP As Worksheet
Dim shpShape As Shape
Dim lngRow As Long
On Error GoTo Fin
Application.ScreenUpdating = False
For Each wksTMP In ThisWorkbook.Worksheets
If wksTMP.Name = "Info_Shapes" Then
Application.DisplayAlerts = False
wksTMP.Delete
Application.DisplayAlerts = True
End If
Next wksTMP
Set wksSheet = ActiveSheet
If wksSheet.Shapes.Count < 1 Then
MsgBox "No Shapes in the current worksheet!"
Exit Sub
End If
Set wksSheetNew = Worksheets.Add(Before:=Worksheets(1))
wksSheetNew.Name = "Info_Shapes"
For Each shpShape In wksSheet.Shapes
With wksSheetNew
.Cells(lngRow + 1, 2) = shpShape.Name
.Cells(lngRow + 1, 2).Font.Bold = True
.Cells(lngRow + 1, 2).HorizontalAlignment = xlRight
.Cells(lngRow + 1, 1) = "Name"
.Cells(lngRow + 2, 2) = shpShape.Type
.Cells(lngRow + 2, 1) = "Type"
.Cells(lngRow + 3, 2) = shpShape.AutoShapeType
.Cells(lngRow + 3, 1) = "AutoShapeType"
.Cells(lngRow + 4, 2) = shpShape.Height
.Cells(lngRow + 4, 1) = "Height"
.Cells(lngRow + 5, 2) = shpShape.Width
.Cells(lngRow + 5, 1) = "Width"
.Cells(lngRow + 6, 2) = shpShape.Top
.Cells(lngRow + 6, 1) = "Top"
.Cells(lngRow + 7, 2) = shpShape.Left
.Cells(lngRow + 7, 1) = "Left"
.Cells(lngRow + 8, 2) = shpShape.TopLeftCell.Column
.Cells(lngRow + 8, 1) = "TopLeftCell.Column"
.Cells(lngRow + 9, 2) = shpShape.TopLeftCell.Row
.Cells(lngRow + 9, 1) = "TopLeftCell.Row"
.Cells(lngRow + 10, 2) = shpShape.TopLeftCell.Address(0, 0)
.Cells(lngRow + 10, 1) = "TopLeftCell.Address"
.Cells(lngRow + 10, 2).HorizontalAlignment = xlRight
If shpShape.OnAction = "" Then
.Cells(lngRow + 11, 2) = "No macro assigned!"
Else
.Cells(lngRow + 11, 2) = shpShape.OnAction
.Cells(lngRow + 11, 2).Font.ColorIndex = 3
End If
.Cells(lngRow + 11, 1) = "OnAction"
.Cells(lngRow + 11, 2).HorizontalAlignment = xlRight
lngRow = lngRow + 12
End With
Next
With wksSheetNew
.Range(Cells(1, 1), _
Cells(.Rows.Count, 1).End(xlUp)).Rows.Font.Bold = True
.Columns("A:B").AutoFit
End With
Fin:
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Set wksSheetNew = Nothing
Set wksSheet = Nothing
End Sub

The following code belonged In "Module2"

Option Explicit
Option Private Module
Sub Big()
With ActiveSheet.Shapes(Application.Caller)
.LockAspectRatio = True
.Height = .Height * 2
.Width = .Width * 2
.Rotation = 0#
.OnAction = "Small"
End With
End Sub
Sub Small()
With ActiveSheet.Shapes(Application.Caller)
.LockAspectRatio = True
.Height = .Height / 2
.Width = .Width / 2
.Rotation = 0#
.OnAction = "Big"
End With
End Sub


Sample 2003

Sample 2007

16.09.2008

Text largely or small!

Over a selection (UserForm) it is selected whether with an existing text all characters are represented largely or small. Or only the first character are largely represented. A further possibility offers the selection to write each individual alphabetic character after a dot largely. The files at the end of the article are Excelfiles of the version 2003 and 2007.


The following code belonged In "UserForm1"

Option Explicit
Private Sub Image1_Click()
Me.OptionButton1.Value = False
Me.OptionButton2.Value = False
Me.OptionButton3.Value = False
Unload UserForm1
End Sub
Private Sub Image2_Click()
If Me.OptionButton1.Value = True Then
Me.OptionButton1.Tag = "Go"
ElseIf Me.OptionButton2.Value = True Then
Me.OptionButton2.Tag = "Go"
ElseIf Me.OptionButton3.Value = True Then
Me.OptionButton3.Tag = "Go"
ElseIf Me.OptionButton4.Value = True Then
Me.OptionButton4.Tag = "Go"
End If
Me.Hide
End Sub
Private Sub UserForm_Activate()
Me.OptionButton1.Value = True
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
If CloseMode = 0 Then
MsgBox "No way!", vbCritical
Cancel = 1
End If
End Sub

The following code belonged In "Module1"

Option Explicit
Public Sub UF_Show()
Dim rngRange As Range
Dim varTMP As Variant
Dim rngCell As Range
Dim lngTMP As Long
On Error GoTo Fin
Set rngRange = Application.InputBox _
("Mark a range!", , , , , , , 8)
UserForm1.Show
With UserForm1
If .OptionButton1.Tag = "Go" Then
rngRange = UCase(rngRange)
ElseIf .OptionButton2.Tag = "Go" Then
rngRange = LCase(rngRange)
ElseIf .OptionButton3.Tag = "Go" Then
rngRange = StrConv(rngRange, vbProperCase)
ElseIf .OptionButton4.Tag = "Go" Then
For Each rngCell In rngRange
varTMP = Split(rngCell.Text, ".")
For lngTMP = 0 To Ubound(varTMP)
If varTMP(lngTMP) <> "" And _
Left(varTMP(lngTMP), 1) <> " " Then
varTMP(lngTMP) = StrConv(Left(varTMP(0), 1), _
vbProperCase) & Right(varTMP(0), _
Len(varTMP(0)) - 1) & "."
ElseIf varTMP(lngTMP) <> "" Then
varTMP(lngTMP) = StrConv _
(Left(varTMP(lngTMP), 2), _
vbProperCase) & Right(varTMP(lngTMP), _
Len(varTMP(lngTMP)) - 2) & "."
End If
Next lngTMP
rngCell.Value = Join(varTMP)
Next rngCell
End If
End With
Fin:
Unload UserForm1
Set rngRange = Nothing
End Sub


Sample 2003

Sample 2007

08.09.2008

Mark cells with formula!

Marked or all cells with formulas are represented with a red frame. The formulas are written additionally into the comment of the respective cell. Repeat the code deletes the frame and the comment. By the line "Option Private Module" the macros are not indicated in the macro window, but can be assigned however over the name to a button. The files at the end of the article are Excelfiles of the version 2003 and 2007.


The following code belonged In "Module1"

Option Explicit
Option Private Module
Public Sub Formula_Frame_Comment()
Dim rngRange As Range
Dim strTMP As String
On Error GoTo Fin
Application.ScreenUpdating = False
If Selection.Count > 1 Then
strTMP = Selection.Address(False, False)
Else
strTMP = Range(Cells(1, 1), _
Cells(Last_R, Last_C)).Address(False, False)
End If
For Each rngRange In Range(strTMP)
With rngRange
If .HasFormula Then
If .Comment Is Nothing Then
.Borders.LineStyle = xlDot
.Borders.Weight = xlThin
.Borders.ColorIndex = 3
.AddComment (.Formula)
.Comment.Shape.TextFrame.AutoSize = True
Else
.Borders.LineStyle = xlNone
.Comment.Delete
End If
End If
End With
Next
Fin:
Application.ScreenUpdating = True
End Sub
Public Function Last_R() As Long
With ActiveSheet
Last_R = .Cells.Find(What:="*", After:=Range("A1"), _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row
End With
End Function
Public Function Last_C() As Long
With ActiveSheet
Last_C = .Cells.Find(What:="*", After:=Range("A1"), _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious).Column
End With
End Function


Sample 2003

Sample 2007

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 ...