Posts

Es werden Posts vom 2010 angezeigt.

Lupe - Label - Klassenprogrammierung!

Mal wieder nachgefragt: Wie kann man eine Art Lupe programmieren, die bei Wechsel der Zelle den Inhalt vergrößert darstellt? Beim verlassen der Zelle wieder Urzustand. Das Ganze jederzeit Ein- bzw. Ausschaltbar. Habe mal einen alten Code ausgegraben:

Lupe - Label - Klassenprogrammierung...[ZIP, 60 KB]

Code in "DieseArbeitsmappe":

Option Explicit
PrivateSub Workbook_Open()
Application.OnKey "{F3}","Application_Ereignis.An"
Application.OnKey "{F4}","Application_Ereignis.Aus"
Call An
EndSub
PrivateSub Workbook_BeforeClose(Cancel AsBoolean)
Application.OnKey "{F3}"
Application.OnKey "{F4}"
Call Aus
EndSub



Code in ein Modul mit Namen "Application_Ereignis":

Option Explicit
Dim AppObject AsNew clsDatei
PublicSub An()
Set AppObject.AppLiCa = Application
EndSub
PublicSub Aus()
Dim objOLEObject As OLEObject
If Workbooks.Count <1ThenExitSub
ForEach objOLEObject In ActiveSheet.OLEObjects
If TypeOf objOLEObject.Object Is M…

Office - Applikationen - gestartet!

Über eine Funktion soll geprüft werden ob eine der Officeapplikationen gestartet ist. Ist die Applikation geöffnet soll sie nicht geschlossen werden, sonst schon. Die "Sichtbarkeit" der Applikation wird über eine optionale Variable gesteuert.

Für PowerPoint muss eventuell auch folgendes beachtet werden:
http://vbanet.blogspot.com/2010/09/excel-powerpoint.html

Option Explicit
Dim blnTMP AsBoolean
PublicSub Test()
Dim objApp AsObject
OnErrorGoTo Fin
Set objApp = OffApp("Word")
'Set objApp = OffApp("Word", False)
'Set objApp = OffApp("Outlook")
'Set objApp = OffApp("Outlook", False)
'Set objApp = OffApp("PowerPoint")
'Set objApp = OffApp("PowerPoint, False")
'Set objApp = OffApp("ACCESS")
'Set objApp = OffApp("ACCESS", False)
IfNot objApp Is NothingThen
MsgBox objApp.Name&" Version: "& objApp.Version
Else
MsgBox"Applikation nicht installiert!"
EndIf
Fin:
IfNo…

Word - Fußzeile - Seiten - Datum - Autor!

Ein neues Worddokument soll erstellt bzw. ein vorhandenes Dokument geöffnet und in die Fußzeile folgendes eingegeben werden: "Seite ? von ?", "Datum" und "Autor" - erstellt und getestet in Excel 2010:

Option Explicit
PublicSub Test()
Dim objFooter AsObject
Dim objWDApp AsObject
Dim objWDDoc AsObject
Dim objRange AsObject
OnErrorGoTo Fin
Set objWDApp = OffApp("Word")
IfNot objWDApp Is NothingThen
'Set objWDDoc = objWDApp.Documents.Open("C:\Temp\Dok1.doc")
Set objWDDoc = objWDApp.Documents.Add
Set objFooter = objWDDoc.Sections(1).Footers(1)
With objFooter.Range
Set objRange =.Characters(Len(objFooter.Range.Text))
objFooter.Range.Text ="Seite "
Set objRange =.Characters(Len(objFooter.Range.Text))
objRange.Fields.Add objRange,-1,"PAGE"
Set objRange =.Characters(Len(objFooter.Range.Text))
objRange.Text =" von "
Set objRange =.Characters(Len(objFooter.Range.Text))
objRange.Fields.…

Liste in Excel - Seiten in Word löschen!

Frage: Wie lösche ich korrespondierende Seiten in einem Worddokument, wenn in einer Excelliste in Spalte Bkein "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 AsObject
PublicSub Test()
OnErrorResumeNext
Set objWD =GetObject(,"Word.Application")
SelectCaseErr.Number
Case429
Err.Clear
Set objWD =CreateObject("Word.Application")
IfErr.Number >0Then
MsgBoxErr.Number &" "&Err.Description
Set objWD =Nothing
ExitSub
EndIf
Case0
CaseElse
MsgBoxErr.Number &" "&Err.Description
Set objWD =Nothing
ExitSub
EndSelect
OnErrorGoTo0
OnErrorGoTo Fin
Call Write_Word
Fin:
Set objWD =Nothing
IfErr.Number <>0ThenMsgBox"Fehler: "&_
Err.Number &" "&Err.Description
EndSub
Priva…

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 AsLong,_
ByVal Operation AsString,ByVal Filename AsString,_
Optional ByVal Parameters AsString,_
Optional ByVal Directory AsString,_
Optional ByVal WindowStyle AsLong_
= vbMinimizedFocus)AsLong
Const strPathFileNmame AsString="C:\Temp\Test123"
' Pfad- und Dateiname anpassen
Const strExt AsString="bmp"
'Const strExt As String = "jpg"
'Const strExt As String = "gif"
PublicSub Pic_Range()
Dim objDiagramm As ChartObject
Dim picGrafik As Picture
Dim rngRange As Range
OnErrorGoTo Fin
S…

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
PrivateSub Workbook_Open()
Application.OnKey "{F5}","Application_Ereignis.An"
Application.OnKey "{F6}","Application_Ereignis.Aus"
Call An
EndSub
PrivateSub Workbook_Deactivate()
Application.OnKey "{F5}"
Application.OnKey "{F6}"
Call Aus
En…