23.07.2009

UserForm - Diagrams!

Since the Web components by Microsoft are not always installed a diagram can be indicated over detours in a UserForm. With the following code diagrams are indicated in a UserForm. The diagram is in the determined "Temp-Folder" temporarly stored, then in "Frame Picture" of the UserForm loaded and in "Temp-Folder" deleted.


Da die Webkomponenten von Microsoft nicht immer installiert sind kann ein Diagramm auch über Umwege in einer UserForm angezeigt werden. Mit dem folgenden Code werden Diagramme in einer UserForm angezeigt. Das Diagramm wird im ermittelten "TEMP-Ordner" temporär gespeichert, dann in den "Frame Picture" der UserForm geladen und ím "TEMP-Ordner" gelöscht. Die Dateien am Ende des Artikels sind Exceldateien der Version 2003 und 2007.


' Code in "DieseArbeitsmappe"
Option Explicit
Private Sub Workbook_Open()
Application.OnKey "{F4}", "Module1.UF_Show"
End Sub
Private Sub Workbook_Deactivate()
Application.OnKey "{F4}"
End Sub

' Code in "UserForm1"
Option Explicit
Private Declare Function GetTempPath Lib "kernel32" Alias _
"GetTempPathA" (ByVal nBufferLength As Long, ByVal _
lpBuffer As String) As Long
Private Sub CommandButton1_Click()
Unload Me
End Sub
Private Sub UserForm_Activate()
Dim wksSheet As Worksheet
On Error GoTo Fin
For Each wksSheet In ThisWorkbook.Worksheets
ListBox1.AddItem wksSheet.Name
Next
With Me
.ListBox2.Visible = False
.Label1.Visible = False
.Label3.Visible = False
End With
Application.VBE.MainWindow.Visible = False
Application.Visible = False
Fin:
If Err.Number <> 0 Then MsgBox Err.Number & " " & Err.Description
End Sub
Private Sub ListBox1_Click()
Dim sngOldWidth As Single
Dim sngOldHeight As Single
Dim wksSheet As Worksheet
Dim intCount As Integer
On Error GoTo Fin
Set wksSheet = ThisWorkbook.Worksheets(ListBox1.Text)
With Me
.ListBox2.Visible = False
.Label3.Visible = False
.Label1.Visible = False
.Label4.Visible = False
.ListBox2.Clear
End With
If wksSheet.ChartObjects.Count > 1 Then
ListBox2.Visible = True
Label3.Visible = True
For intCount = 1 To wksSheet.ChartObjects.Count
ListBox2.AddItem wksSheet.ChartObjects _
(intCount).Chart.ChartTitle.Text
Next
Frame1.Picture = LoadPicture()
Set wksSheet = Nothing
Label1.Visible = True
Exit Sub
Else
With ThisWorkbook.Worksheets(ListBox1.Text).ChartObjects(1)
sngOldWidth = .ShapeRange.Width
sngOldHeight = .ShapeRange.Height
.ShapeRange.Width = Frame1.Width
.ShapeRange.Height = Frame1.Height
.Chart.Export Filename:=GetTempDir & _
"Chart.gif", FilterName:="GIF"
.ShapeRange.Width = sngOldWidth
.ShapeRange.Height = sngOldHeight
End With
End If
With Frame1
.PictureSizeMode = fmPictureSizeModeZoom
.Picture = LoadPicture(GetTempDir & "Chart.gif")
End With
Kill (GetTempDir & "Chart.gif")
Fin:
Set wksSheet = Nothing
If Err.Number <> 0 Then MsgBox Err.Number & " " & Err.Description
End Sub
Private Sub ListBox2_Click()
Dim sngOldWidth As Single
Dim sngOldHeight As Single
Dim wksSheet As Worksheet
Dim intCount As Integer
On Error GoTo Fin
Set wksSheet = ThisWorkbook.Worksheets(ListBox1.Text)
Label1.Visible = False
With ThisWorkbook.Worksheets(ListBox1.Text). _
ChartObjects(ListBox2.ListIndex + 1)
sngOldWidth = .ShapeRange.Width
sngOldHeight = .ShapeRange.Height
.ShapeRange.Width = Frame1.Width
.ShapeRange.Height = Frame1.Height
.Chart.Export Filename:=GetTempDir & _
"Chart.gif", FilterName:="GIF"
.ShapeRange.Width = sngOldWidth
.ShapeRange.Height = sngOldHeight
End With
With Frame1
.PictureSizeMode = fmPictureSizeModeZoom
.Picture = LoadPicture(GetTempDir & "Chart.gif")
End With
Kill (GetTempDir & "Chart.gif")
Fin:
Set wksSheet = Nothing
If Err.Number <> 0 Then MsgBox Err.Number & " " & Err.Description
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
If CloseMode = 0 Then
MsgBox "Click Button ""ESC""!"
Cancel = True
Else
Application.VBE.MainWindow.Visible = True
Application.Visible = True
End If
End Sub
Public Function GetTempDir() As String
Dim strTMP As String
Dim lngCount As Long
Dim strPath As String
On Error GoTo Fin
strTMP = Space(255)
lngCount = GetTempPath(255, strTMP)
If lngCount > 0 Then
strPath = Left$(strTMP, lngCount)
If Right$(strPath, 1) <> "\" Then strPath = strPath & "\"
End If
GetTempDir = strPath
Fin:
If Err.Number <> 0 Then MsgBox Err.Number & " " & Err.Description
End Function

' Code in ein "Modul"
Option Explicit
Public Sub UF_Show()
UserForm1.Show
End Sub


Sample 2003

Sample 2007

22.07.2009

Files - Rename!

With the following code all file extensions of the files in a folder are renamed. In this example from "*.csv" to "*.txt". Subfolders can be considered optionally. The files at the end of the article are Excelfiles of the version 2003 and 2007. The following code belonged in "Module1, Module2, Module3".


Mit folgendem Code werden alle Dateiendungen der Dateien in einem Ordner umbenannt. In diesem Beispiel von "*.csv" nach "*.txt". Unterordner können optional berücksichtigt werden. Die Dateien am Ende des Artikels sind Exceldateien der Version 2003 und 2007. Der folgende Code gehört in "Modul1, Modul2, Modul3".


Option Explicit
Const strOldEX As String = ".csv"
Const strNewEX As String = ".txt"
Public Sub Files_Rename()
Dim objFSO As Object
Dim objDir As Object
On Error GoTo Fin
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objDir = objFSO.GetFolder(ThisWorkbook.Path & "\")
'Call dirInfo(objDir, "*" & strOldEX, True) ' with subfolders
Call dirInfo(objDir, "*" & strOldEX)
Fin:
Set objDir = Nothing
Set objFSO = Nothing
If Err.Number <> 0 Then MsgBox Err.Number & " " & Err.Description
End Sub
Private Sub dirInfo(ByVal objCurrentDir As Object, ByVal strName As String, _
Optional ByVal blnTMP As Boolean = False)
Dim strNewName As String
Dim varTMP As Variant
For Each varTMP In objCurrentDir.Files
If UCase(varTMP.Name) Like UCase(strName) Then
strNewName = Replace(varTMP.Name, strOldEX, strNewEX)
Name varTMP.Path As varTMP.ParentFolder & "\" & strNewName
End If
Next varTMP
If blnTMP = True Then
For Each varTMP In objCurrentDir.SubFolders
dirInfo varTMP, strName, True
Next varTMP
End If
End Sub


Option Explicit
Dim strOldEX As String
Dim strNewEX As String
Public Sub Files_Rename_1()
Dim objFSO As Object
Dim objDir As Object
On Error GoTo Fin
strOldEX = InputBox("OLD extension e.g. csv", "Rename", "csv")
If strOldEX = "" Then Exit Sub
If Right(strOldEX, 1) <> "." Then strOldEX = "." & strOldEX
strNewEX = InputBox("NEW extension e.g. txt", "Rename", "txt")
If strNewEX = "" Then Exit Sub
If Right(strNewEX, 1) <> "." Then strNewEX = "." & strNewEX
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objDir = objFSO.GetFolder(ThisWorkbook.Path & "\")
'Call dirInfo(objDir, "*" & strOldEX, True) ' with subfolders
Call dirInfo(objDir, "*" & strOldEX)
Fin:
Set objDir = Nothing
Set objFSO = Nothing
If Err.Number <> 0 Then MsgBox Err.Number & " " & Err.Description
End Sub
Private Sub dirInfo(ByVal objCurrentDir As Object, ByVal strName As String, _
Optional ByVal blnTMP As Boolean = False)
Dim strNewName As String
Dim varTMP As Variant
For Each varTMP In objCurrentDir.Files
If UCase(varTMP.Name) Like UCase(strName) Then
strNewName = Replace(varTMP.Name, strOldEX, strNewEX)
Name varTMP.Path As varTMP.ParentFolder & "\" & strNewName
End If
Next varTMP
If blnTMP = True Then
For Each varTMP In objCurrentDir.SubFolders
dirInfo varTMP, strName, True
Next varTMP
End If
End Sub


Option Explicit
Public intTMP As Integer
Dim strOldEX As String
Dim strNewEX As String
Public Sub Files_Rename_2()
Dim objFSO As Object
Dim objDir As Object
On Error GoTo Fin
strOldEX = InputBox("OLD extension e.g. csv", "Rename", "csv")
If strOldEX = "" Then Exit Sub
If Left(strOldEX, 1) <> "." Then strOldEX = "." & strOldEX
strNewEX = InputBox("NEW extension e.g. txt", "Rename", "txt")
If strNewEX = "" Then Exit Sub
If Left(strNewEX, 1) <> "." Then strNewEX = "." & strNewEX
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objDir = objFSO.GetFolder(funcDirectory("C:\"))
'Call dirInfo(objDir, "*" & strOldEX, True) ' with subfolders
Call dirInfo(objDir, "*" & strOldEX)
Fin:
If intTMP = 0 Then
MsgBox "No files renamed!"
Else
MsgBox intTMP & " files renamed!"
intTMP = 0
End If
Set objDir = Nothing
Set objFSO = Nothing
If Err.Number <> 0 Then MsgBox Err.Number & " " & Err.Description
End Sub
Private Sub dirInfo(ByVal objCurrentDir As Object, ByVal strName As String, _
Optional ByVal blnTMP As Boolean = False)
Dim strNewName As String
Dim varTMP As Variant
For Each varTMP In objCurrentDir.Files
If UCase(varTMP.Name) Like UCase(strName) Then
strNewName = Replace(varTMP.Name, strOldEX, strNewEX)
intTMP = intTMP + 1
Name varTMP.Path As varTMP.ParentFolder & "\" & strNewName
End If
Next varTMP
If blnTMP = True Then
For Each varTMP In objCurrentDir.SubFolders
dirInfo varTMP, strName, True
Next varTMP
End If
End Sub
Private Function funcDirectory(strFolder As String) As String
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = "C:\"
.Title = "Folder"
.ButtonName = "Select..."
.InitialView = msoFileDialogViewList
If .Show = -1 Then
strFolder = .SelectedItems(1)
If Right(strFolder, 1) <> "\" Then strFolder = strFolder & "\"
Else
strFolder = ""
End If
End With
funcDirectory = strFolder
End Function


Sample 2003

Sample 2007

21.07.2009

Office - Applications - Started!

With the following code the different Office applications (Word, PowerPoint, Access, Outlook) is started. It is examined whether application is already started. For each application there is a small example. Word - text mark put on and fill. PowerPoint - Slides put on and a range from Excel copy (picture, embedded object and metafile). Access - an empty data base is provided. Outlook - the number of mails in the inbox is spent. The files at the end of the article are Excelfiles of the version 2003 and 2007. The following code belonged in "Module1, Module2, Module3, Module4".


Mit folgendem Code werden die verschiedenen Office Anwendungen (Word, PowerPoint, Access, Outlook) gestartet. Es wird geprüft, ob die Anwendung schon gestartet ist. Für jede Applikation gibt es ein kleines Beispiel. Word - Textmarke anlegen und befüllen. PowerPoint - Slides anlegen und einen Bereich aus Excel kopieren (Bild, eingebettetes Objekt und Metafile). Access - eine leere Datenbank wird erstellt. Outlook - die Anzahl der Mails im Posteingang wird ausgegeben. Die Dateien am Ende des Artikels sind Exceldateien der Version 2003 und 2007. Der folgende Code gehört in "Modul1, Modul2, Modul3, Modul4".


Option Explicit
Dim objWDD As Object
Dim objWD As Object
Dim strTMP As String
Public Sub Word_Bookmark()
Application.ScreenUpdating = False
On Error Resume Next
Set objWD = GetObject(, "Word.Application")
Select Case Err.Number
Case 429
Err.Clear
Set objWD = CreateObject("Word.Application")
objWD.Visible = True
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
Call Do_Word
Fin:
Set objWDD = Nothing
Set objWD = Nothing
Application.ScreenUpdating = True
If Err.Number <> 0 Then MsgBox "Fehler: " & _
Err.Number & " " & Err.Description
End Sub
Private Sub Do_Word()
Set objWDD = objWD.Documents.Add
objWDD.Bookmarks.Add Name:="Test" ' adapt
With Sheet1 ' adapt
strTMP = .Cells(1, 1).Value & vbCrLf & _
.Cells(2, 1).Value & " " & .Cells(3, 1).Value
End With
objWDD.Bookmarks("Test").Range = strTMP
End Sub


Option Explicit
Dim objPPRange As Object
Dim objPPApp As Object
Dim objSlide As Object
Dim rngRange As Range
Public Sub PowerPoint_Slide()
On Error GoTo Fin
Application.ScreenUpdating = False
On Error Resume Next
Set objPPApp = GetObject(, "PowerPoint.Application")
Select Case Err.Number
Case 429
Err.Clear
Set objPPApp = CreateObject("PowerPoint.Application")
objPPApp.Visible = True
If Err.Number > 0 Then
MsgBox Err.Number & " " & Err.Description
Set objPPApp = Nothing
Exit Sub
End If
Case 0
Case Else
MsgBox Err.Number & " " & Err.Description
Set objPPApp = Nothing
Exit Sub
End Select
On Error GoTo 0
On Error GoTo Fin
Call Do_PowerPoint
Fin:
Application.ScreenUpdating = True
Application.CutCopyMode = False
Set objPPRange = Nothing
Set objPPApp = Nothing
Set objSlide = Nothing
If Err.Number <> 0 Then MsgBox "Fehler: " & _
Err.Number & " " & Err.Description
End Sub
Private Sub Do_PowerPoint()
Set rngRange = Sheet1.Range("A1:D10")
With objPPApp
.Visible = True
.Presentations.Add
.ActivePresentation.Slides.Add 1, 12
'Const ppLayoutBlank = 12
ThisWorkbook.Worksheets(rngRange.Parent.Name) _
.Range(rngRange.Address).CopyPicture
Set objSlide = .ActivePresentation.Slides(1)
Set objPPRange = objSlide.Shapes.Paste
With objPPRange
.Align 4, True
.Align 1, True
End With
Sheet1.Range(rngRange.Address).Copy
.ActivePresentation.Slides.Add 2, 12
'Const ppLayoutBlank = 12
.ActiveWindow.View.GotoSlide (2)
.ActiveWindow.View.PasteSpecial 10, , , , , -1
'Const ppPasteOLEObject = 10
.ActivePresentation.Slides.Add 3, 12
'Const ppLayoutBlank = 12
.ActiveWindow.View.GotoSlide (3)
.ActiveWindow.View.PasteSpecial 2
'Const ppPasteEnhancedMetafile = 2
End With
End Sub


Option Explicit
Dim strFileName As String
Dim objDataBase As Object
Dim objAcc As Object
Public Sub Access_Open()
Application.ScreenUpdating = False
On Error Resume Next
Set objAcc = GetObject(, "Access.Application")
Select Case Err.Number
Case 429
Err.Clear
Set objAcc = CreateObject("Access.Application")
objAcc.Visible = False
If Err.Number > 0 Then
MsgBox Err.Number & " " & Err.Description
Set objAcc = Nothing
Exit Sub
End If
Case 0
Case Else
MsgBox Err.Number & " " & Err.Description
Set objAcc = Nothing
Exit Sub
End Select
On Error GoTo 0
On Error GoTo Fin
Call Do_Access
Fin:
Set objDataBase = Nothing
Set objAcc = Nothing
Application.ScreenUpdating = True
If Err.Number <> 0 Then MsgBox "Fehler: " & _
Err.Number & " " & Err.Description
End Sub
Private Sub Do_Access()
strFileName = ThisWorkbook.Path & "\Test.mdb"
If Dir(strFileName) <> "" Then Kill (strFileName)
Set objDataBase = CreateObject(Class:="ADOX.Catalog")
objDataBase.Create "Provider=Microsoft.Jet.OLEDB.4.0; " _
& "Data Source=" & strFileName
MsgBox "Empty ""mdb"" in " & ThisWorkbook.FullName & _
"\Test.mdb" & " - and ACCESS is closed."
End Sub


Option Explicit
Dim objOutlook As Object
Public Sub Outlook_Open()
Application.ScreenUpdating = False
On Error Resume Next
Set objOutlook = GetObject(, "Outlook.Application")
Select Case Err.Number
Case 429
Err.Clear
Set objOutlook = CreateObject("Outlook.Application")
If Err.Number > 0 Then
MsgBox Err.Number & " " & Err.Description
Set objOutlook = Nothing
Exit Sub
End If
Case 0
Case Else
MsgBox Err.Number & " " & Err.Description
Set objOutlook = Nothing
Exit Sub
End Select
On Error GoTo 0
On Error GoTo Fin
Call Do_Outlook
Fin:
Set objOutlook = Nothing
Application.ScreenUpdating = True
If Err.Number <> 0 Then MsgBox "Fehler: " & _
Err.Number & " " & Err.Description
End Sub
Private Sub Do_Outlook()
Dim myNameSpace As Object
Dim myFolder As Object
Set myNameSpace = objOutlook.GetNamespace("MAPI")
Set myFolder = myNameSpace.GetDefaultFolder(6)
'Const olFolderCalendar = 9
'Const olFolderConflicts = 19 (&H13)
'Const olFolderContacts = 10
'Const olFolderDeletedItems = 3
'Const olFolderDrafts = 16 (&H10)
'Const olFolderInbox = 6
'Const olFolderJournal = 11
'Const olFolderJunk = 23 (&H17)
'Const olFolderLocalFailures = 21 (&H15)
'Const olFolderNotes = 12
'Const olFolderOutbox = 4
'Const olFolderSentMail = 5
'Const olFolderServerFailures = 22 (&H16)
'Const olFolderSyncIssues = 20 (&H14)
'Const olFolderTasks = 13
'Const olPublicFoldersAllPublicFolders = 18 (&H12)
MsgBox "There are " & myFolder.Items.Count & _
" mails in the inbox."
End Sub


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