23.09.2010

Anzahl Zeilen Textdatei(en)!

Manchmal ganz hilfreich: Man(n) möchte die Anzahl Zeilen von Textdateien wissen, bevor man(n) etwas damit anfängt. Mit folgendem Code können über einen Auswahldialog eine oder mehrere Dateien ausgewählt werden. Die Ausgabe erfolgt im Moment im Direktbereich (Im VBA-Editor Ansicht Direktfenster bzw. Strg+G):

Option Explicit
Public Sub Test()
Dim strContent As String
Dim intCount As Integer
Dim varFiles As Variant
Dim objFile As Object
Dim objFSO As Object
On Error GoTo Fin
varFiles = Application.GetOpenFilename _
(Filefilter:="Textdateien (*.txt), *.*", _
Title:="Bitte Datei(en) auswaehlen", _
MultiSelect:=True)
If Not VarType(varFiles) = vbBoolean Then
Set objFSO = CreateObject("Scripting.FileSystemObject")
For intCount = Lbound(varFiles) To Ubound(varFiles)
Set objFile = objFSO.OpenTextFile(varFiles(intCount), 1)
strContent = objFile.ReadAll
Debug.Print "Datei: " & varFiles(intCount) & vbCrLf & _
objFile.Line & " Zeilen!" & vbCrLf
objFile.Close
Set objFile = Nothing
Next intCount
End If
Fin:
If Err.Number <> 0 Then MsgBox "Fehler: " & _
Err.Number & " " & Err.Description
Set objFile = Nothing
Set objFSO = Nothing
End Sub

20.09.2010

Access - Primärschlüssel!

Frage: Wie erstelle ich eine Access-Datenbank mit einer Tabelle und einem Primärschlüssel - am besten noch per "Late Binding" um die eventuell auftretenden Verweisprobleme zu umgehen? So:

Access - Primärschlüssel...[ZIP, 40 KB]

Code:
Option Explicit
' Pfad- und Dateiname anpassen!
Const strFileName As String = "C:\Temp\Test1.mdb"
Public Sub CreateDataBase()
Dim catCatalog As Object
Dim objTable As Object
Dim objIndex As Object
Dim objConn As Object
On Error GoTo Fin
Set objConn = CreateObject("ADODB.Connection")
Set catCatalog = CreateObject("ADOX.Catalog")
catCatalog.Create "Provider=Microsoft.Jet.OLEDB.4.0; " & _
"Data Source=" & strFileName
With objConn
.CursorLocation = 3 ' = adUseClient
.Provider = "Microsoft.Jet.OLEDB.4.0"
.Properties("Data Source") = strFileName
.Open
End With
Set objIndex = CreateObject("ADOX.Index")
Set objTable = CreateObject("ADOX.Table")
With objTable
.Name = "Lieferanten"
.ParentCatalog = catCatalog
.Columns.Append "Primaer", 3 ' = adInteger
With .Columns("Primaer")
.Properties("Description") = "Schluessel"
.Properties("Autoincrement") = True
End With
.Columns.Append "Name", 202, 60 ' 202 = adVarWChar
With .Columns("Name")
.Properties("Description") = "Nachname"
.Properties("Jet OLEDB:Allow Zero Length") = True
.Properties("Nullable") = True
End With
End With
catCatalog.Tables.Append objTable
With objIndex
.Name = "PrimaryKey"
.Columns.Append "Primaer"
.PrimaryKey = True
.Unique = True
End With
objTable.Indexes.Append objIndex
Fin:
If Err.Number <> 0 Then MsgBox "Fehler: " & _
Err.Number & " (" & Err.Description & ")"
If Not objConn Is Nothing And objConn.State = 1 Then objConn.Close
Set objIndex = Nothing
Set objTable = Nothing
Set catCatalog = Nothing
Set objConn = Nothing
End Sub

16.09.2010

Excel - PowerPoint!

Oft nachgefragt - wie bekomme ich einen Bereich aus Excel nach PowerPoint. Nachfolgend eine Möglichkeit. Die PowerPoint Datei kann wahlweise auf dem Desktop oder im TEMP Ordner gespeichert werden. Abfrage des Bereiches über eine InputBox. Da PowerPoint sich über "WindowState" nicht vernünftig ausblenden lässt, habe ich auf API zurück gegriffen.

Excel PowerPoint...[ZIP, 55 KB]

Code:
Option Explicit
Private Declare Function GetWindowText Lib "user32" _
Alias "GetWindowTextA" (ByVal hwnd As Long, _
ByVal lpString As String, ByVal cch As Long) As Long
Private Declare Function FindWindow Lib "user32" _
Alias "FindWindowA" (ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
Private Declare Function ShowWindow Lib "user32" (ByVal _
hwnd As Long, ByVal nCmdShow As Long) As Long
Private Declare Function GetWindow Lib "user32" _
(ByVal hwnd As Long, ByVal wCmd As Long) As Long
Private Declare Function GetTempPath Lib "kernel32" Alias _
"GetTempPathA" (ByVal strBufferLength As Long, ByVal _
lpBuffer As String) As Long
Private Declare Function GetParent Lib "user32" _
(ByVal hwnd As Long) As Long
Const strPPSave As String = "Test.ppt" ' anpassen!!!
Const GW_HWNDNEXT = 2
Const SW_MINIMIZE = 6
Dim objPPApp As Object
Public Sub PowerPoint_Slide()
Application.ScreenUpdating = False
On Error GoTo Fin
On Error Resume Next
Set objPPApp = GetObject(, "PowerPoint.Application")
Select Case Err.Number
Case 429
Err.Clear
Set objPPApp = CreateObject("PowerPoint.Application")
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:
If Err.Number <> 0 Then
If Err.Number = 13 Then
MsgBox "Inputbox - Rangeauswahl abgebrochen!"
Else
MsgBox "Fehler: " & Err.Number & " " & Err.Description
End If
End If
If Not objPPApp Is Nothing Then objPPApp.Quit
Set objPPApp = Nothing
With Application
.ScreenUpdating = True
.CutCopyMode = False
.ThisWorkbook.Close False
End With
End Sub
Private Sub Do_PowerPoint()
Dim objPPSlide As Object
Dim objPPPraes As Object
Dim strFolder As String
Dim intCount As Integer
Dim objShape As Object
Dim varTMP As Variant
Dim intTMP As Integer
With objPPApp
Set objPPPraes = .Presentations.Add
Call PP_Klein
For intCount = 1 To 2 ' Schleifendurchlauf anpassen!!!
Application.ScreenUpdating = True
Set varTMP = Application.InputBox _
("Range", "Auswahl", , , , , , 8)
Application.ScreenUpdating = False
With ThisWorkbook.Worksheets(varTMP.Parent.Name)
.Range(varTMP.Address).Copy
End With
'Const ppLayoutBlank = 12
Set objPPSlide = objPPPraes.Slides.Add _
(intCount + intTMP, 12)
intTMP = intTMP + 1
'Const ppPasteOLEObject = 10
'Const msoTrue = -1 (Element von Office.MsoTriState)
objPPSlide.Shapes.PasteSpecial 10, , , , , -1
Set objPPSlide = objPPPraes.Slides.Add _
(intCount + intTMP, 12)
intTMP = intTMP + 1
'Const ppPasteEnhancedMetafile = 2
objPPSlide.Shapes.PasteSpecial 2
Set objShape = objPPPraes.Slides.Item(objPPPraes.Slides.Count)
With objShape.Shapes.Item(objShape.Shapes.Count)
.Top = 60
.Left = 60
.Width = 350
.Height = 350
End With
Set objPPSlide = objPPPraes.Slides.Add _
(intCount + intTMP, 12)
With ThisWorkbook.Worksheets(varTMP.Parent.Name)
.Range(varTMP.Address).CopyPicture
End With
objPPSlide.Shapes.Paste
Set objShape = objPPPraes.Slides.Item(objPPPraes.Slides.Count)
With objShape.Shapes.Item(objShape.Shapes.Count)
.Top = 60
.Left = 60
.Width = 350
.Height = 350
End With
Application.ScreenUpdating = True
Application.CutCopyMode = False
Set objShape = Nothing
Set objPPSlide = Nothing
Set varTMP = Nothing
Next intCount
' speichert auf dem Desktop
strFolder = Environ("UserProfile") & "\Desktop\"
If Right(strFolder, 1) <> "\" Then strFolder = strFolder & "\"
' speichert im TEMP-Ordner
'strFolder = PP_Save
objPPPraes.SaveAs strFolder & strPPSave
End With
Set objPPPraes = Nothing
End Sub
Private Sub PP_Klein()
Dim hWindow As Long
hWindow = SearchHndByWndName_Parent("Microsoft PowerPoint")
Call ShowWindow(hWindow, SW_MINIMIZE)
End Sub
Private Function SearchHndByWndName_Parent(strSearch As String) As Long
Dim strTMP As String * 100
Dim nhWnd As Long
nhWnd = FindWindow(vbNullString, vbNullString)
Do While Not nhWnd = 0
If GetParent(nhWnd) = 0 Then
GetWindowText nhWnd, strTMP, 100
If InStr(strTMP, strSearch) > 0 Then
SearchHndByWndName_Parent = nhWnd
Exit Do
End If
End If
nhWnd = GetWindow(nhWnd, GW_HWNDNEXT)
Loop
End Function
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

14.09.2010

Strassenname mit Google Maps!

Wichtig / Important: Neue Version - Google Maps - Strassenname ermitteln...
In einer Tabelle stehen in A1 (folgende) der Firmenname in B1 (folgende) die PLZ und in C1 (folgende) der Ort. Der Strassenname soll ermittelt werden. Hier eine Lösung mit Google Maps. Getestet mit Excel 2003/2010 und Internetexplorer 8.

Google Maps - Strassenname ermitteln... [ZIP, 60 KB]

Option Explicit
Private Enum IE_READYSTATE
    Uninitialised = 0
    Loading = 1
    Loaded = 2
    Interactive = 3
    Complete = 4
End Enum
Sub Test()
    Dim wksSheet As Worksheet
    Dim objResult As Object
    Dim objIEApp As Object
    Dim strFirma As String
    Dim varArr As Variant
    Dim strPLZ As String
    Dim strOrt As String
    On Error GoTo Fin
    Set wksSheet = ThisWorkbook.Worksheets("Tabelle1") ' anpassen!!!
    With wksSheet
        strFirma = .Cells(1, 1).Value
        strPLZ = .Cells(1, 2).Value
        strOrt = .Cells(1, 3).Value
    End With
    Set objIEApp = CreateObject("InternetExplorer.Application")
    With objIEApp
        .Visible = False ' True = sichtbar
        .Navigate2 "http://maps.google.com/maps?q=" & _
            strFirma & " " & strPLZ & " " & strOrt
        Do Until objIEApp.readyState = _
            IE_READYSTATE.Complete: DoEvents: Loop
        Set objResult = .Document.getElementById("adr")
        If Not objResult Is Nothing Then
            varArr = Split(objResult.innerText, ",")
            wksSheet.Cells(1, 4).Value = varArr(0)
        Else
            wksSheet.Cells(1, 4).Value = "Kein Ergebnis!"
        End If
    End With
Fin:
    If Err.Number <> 0 Then MsgBox "Fehler: " & _
        Err.Number & " " & Err.Description
    If Not objIEApp Is Nothing Then objIEApp.Quit
    Set objIEApp = Nothing
    Set wksSheet = Nothing
End Sub

'Code: Alle Adressen

Option Explicit
Private Enum IE_READYSTATE
    Uninitialised = 0
    Loading = 1
    Loaded = 2
    Interactive = 3
    Complete = 4
End Enum
Sub Test_1()
    Dim wksSheet As Worksheet
    Dim objResult As Object
    Dim objIEApp As Object
    Dim strFirma As String
    Dim varArr As Variant
    Dim strPLZ As String
    Dim strOrt As String
    Dim lngRow As Long
    On Error GoTo Fin
    Set objIEApp = CreateObject("InternetExplorer.Application")
    Set wksSheet = ThisWorkbook.Worksheets("Tabelle1") ' anpassen!!!
    With wksSheet
        lngRow = IIf(Len(.Cells(.Rows.Count, 1)), .Rows.Count, _
            .Cells(.Rows.Count, 1).End(xlUp).Row)
    End With
    With objIEApp
        .Visible = False ' True = sichtbar
        For lngRow = 1 To lngRow
            With wksSheet
                strFirma = .Cells(lngRow, 1).Value
                strPLZ = .Cells(lngRow, 2).Value
                strOrt = .Cells(lngRow, 3).Value
            End With
            .Navigate2 "http://maps.google.com/maps?q=" & _
                strFirma & " " & strPLZ & " " & strOrt
            Do Until objIEApp.readyState = _
                IE_READYSTATE.Complete: DoEvents: Loop
            Set objResult = .Document.getElementById("adr")
            With wksSheet
                If Not objResult Is Nothing Then
                    varArr = Split(objResult.innerText, ",")
                    .Cells(lngRow, 4).Value = varArr(0)
                Else
                    .Visible = True
                    .Cells(lngRow, 4).Value = "Kein Ergebnis!"
                End If
            End With
        Next lngRow
    End With
Fin:
    If Err.Number <> 0 Then MsgBox "Fehler: " & _
        Err.Number & " " & Err.Description
    If Not objIEApp Is Nothing Then objIEApp.Quit
    Set objIEApp = Nothing
    Set wksSheet = Nothing
End Sub
Problem! Goggle kann jederzeit - und das wird auch in unregelmässigen Abständen gemacht - Teile der Homepage ändern. Dies beinhaltet z. B. auch den Punkt "getElementById". Dann kracht der Code natürlich. Wenn man das Problem umgehen möchte sollte man sich zwangsläufig mit der Google API auseinandersetzen. Näher Informationen dazu liefert eine Suchmaschine ihrer Wahl. :-)
Nachfolgend mal einen Code, der das erste Ergebnis in einer MsgBox anzeigt. Das muss natürlich dann noch über z. B. "Split" aufgeteilt werden:
Option Explicit
Sub Main()
    Dim objIEDocument As Object
    Dim objResult As Object
    Dim objIEApp As Object
    Dim wksSheet As Worksheet
    Dim strFirma As String
    Dim strPLZ As String
    Dim strOrt As String
    On Error GoTo Fin
    Set wksSheet = ThisWorkbook.Worksheets("Tabelle1") ' anpassen!!!
    With wksSheet
        strFirma = .Cells(1, 1).Value
        strPLZ = .Cells(1, 2).Value
        strOrt = .Cells(1, 3).Value
    End With
    Set objIEApp = CreateObject("InternetExplorer.Application")
    With objIEApp
        .Visible = False ' True
        .Navigate2 "http://maps.google.com/maps?q=" & _
            strFirma & " " & strPLZ & " " & strOrt
        Do: Loop Until .Busy = False
        Do: Loop Until .Busy = False
        Set objIEDocument = .Document
        With .Document
            Do: Loop Until .ReadyState = "complete"
            Set objResult = .getElementById("panel_A_2")
            If Not objResult Is Nothing Then
                MsgBox objResult.InnerText
            End If
        End With
    End With
Fin:
    If Not objIEApp Is Nothing Then objIEApp.Quit
    Set objIEDocument = Nothing
    Set objIEApp = Nothing
    If Err.Number <> 0 Then MsgBox "Fehler: " & _
        Err.Number & " " & Err.Description
End Sub
"getElementById("panel_A_2")" kann natürlich in Kürze wieder anders heissen. :-)

12.09.2010

Internetexplorer - GetObject!

Immer wieder taucht die Frage auf, ob man auf eine laufende Internetexplorerinstanz aufsetzen kann. Man(n) kann das so schreiben "Set objIEApp = GetObject("", "InternetExplorer.Application")" - das bringt keinen Fehler mehr, startet aber bei jedem Aufruf eine neue Instanz - ist also auch keine Lösung. GetObject schaut in der ROT (RunningObjectTable) nach ob sich ein Object dort registriert hat - der IE macht das wohl nicht. Folgender Code bietet eine Alternative:

Option Explicit
'--------------------------------------------------------------------------
' Module    : Modul1
' Procedure : Main
' Author    : Case (Ralf Stolzenburg)
' Date      : 12.09.2010
' Purpose   : Internetexplorer bestehende Instanz - oder neu starten...
'--------------------------------------------------------------------------
Public Sub Test()
    Dim objWindow As Object
    Dim objIEApp As Object
    Dim objShell As Object
    Dim objItem As Object
    On Error GoTo Fin
    Set objShell = CreateObject("Shell.Application")
    Set objWindow = objShell.Windows()
    For Each objItem In objWindow
        If LCase(objItem.FullName Like "*iexplore*") Then
            Set objIEApp = objItem
        End If
    Next objItem
    If objIEApp Is Nothing Then
        Set objIEApp = CreateObject("InternetExplorer.Application")
        objIEApp.Visible = True
    End If
    objIEApp.Navigate2 "http://vbanet.blogspot.com/"
Fin:
    If Err.Number <> 0 Then MsgBox "Fehler: " & _
    Err.Number & " " & Err.Description
    Set objWindow = Nothing
    Set objShell = Nothing
End Sub

Kleines Update (14.05.2017):
Option Explicit
'--------------------------------------------------------------------------
' Module    : Modul1
' Procedure : Main
' Author    : Case (Ralf Stolzenburg)
' Date      : 14.05.2017
' Purpose   : Internetexplorer bestehende Instanz - oder neu starten...
'--------------------------------------------------------------------------
Public Sub Main()
    Dim objWindow As Object
    Dim objIEApp As Object
    Dim objShell As Object
    Dim objItem As Object
    On Error GoTo Fin
    Set objShell = CreateObject("Shell.Application")
    Set objWindow = objShell.Windows()
    For Each objItem In objWindow
        If LCase(objItem.FullName Like "*iexplore*") Then
            Set objIEApp = objWindow
        End If
    Next objItem
    If objIEApp Is Nothing Then
        Set objIEApp = CreateObject("InternetExplorer.Application")
        With objIEApp
            .Visible = True
            .Navigate "http://delisonline.dpd.de/delisonline/index.jsp"
            Do: Loop Until .Busy = False
            Do: Loop Until .Busy = False
            Do: Loop Until .Document.ReadyState = "complete"
            .Document.All.Item("txtLogin").Value = "mein@email.de"
        End With
    Else
        With objIEApp.Item(1).Document.All
            .Item("txtLogin").Value = "mein@email.de"
        End With
    End If
Fin:
    If Err.Number <> 0 Then MsgBox "Fehler: " & _
        Err.Number & " " & Err.Description
    Set objWindow = Nothing
    Set objShell = Nothing
End Sub

Kleines Update (17.05.2017):

Das Grundgerüst kommt von hier: ;-)

ShellWindows object...

Mit der ersten Methode wird ein Objekt erstellt. Die zweite Methode beinhaltet die Explorerfenster des Shellobjektes. Die daraus resultierende Eigenschaft "Count" beinhaltet alle Adressen.

Daraus lese ich z. B. die "LocationURL". Der Code von Anton geht über "Document.Location". Zusätzlich prüft er noch, ob es der Internetexplorer ist, da sonst auch die Explorerfenster durchlaufen werden. Leicht mit F8 und dem Lokal-Fenster zu überprüfen.

Ohne "Exit For" wird das zuletzt geöffnete Tab - mit der entsprechenden Adresse - genommen.

Da in den "Items" die/alle URLs gelistet sind, muss das jeweilige Tab auch nicht aktiv sein.

Option Explicit
' Code von Anton am 16.05.2017 07:42:23 aus dem Herber Forum...
' http://www.herber.de/forum/archiv/1556to1560/t1558216.htm
Sub b()
    Dim objShell As Object
    Dim IEApp As Object, win As Object, IEDocument As Object
    Dim adresse As String
    adresse = "http://www.skylu.de/auswahl.php" 'anpassen
    Set objShell = CreateObject("Shell.Application")
    For Each win In objShell.Windows
        If InStr(1, UCase(win.FullName), "IEXPLORE") > 0 Then
            If win.Document.Location = adresse Then
                Set IEApp = win
                Exit For
            End If
        End If
    Next
    If IEApp Is Nothing Then
        Set IEApp = CreateObject("InternetExplorer.Application")
        IEApp.Visible = True
        IEApp.Navigate adresse
        Do: Loop Until IEApp.Busy = False
        Do: Loop Until IEApp.Busy = False
    End If
    Set IEDocument = IEApp.Document
    Do: Loop Until IEDocument.ReadyState = "complete"
    IEDocument.getElementById("anrede").Value = "Herr"
    IEDocument.getElementById("vorname").Value = "Sebastian"
    IEDocument.getElementById("name").Value = "lupo"
    Set IEDocument = Nothing
    Set IEApp = Nothing
    Set objShell = Nothing
End Sub

Bzw. alle Explorerfenster (Adressen) im Direktfenster im VBA - Editor ausgeben:

Option Explicit
Sub Main()
    Dim IEXPEX As SHDocVw.ShellWindows
    Dim objIE As Object
    On Error GoTo Fin
    Set IEXPEX = New SHDocVw.ShellWindows
    For Each objIE In IEXPEX
        Debug.Print "URL: " & objIE.LocationURL
    Next objIE
Fin:
    Set IEXPEX = Nothing
    Set objIE = Nothing
End Sub

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