25.12.2008

Range - InputBox - PowerPoint...



Mit folgendem Code wird ein Bereich (Auswahl per InputBox) nach PowerPoint kopiert. Eingefügt als Link und als Bild. Automatisch im ermittelten TMP-Ordner gespeichert. Die beiden Bilder oben sind aus dem Objektexplorer (F2 in VBE) von PowerPoint und zeigen die Möglichkeiten des einfügens. Die Dateien am Ende des Beitrages sind in der Version für Excel 2003 und >=2007.


Option Explicit
Private Declare Function GetTempPath Lib "kernel32" Alias _
    "GetTempPathA" (ByVal strBufferLength As Long, ByVal _
    lpBuffer As String) As Long
Const strPPSave As String = "Test.ppt"
'--------------------------------------------------------------------------
' Module    : Module1
' Procedure : Test
' Author    : © Case (Ralf Stolzenburg)
' Date      : 25.12.2008
' Purpose   : Range - InputBox - nach PowerPoint...
'--------------------------------------------------------------------------
Public Sub Test()
    Dim strFileName As String
    Dim objPPRange As Object
    Dim objPPApp As Object
    Dim objSlide As Object
    Dim varTMP As Variant
    On Error GoTo Fin
    Set varTMP = Application.InputBox("Range select.", "Select", , , , , , 8)
    Set objPPApp = CreateObject("PowerPoint.Application")
    With objPPApp
        .Visible = True
        .Presentations.Add
        .ActivePresentation.Slides.Add 1, 12
        ThisWorkbook.Worksheets(varTMP.Parent.Name).Range(varTMP.Address).CopyPicture
        Set objSlide = .ActivePresentation.Slides(1)
        Set objPPRange = objSlide.Shapes.Paste
        With objPPRange
            .LockAspectRatio = False
            .Width = objSlide.Design.SlideMaster.Width
            .Height = objSlide.Design.SlideMaster.Height
            .Align 4, True
            .Align 1, True
        End With
        Sheet1.Range(varTMP.Address).Copy
        .ActivePresentation.Slides.Add 2, 12
        .ActiveWindow.View.GotoSlide (2)
        .ActiveWindow.View.PasteSpecial 10, , , , , -1
        .ActivePresentation.Slides.Add 3, 12
        .ActiveWindow.View.GotoSlide (3)
        .ActiveWindow.View.PasteSpecial 2
        strFileName = PP_Save
        .ActivePresentation.SaveAs strFileName & strPPSave
    End With
Fin:
    Application.CutCopyMode = False
    Set objPPRange = Nothing
    Set objPPApp = Nothing
    Set objSlide = Nothing
End Sub
Private Function PP_Save() As String
    Dim strBuffer As String
    Dim lngReturn As Long
    strBuffer = Space(255)
    lngReturn = GetTempPath(255, strBuffer)
    If lngReturn > 0 Then
        PP_Save = Left$(strBuffer, lngReturn)
    Else
        PP_Save = CurDir$
    End If
    If Right(PP_Save, 1) <> "\" Then PP_Save = PP_Save & "\"
End Function


Sample 2003

Sample 2007

16.12.2008

Search Word!

All files (*.doc) of a selectable folder - with subfolders - ar scanned for a term. If the term is found, the files are linked and listed. The files at the end of the article are Excelfiles of the version 2003 and 2007.


Link:
http://vbanet.blogspot.com/2011/03/worddateien-durchsuchen-auch-mit.html
The following code belonged in "Module1"

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
Const strSearchTMP As String = "Calculation"
Const strEXT As String = "*.doc"
Private strList() As String
Private objWDApp As Object
Private lngCount As Long
Private objFSO As Object
Public Sub Test()
Dim strListing As String
Dim strDirOld As String
lngCount = 0
On Error GoTo Fin
strDirOld$ = String(255, 0)
Call GetCurrentDirectory(255, strDirOld$)
strDirOld$ = Left(strDirOld$, _
InStr(1, strDirOld$, vbNullChar) - 1)
If funcDirectory(strListing) <> "" Then
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objWDApp = CreateObject("Word.Application")
SearchFiles strListing, strEXT
If lngCount = 0 Then
MsgBox "No file with the search value found."
Else
With Tabelle1 ' anpassen!!!
.Cells.Clear
.Range(.Cells(1, 1), Cells(lngCount, 1)) = _
WorksheetFunction.Transpose(strList)
End With
Call HyLink(Tabelle1)
End If
End If
Fin:
If Not objWDApp Is Nothing Then objWDApp.Quit
Call SetCurrentDirectory(strDirOld$)
Set objWDApp = Nothing
Set objFSO = Nothing
End Sub
Private Sub SearchFiles(strFolder As String, strFileName As String)
Dim objFolder As Object
Dim objFile As Object
For Each objFile In objFSO.GetFolder(strFolder).Files
If objFile.Name Like strFileName Then
objWDApp.Documents.Open objFile.Path
With objWDApp.Selection.Find
.Forward = True
.Text = strSearchTMP
If .Execute = True Then
Redim Preserve strList(lngCount)
strList(lngCount) = objFile.Path
lngCount = lngCount + 1
objWDApp.ActiveDocument.Close False
End If
End With
End If
Next
For Each objFolder In objFSO.GetFolder(strFolder).Subfolders
SearchFiles strFolder & "\" & objFolder.Name, strFileName
Next
End Sub
Private Function funcDirectory(strDirectory As String) As String
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = "C:\"
.Title = "Directory"
.ButtonName = "Select..."
.InitialView = msoFileDialogViewList
If .Show = -1 Then
strDirectory = .SelectedItems(1)
If Right(strDirectory, 1) <> "\" _
Then strDirectory = strDirectory & "\"
funcDirectory = strDirectory
Else
funcDirectory = ""
End If
End With
End Function
Private Sub HyLink(objSheet As Object)
Dim lngRow As Long
With objSheet
lngRow = .Range("A" & .Rows.Count).End(xlUp).Row
For lngRow = 1 To lngRow
.Hyperlinks.Add Anchor:=.Cells(lngRow, 2), _
Address:=.Cells(lngRow, 1), _
TextToDisplay:=Mid(.Cells(lngRow, 1), _
InStrRev(.Cells(lngRow, 1), "\", -1) + 1)
Next lngRow
.Columns("A:B").AutoFit
End With
End Sub


Sample 2003

Sample 2007

11.12.2008

TextBoxes/ComboBoxes by Tab change!

With class programming you can change by "Tab" from a TextBox OR a ComboBox to the next, even if you new TextBoxes or ComboBoxes insert. In this case you must store the file, close and start again, or start the Sub "Private Sub Workbook_Open ()" again. If you "Shift" keep pressed you changed backwards. The TextBoxes or the ComboBoxes are in a worksheet NOT in a UserForm. The files at the end of the article are Excelfiles of the version 2003 and 2007.


The following code belonged In "ThisWorkbook"

Option Explicit
Private objTextBox() As clsTextBox
Private Sub Workbook_Open()
Dim objOLEObject As OLEObject
For Each objOLEObject In Worksheets("Sheet1").OLEObjects 'adapt
If objOLEObject.progID = "Forms.TextBox.1" Then
intIndex = intIndex + 1
Redim Preserve objTextBox(1 To intIndex)
Set objTextBox(intIndex) = New clsTextBox
Set objTextBox(intIndex).mobjTextBox = _
objOLEObject.Object
End If
Next objOLEObject
Sheet1.TextBox1.Activate
End Sub
Private Sub Workbook_SheetActivate(ByVal Sh As Object)
If Sh.Name = "Sheet1" Then ActiveSheet.TextBox1.Activate 'adapt
End Sub

The following code belonged In "Module1"

Option Explicit
Public intIndex As Integer

The following code belonged In a Class Module With name "clsTextBox"

Option Explicit
Public WithEvents mobjTextBox As MSForms.TextBox
Private Declare Function GetAsyncKeyState Lib "user32" _
(ByVal vKey As Long) As Integer
Private Sub mobjTextBox_KeyDown(ByVal KeyCode As _
MSForms.ReturnInteger, ByVal Shift As Integer)
Dim intTMP As Integer
intTMP = Div_Number(mobjTextBox.Name)
With ThisWorkbook.Worksheets("Sheet1") 'adapt
If intTMP = intIndex Then
If KeyCode = 9 Then If GetAsyncKeyState(16) Then _
.OLEObjects("TextBox" & intTMP - 1).Activate _
Else .TextBox1.Activate
ElseIf intTMP = 1 Then
If KeyCode = 9 Then If GetAsyncKeyState(16) Then _
.OLEObjects("TextBox" & intIndex).Activate _
Else .OLEObjects("TextBox" & intTMP + 1).Activate
Else
If KeyCode = 9 Then If GetAsyncKeyState(16) Then _
.OLEObjects("TextBox" & intTMP - 1).Activate _
Else .OLEObjects("TextBox" & intTMP + 1).Activate
End If
End With
End Sub
Private Function Div_Number(strTMP As String) As Integer
Dim intTMP As Integer
Dim strText As String
For intTMP = 1 To Len(strTMP)
If IsNumeric(Mid(strTMP, intTMP, 1)) Then
strText = strText & Mid(strTMP, intTMP, 1)
End If
Next intTMP
Div_Number = strText * 1
End Function

The following code Is For Comboboxes

The following code belonged In "ThisWorkbook"

Option Explicit
Private objCombo() As clsCombo
Private Sub Workbook_Open()
Dim objOLEObject As OLEObject
For Each objOLEObject In Worksheets("Sheet1").OLEObjects 'adapt
If objOLEObject.progID = "Forms.ComboBox.1" Then
intIndex = intIndex + 1
Redim Preserve objCombo(1 To intIndex)
Set objCombo(intIndex) = New clsCombo
Set objCombo(intIndex).mobjCombo = objOLEObject.Object
End If
Next objOLEObject
Sheet1.ComboBox1.Activate
End Sub
Private Sub Workbook_SheetActivate(ByVal Sh As Object)
If Sh.Name = "Sheet1" Then ActiveSheet.ComboBox1.Activate 'adapt
End Sub

The following code belonged In "Module1"

Option Explicit
Public intIndex As Integer

The following code belonged In a Class Module With name "clsCombo"

Option Explicit
Public WithEvents mobjCombo As MSForms.ComboBox
Private Declare Function GetAsyncKeyState Lib "user32" _
(ByVal vKey As Long) As Integer
Private Sub mobjCombo_KeyDown(ByVal KeyCode As _
MSForms.ReturnInteger, ByVal Shift As Integer)
Dim intTMP As Integer
intTMP = Div_Number(mobjCombo.Name)
With ThisWorkbook.Worksheets("Sheet1") 'adapt
If intTMP = intIndex Then
If KeyCode = 9 Then If GetAsyncKeyState(16) Then _
.OLEObjects("ComboBox" & intTMP - 1).Activate _
Else .ComboBox1.Activate
ElseIf intTMP = 1 Then
If KeyCode = 9 Then If GetAsyncKeyState(16) Then _
.OLEObjects("ComboBox" & intIndex).Activate _
Else .OLEObjects("ComboBox" & intTMP + 1).Activate
Else
If KeyCode = 9 Then If GetAsyncKeyState(16) Then _
.OLEObjects("ComboBox" & intTMP - 1).Activate _
Else .OLEObjects("ComboBox" & intTMP + 1).Activate
End If
End With
End Sub
Private Function Div_Number(strTMP As String) As Integer
Dim intTMP As Integer
Dim strText As String
For intTMP = 1 To Len(strTMP)
If IsNumeric(Mid(strTMP, intTMP, 1)) Then
strText = strText & Mid(strTMP, intTMP, 1)
End If
Next intTMP
Div_Number = strText * 1
End Function

Sample for Textboxes


Sample 2003

Sample 2007


Sample for Comboboxes


Sample 2003

Sample 2007

15.11.2008

Cell - Read - Closed Files!

From closed Workbooks certain cells are selected and summed up. The cells which can be selected are indicated in Sheet2 in column A. Some lines in the code must be adapted. These are characterized. In the ZIP file are example files. It functions immediately, if the file with the code is in the same folder as the files with the cells which must be read in. Subfolders are considered. 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
Const strSheet As String = "Sheet1" 'adapt
Public Sub Files_Read()
Dim stCalc As XlCalculation
Dim strDir As String
Dim objFSO As Object
Dim objDir As Object
On Error GoTo Fin
With Application
.ScreenUpdating = False
.AskToUpdateLinks = False
.EnableEvents = False
stCalc = .Calculation
.Calculation = xlCalculationManual
.DisplayAlerts = False
End With
Set objFSO = CreateObject("Scripting.FileSystemObject")
strDir = ThisWorkbook.Path 'adapt
Set objDir = objFSO.GetFolder(strDir)
dirInfo objDir, "*.xls"
Fin:
With Application
.ScreenUpdating = True
.AskToUpdateLinks = True
.EnableEvents = True
.Calculation = stCalc
.DisplayAlerts = True
End With
Set objDir = Nothing
Set objFSO = Nothing
End Sub
Public Sub dirInfo(ByVal objCurrentDir As Object, _
ByVal strName As String)
Dim objWorkbook As Workbook
Dim strFormula As String
Dim varRange As Variant
Dim varTMP As Variant
Dim intTMP As Integer
For Each varTMP In objCurrentDir.Files
If varTMP.Name Like strName And varTMP.Name <> _
ThisWorkbook.Name Then
With Sheet2 'adapt
varRange = .Range(.Cells(1, 1), .Cells _
(.Rows.Count, 1).End(xlUp).Rows)
strFormula = "='" & Mid(varTMP.Path, 1, _
InStrRev(varTMP.Path, "\")) & "[" & _
Mid(varTMP.Path, InStrRev _
(varTMP.Path, "\") + 1) & "]" & strSheet & "'!"
For intTMP = 1 To Ubound(varRange)
.Range("B" & intTMP).Formula = _
strFormula & varRange(intTMP, 1)
Sheet1.Range(varRange(intTMP, 1)).Value = _
Sheet1.Range(varRange(intTMP, 1)).Value + _
.Range("B" & intTMP).Value
Next intTMP
End With
End If
Next
For Each varTMP In objCurrentDir.SubFolders
dirInfo varTMP, strName
Next varTMP
Set objWorkbook = Nothing
End Sub


Sample ZIP - 2007 and 2003

02.11.2008

Pictures centers!

Cliparts in one worksheet, or in all worksheets are centered vertically and horizontal in the cell. The pictures can be aligned also again left above. The individual examples differed only in the kind, how the worksheet is addressed. 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 Picture_Center_Index()
Dim shpPicture As Shape
With ThisWorkbook.Worksheets(1)
For Each shpPicture In .Shapes
If shpPicture.Type = msoPicture Then
shpPicture.Left = shpPicture.Left + _
(shpPicture.TopLeftCell.Width - _
shpPicture.Width) / 2
shpPicture.Top = shpPicture.Top + _
(shpPicture.TopLeftCell.Height - _
shpPicture.Height) / 2
End If
Next shpPicture
End With
End Sub
Public Sub Picture_Center_Name()
Dim shpPicture As Shape
With ThisWorkbook.Worksheets("Sheet1")
For Each shpPicture In .Shapes
If shpPicture.Type = msoPicture Then
shpPicture.Left = shpPicture.Left + _
(shpPicture.TopLeftCell.Width - _
shpPicture.Width) / 2
shpPicture.Top = shpPicture.Top + _
(shpPicture.TopLeftCell.Height - _
shpPicture.Height) / 2
End If
Next shpPicture
End With
End Sub
Public Sub Picture_Center_CodeName()
Dim shpPicture As Shape
With Sheet1
For Each shpPicture In .Shapes
If shpPicture.Type = msoPicture Then
shpPicture.Left = shpPicture.Left + _
(shpPicture.TopLeftCell.Width - _
shpPicture.Width) / 2
shpPicture.Top = shpPicture.Top + _
(shpPicture.TopLeftCell.Height - _
shpPicture.Height) / 2
End If
Next shpPicture
End With
End Sub
Public Sub Picture_Center_All_Worksheet()
Dim wksSheet As Worksheet
Dim shpPicture As Shape
For Each wksSheet In ThisWorkbook.Worksheets
With wksSheet
For Each shpPicture In .Shapes
If shpPicture.Type = msoPicture Then
shpPicture.Left = shpPicture.Left + _
(shpPicture.TopLeftCell.Width - _
shpPicture.Width) / 2
shpPicture.Top = shpPicture.Top + _
(shpPicture.TopLeftCell.Height - _
shpPicture.Height) / 2
End If
Next shpPicture
End With
Next wksSheet
End Sub
Public Sub Picture_Reset()
Dim wksSheet As Worksheet
Dim shpPicture As Shape
For Each wksSheet In ThisWorkbook.Worksheets
With wksSheet
For Each shpPicture In .Shapes
If shpPicture.Type = msoPicture Then
shpPicture.Left = _
shpPicture.TopLeftCell.Left
shpPicture.Top = _
shpPicture.TopLeftCell.Top
End If
Next shpPicture
End With
Next wksSheet
End Sub


Sample 2003

Sample 2007

01.11.2008

Check Boxes from Form Controls!

Information about check boxes from form controls. You can check, reset, move, create and other things. The "Create Button" is to demonstrates that also. e.g. for a COMMANDBUTTON (ActiveX Controls) in the worksheet the code to set or reset the hook has to be changed. The files at the end of the article are Excelfiles of the version 2003 and 2007.


The following code belonged in "Module1"


Option Explicit
Sub CHECK_Formular_CheckBox()
Dim shpBox As Shape
For Each shpBox In ActiveSheet.Shapes
If shpBox.Type <> msoOLEControlObject Then
If shpBox.FormControlType = xlCheckBox Then
shpBox.ControlFormat.Value = 1
End If
End If
Next
End Sub
Sub Reset_Formular_CheckBox()
Dim shpBox As Shape
For Each shpBox In ActiveSheet.Shapes
If shpBox.AlternativeText Like "Box*" Then
shpBox.ControlFormat.Value = False
End If
Next
End Sub
Sub Reset_Formular_CheckBox_1()
Dim shpBox As Shape
For Each shpBox In ActiveSheet.Shapes
If shpBox.FormControlType = xlCheckBox Then
shpBox.ControlFormat.Value = False
End If
Next
End Sub
Sub Reset_Formular_CheckBox_2()
Dim shpBox As Shape
For Each shpBox In ActiveSheet.Shapes
If shpBox.FormControlType = 1 Then
shpBox.ControlFormat.Value = 0
End If
Next
End Sub
Sub Create_Button()
If Sheet1.OLEObjects.Count >= 1 Then Exit Sub
With Sheet1.OLEObjects.Add(ClassType:="Forms.CommandButton.1", _
Left:=435, Top:=225, Width:=60, Height:=30)
.Name = "CButton"
.Object.Caption = "Test"
End With
End Sub
Sub Delete_Button()
On Error Resume Next
Sheet1.Shapes("CButton").Delete
End Sub
Sub Reset_Formular_CheckBox_3()
Dim shpBox As Shape
For Each shpBox In ActiveSheet.Shapes
If shpBox.Type <> msoOLEControlObject Then
If shpBox.FormControlType = xlCheckBox Then
shpBox.ControlFormat.Value = False
End If
End If
Next
End Sub
Sub Step_Right()
Dim shpBox As Shape
For Each shpBox In ActiveSheet.Shapes
If shpBox.Type <> msoOLEControlObject Then
If shpBox.FormControlType = xlCheckBox Then
shpBox.Left = shpBox.Left + 50
End If
End If
Next
End Sub
Sub Step_Left()
Dim shpBox As Shape
For Each shpBox In ActiveSheet.Shapes
If shpBox.Type <> msoOLEControlObject Then
If shpBox.FormControlType = xlCheckBox Then
shpBox.Left = shpBox.Left - 50
End If
End If
Next
End Sub
Sub CheckBox_Linked_Cell()
Dim shpBox As Shape
For Each shpBox In ActiveSheet.Shapes
If Left(shpBox.Name, 5) = "Check" Then
shpBox.ControlFormat.LinkedCell = shpBox.TopLeftCell.Offset(0, 1).Address
Debug.Print shpBox.ControlFormat.LinkedCell
End If
Next
End Sub
Sub CheckBox_Create()
Dim objBox As Object
Set objBox = ActiveSheet.CheckBoxes.Add(0, 0, 0, 0)
With objBox
.Left = Cells(22, 3).Left
.Top = Cells(22, 3).Top
.Height = 17.25
.Width = 96
.Caption = "New 11"
End With
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 ...