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

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