Range - PowerPoint!

With the following code a freely selectable range (InputBox) is copied to PowerPoint. It is inserted with and without linkage. The file is stored in automatically determined "Temp - folder". The two pictures are from the "Object Browser" (F2 in VBE) of Powerpoint and show the possibilities of inserting. That is not the wisdom last conclusion - however it functions. 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 Declare Function GetTempPath Lib "kernel32" Alias _
    "GetTempPathA" (ByVal strBufferLength As Long, ByVal _
    lpBuffer As String) As Long
Const strPPSave As String = "Test.ppt"
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
        Tabelle1.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

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

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