23.11.2010

Liste in Excel - Seiten in Word löschen!

Frage: Wie lösche ich korrespondierende Seiten in einem Worddokument, wenn in einer Excelliste in Spalte B kein "X" steht (Exceldatei und Worddokument müssen im selben Ordner sein)? Das abgespeckte Worddokument wird dann unter dem Namen "Test_" plus einer Zufallszahl im gleichen Ordner wie die Exceldatei abgespeichert.

Seiten in Worddatei löschen - Vorgaben aus Excel...[ZIP, 60 KB]

Option Explicit
Dim objWD As Object
Public Sub Test()
On Error Resume Next
Set objWD = GetObject(, "Word.Application")
Select Case Err.Number
Case 429
Err.Clear
Set objWD = CreateObject("Word.Application")
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 Write_Word
Fin:
Set objWD = Nothing
If Err.Number <> 0 Then MsgBox "Fehler: " & _
Err.Number & " " & Err.Description
End Sub
Private Sub Write_Word()
Dim intPage As Integer
Dim rngTMP As Object
With objWD
.Documents.Open _
(ThisWorkbook.Path & "\" & _
"Testdatei_mit_10_Seiten.doc")
' wdGoToPage - Konstante = 1
' wdGoToAbsolute - Konstante = 1
For intPage = Tabelle1.Range _
("A" & Tabelle1.Rows.Count).End(xlUp).Row To 1 Step -1
If Not UCase(Tabelle1.Cells(intPage, 2).Value) = "X" Then
If intPage = Tabelle1.Range _
("A" & Tabelle1.Rows.Count).End(xlUp).Row Then
.Selection.GoTo 1, 1, intPage
Set rngTMP = .Selection.Bookmarks("\Page").Range
rngTMP.Start = rngTMP.Start - 1
rngTMP.Delete
Else
.Selection.GoTo 1, 1, intPage
.Selection.Bookmarks("\Page").Range.Delete
End If
End If
Next intPage
.ActiveDocument.SaveAs (ThisWorkbook.Path & _
"\" & "Test_" & Int(1000 * Rnd) + 1 & ".doc")
.ActiveDocument.Close False
.Quit
End With
End Sub

22.11.2010

Bereich als Grafik speichern!

Frage: Wie speichere ich einen Bereich als Bild / Grafik ab? Folgend mal zwei Beispiele. Realisiert über ein "ChartObject". Im ersten Beispiel wird ein fester Bereich genommen. Im zweiten Beispiel wird der Dateiname, der Pfad und der Bereich jeweils über InputBoxen abgefragt.

Bereich als Bild / Grafik speichern...[ZIP, 80 KB]

Option Explicit
Private Declare Function ShellExecute Lib "shell32.dll" _
Alias "ShellExecuteA" (ByVal hWnd As Long, _
ByVal Operation As String, ByVal Filename As String, _
Optional ByVal Parameters As String, _
Optional ByVal Directory As String, _
Optional ByVal WindowStyle As Long _
= vbMinimizedFocus) As Long
Const strPathFileNmame As String = "C:\Temp\Test123"
' Pfad- und Dateiname anpassen
Const strExt As String = "bmp"
'Const strExt As String = "jpg"
'Const strExt As String = "gif"
Public Sub Pic_Range()
Dim objDiagramm As ChartObject
Dim picGrafik As Picture
Dim rngRange As Range
On Error GoTo Fin
Set rngRange = ActiveSheet.UsedRange
Application.ScreenUpdating = False
rngRange.Copy
Worksheets.Add
Set picGrafik = ActiveSheet.Pictures.Paste
picGrafik.CopyPicture 1, -4147
Set objDiagramm = ActiveSheet.ChartObjects.Add _
(0, 0, picGrafik.Width, picGrafik.Height)
With objDiagramm
.Chart.Paste
.Chart.Export strPathFileNmame & _
"." & strExt, strExt
End With
Application.DisplayAlerts = False
ActiveSheet.Delete
Fin:
Application.ScreenUpdating = True
Application.DisplayAlerts = True
If Err.Number <> 0 Then MsgBox "Fehler: " & _
Err.Number & " " & Err.Description
Set objDiagramm = Nothing
Set picGrafik = Nothing
Set rngRange = Nothing
If Dir(strPathFileNmame & "." & strExt) <> "" Then _
ShellExecute 0, "Open", strPathFileNmame & _
"." & strExt, , , 1
End Sub
Public Sub Pic_Range_1()
Dim objDiagramm As ChartObject
Dim strVerzeichnis As String
Dim picGrafik As Picture
Dim rngRange As Range
Dim strTMP As String
On Error GoTo Fin
strTMP = InputBox("Dateiname!", "Eingabe!", "Bereich")
If Trim(strTMP) = "" Then Exit Sub
If Ordnerwahl(strVerzeichnis) <> "" Then
If Dir(strVerzeichnis & strTMP & "." & strExt) <> "" Then _
Kill (strVerzeichnis & strTMP & "." & strExt)
Set rngRange = Application.InputBox _
("Bereich mit der Maus wählen...", _
" Auswahl!", "A1:J22", , , , , 8)
Application.ScreenUpdating = False
rngRange.Copy
Worksheets.Add
Set picGrafik = ActiveSheet.Pictures.Paste
picGrafik.CopyPicture 1, -4147
Set objDiagramm = ActiveSheet.ChartObjects.Add _
(0, 0, picGrafik.Width, picGrafik.Height)
With objDiagramm
.Chart.Paste
.Chart.Export strVerzeichnis & strTMP & _
"." & strExt, strExt
End With
Application.DisplayAlerts = False
ActiveSheet.Delete
Else
MsgBox "Es wurde kein Ordner ausgewaehlt!"
End If
Fin:
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Set objDiagramm = Nothing
Set picGrafik = Nothing
Set rngRange = Nothing
If Err.Number = 424 Then MsgBox "Rangeauswahl abgebrochen!"
If Err.Number <> 0 And Not Err.Number = 424 Then
MsgBox "Fehler: " & Err.Number & _
" " & Err.Description
Else
If Dir(strVerzeichnis & strTMP & "." & strExt) <> "" Then _
ShellExecute 0, "Open", strVerzeichnis & _
strTMP & "." & strExt, , , 1
End If
End Sub
Public Function Ordnerwahl(strOrdner As String) As String
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = "C:\"
'Oder Pfad in dem die Exceldatei ist
'.InitialFileName = ThisWorkbook.Path & "\"
.Title = "Ordnerauswahl"
.ButtonName = "Auswahl..."
.InitialView = msoFileDialogViewList
If .Show = -1 Then
strOrdner = .SelectedItems(1)
If Right(strOrdner, 1) <> "\" Then _
strOrdner = strOrdner & "\"
Else
strOrdner = ""
End If
End With
Ordnerwahl = strOrdner
End Function

10.11.2010

Addin Applikationsweit nutzen!

Der Code eines Addin soll Applikationsweit zur Verfügung stehen also auch noch, wenn "Datei - Neu..." ausgeführt wird. Hier mal an einem Beispiel in dem abhängig vom Zoom und der Bildschirmauflösung bei erreichen einer bestimmten Zelle diese automatisch nach oben gescrollt wird. Mit den Funktionstasten F5 / F6 kann die Funktion ein- bzw. ausgeschaltet werden. Ist jetzt exemplarisch nur für Auflösung "1280 x 1024" und "1024 x 768". Weitere Auflösungen, Zoom bzw. andere Einschränkungen können natürlich nach belieben angepasst werden. :-)

Klassenmodul, Scrollen mit Zoom und Auflösung... [ZIP, 90 KB]

Code gehört in "DieseArbeitsmappe"

Option Explicit
Private Sub Workbook_Open()
Application.OnKey "{F5}", "Application_Ereignis.An"
Application.OnKey "{F6}", "Application_Ereignis.Aus"
Call An
End Sub
Private Sub Workbook_Deactivate()
Application.OnKey "{F5}"
Application.OnKey "{F6}"
Call Aus
End Sub

Code gehört in ein allgemeines Modul mit Namen "Application_Ereignis"

Option Explicit
Option Private Module
Private Declare Function GetDeviceCaps Lib "GDI32" _
(ByVal hdc As Long, ByVal nIndex As Long) As Long
Private Declare Function GetDC Lib "User32" _
(ByVal hWnd As Long) As Long
Private Declare Function ReleaseDC Lib "User32" _
(ByVal hWnd As Long, ByVal hdc As Long) As Long
Private Declare Sub ShowWindow Lib "User32" _
(ByVal hWnd As Long, ByVal nCmdShow As Long)
Const HORZRES = 8
Const VERTRES = 10
Dim AppObject As New clsDatei
Function GetScreenRes()
Dim lRval As Long
Dim lDC As Long
Dim lHSize As Long
Dim lVSize As Long
lDC = GetDC(0&)
lHSize = GetDeviceCaps(lDC, HORZRES)
lVSize = GetDeviceCaps(lDC, VERTRES)
lRval = ReleaseDC(0, lDC)
GetScreenRes = lHSize & "x" & lVSize
End Function
Public Sub An()
Set AppObject.AppLiCa = Application
End Sub
Public Sub Aus()
Set AppObject.AppLiCa = Nothing
End Sub

Code gehört in ein Klassenmodul mit Namen "clsDatei"

Option Explicit
Public WithEvents AppLiCa As Application
Private Sub AppLiCa_SheetSelectionChange(ByVal Sh As Object, _
ByVal Target As Range)
Select Case GetScreenRes
Case "1280x1024"
Select Case ActiveWindow.Zoom
Case 200
If Target.Row Mod 18 = 0 Then
Application.Goto _
Reference:=Range(Target.Address), _
Scroll:=True
End If
Case 100
If Target.Row Mod 38 = 0 Then
Application.Goto _
Reference:=Range(Target.Address), _
Scroll:=True
End If
Case 70
If Target.Row Mod 55 = 0 Then
Application.Goto _
Reference:=Range(Target.Address), _
Scroll:=True
End If
Case 50
If Target.Row Mod 77 = 0 Then
Application.Goto _
Reference:=Range(Target.Address), _
Scroll:=True
End If
End Select
Case "1024x768"
Select Case ActiveWindow.Zoom
Case 200
If Target.Row Mod 16 = 0 Then
Application.Goto _
Reference:=Range(Target.Address), _
Scroll:=True
End If
Case 100
If Target.Row Mod 33 = 0 Then
Application.Goto _
Reference:=Range(Target.Address), _
Scroll:=True
End If
Case 75
If Target.Row Mod 43 = 0 Then
Application.Goto _
Reference:=Range(Target.Address), _
Scroll:=True
End If
Case 50
If Target.Row Mod 63 = 0 Then
Application.Goto _
Reference:=Range(Target.Address), _
Scroll:=True
End If
End Select
End Select
End Sub

08.11.2010

Bestimmte PDF-Datei schließen!

Wie lässt sich eigentlich eine bestimmte PDF-Datei schließen, wenn mehrere offen sind? Das PDF-Programm pauschal abschießen schließt ja alle offenen Dokumente - ist hier also nicht erwünscht. Nachfolgend zwei Möglichkeiten. Bei der ersten Lösung wird nach der kompletten Caption gesucht und das entsprechende Dokument geschlossen. Bei der zweiten Lösung ist nur der Name des Dokumentes relevant - Quellangaben im Code:

Code:

Option Explicit
' Quelle: http://support.microsoft.com/kb/q176391/
Private Declare Function FindWindow Lib "user32" _
Alias "FindWindowA" (ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
Private Declare Function PostMessage Lib "user32" _
Alias "PostMessageA" (ByVal hwnd As Long, _
ByVal wMsg As Long, ByVal wParam As Long, _
ByVal lParam As Long) As Long
Private Declare Function OpenProcess Lib "kernel32" _
(ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, _
ByVal dwProcessId As Long) As Long
Private Declare Function GetWindowThreadProcessId Lib "user32" _
(ByVal hwnd As Long, lpdwProcessId As Long) As Long
Const WM_CLOSE = &H10
Const SYNCHRONIZE = &H100000
Public Sub Test()
Dim hWindow As Long
Dim hThread As Long
Dim hProcess As Long
Dim lProcessId As Long
Dim lngReturnValue As Long
' Fenstertitel anpassen
hWindow = FindWindow(vbNullString, "1.pdf - Adobe Reader")
hThread = GetWindowThreadProcessId(hWindow, lProcessId)
hProcess = OpenProcess(SYNCHRONIZE, 0&, lProcessId)
lngReturnValue = PostMessage(hWindow, WM_CLOSE, 0&, 0&)
End Sub


Code:

Option Explicit
' Quelle: http://support.microsoft.com/kb/147659/en-us/
Private Declare Function FindWindow Lib "user32" _
Alias "FindWindowA" (ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
Private Declare Function PostMessage Lib "user32" _
Alias "PostMessageA" (ByVal hwnd As Long, _
ByVal wMsg As Long, ByVal wParam As Long, _
ByVal lParam As Long) As Long
Private Declare Function OpenProcess Lib "kernel32" _
(ByVal dwDesiredAccess As Long, _
ByVal bInheritHandle As Long, _
ByVal dwProcessId As Long) As Long
Private Declare Function GetWindowThreadProcessId _
Lib "user32" (ByVal hwnd As Long, lpdwProcessId As Long) As Long
Declare Function GetParent Lib "user32" (ByVal hwnd As Long) As Long
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 GetWindow Lib "user32" (ByVal hwnd As Long, _
ByVal wCmd As Long) As Long
Const GW_HWNDNEXT = 2
Const WM_CLOSE = &H10
Const SYNCHRONIZE = &H100000
Public Sub Test()
Dim hWindow As Long
Dim hProcess As Long
Dim lProcessId As Long
Dim lngReturnValue As Long
' Dateiname anpassen
hWindow = SearchHndByWndName_Parent("1.pdf")
hProcess = OpenProcess(SYNCHRONIZE, 0&, lProcessId)
lngReturnValue = PostMessage(hWindow, WM_CLOSE, 0&, 0&)
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

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