26.12.2010

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
Private Sub Workbook_Open()
Application.OnKey "{F3}", "Application_Ereignis.An"
Application.OnKey "{F4}", "Application_Ereignis.Aus"
Call An
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Application.OnKey "{F3}"
Application.OnKey "{F4}"
Call Aus
End Sub



Code in ein Modul mit Namen "Application_Ereignis":

Option Explicit
Dim AppObject As New clsDatei
Public Sub An()
Set AppObject.AppLiCa = Application
End Sub
Public Sub Aus()
Dim objOLEObject As OLEObject
If Workbooks.Count < 1 Then Exit Sub
For Each objOLEObject In ActiveSheet.OLEObjects
If TypeOf objOLEObject.Object Is MSForms.Label Then
If objOLEObject.Name = "Lupe" Then objOLEObject.Delete
Exit For
End If
Next
Dim oS As Shape
Set AppObject.AppLiCa = Nothing
End Sub



Code 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)
Dim objOLEObject As OLEObject
Dim intBerechnen As Integer
Dim objLabel As Object
If Target.Count > 2 Then Exit Sub
With Application
intBerechnen = .Calculation
.Calculation = -4135
End With
If Target.Value <> "" Then
For Each objOLEObject In Sh.OLEObjects
If TypeOf objOLEObject.Object Is MSForms.Label Then
If objOLEObject.Name = "Lupe" Then objOLEObject.Delete
Exit For
End If
Next
Set objLabel = Sh.OLEObjects.Add(ClassType:="Forms.Label.1", _
Left:=Target.Left, Top:=Target.Top, _
Width:=Target.Width * 2, Height:=Target.Height * 2)
objLabel.Name = "Lupe"
With objLabel.Object
.Caption = Target.Value
.Font.Size = 20
.TextAlign = 2
.ForeColor = Target.Font.Color
.BackColor = Target.Interior.Color
End With
Else
For Each objOLEObject In Sh.OLEObjects
If TypeOf objOLEObject.Object Is MSForms.Label Then
If objOLEObject.Name = "Lupe" Then objOLEObject.Delete
Exit For
End If
Next
End If
Set objLabel = Nothing
Application.Calculation = intBerechnen
End Sub

20.12.2010

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 As Boolean
Public Sub Test()
Dim objApp As Object
On Error GoTo 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)
If Not objApp Is Nothing Then
MsgBox objApp.Name & " Version: " & objApp.Version
Else
MsgBox "Applikation nicht installiert!"
End If
Fin:
If Not objApp Is Nothing Then
If blnTMP = True Then
objApp.Quit
blnTMP = False
End If
End If
Set objApp = Nothing
If Err.Number <> 0 Then MsgBox "Fehler: " & _
Err.Number & " " & Err.Description
End Sub
Private Function OffApp(ByVal strApp As String, _
Optional blnVisible As Boolean = True) As Object
Dim objApp As Object
On Error Resume Next
Set objApp = GetObject(, strApp & ".Application")
Select Case Err.Number
Case 429
Err.Clear
Set objApp = CreateObject(strApp & ".Application")
blnTMP = True
If blnVisible = True Then
On Error Resume Next
objApp.Visible = True
Err.Clear
End If
End Select
On Error GoTo 0
Set OffApp = objApp
Set objApp = Nothing
End Function

14.12.2010

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
Public Sub Test()
Dim objFooter As Object
Dim objWDApp As Object
Dim objWDDoc As Object
Dim objRange As Object
On Error GoTo Fin
Set objWDApp = OffApp("Word")
If Not objWDApp Is Nothing Then
'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.Add objRange, -1, "NUMPAGES"
Set objRange = .Characters(Len(objFooter.Range.Text))
objRange.Text = vbTab
Set objRange = .Characters(Len(objFooter.Range.Text))
objRange.InsertDateTime DateTimeFormat:="dd.MM.yyyy"
Set objRange = .Characters(Len(objFooter.Range.Text))
objRange.Text = vbTab
Set objRange = .Characters(Len(objFooter.Range.Text))
objRange.Fields.Add objRange, -1, "AUTHOR"
End With
End If
Fin:
Set objRange = Nothing
Set objFooter = Nothing
Set objWDDoc = Nothing
Set objWDApp = Nothing
If Err.Number <> 0 Then MsgBox "Fehler: " & _
Err.Number & " " & Err.Description
End Sub
Private Function OffApp(ByVal strApp As String) As Object
Dim objApp As Object
On Error Resume Next
Set objApp = GetObject(, strApp & ".Application")
Select Case Err.Number
Case 429
Err.Clear
Set objApp = CreateObject(strApp & ".Application")
objApp.Visible = True
If Err.Number > 0 Then
MsgBox Err.Number & " " & Err.Description
Set objApp = Nothing
End If
Case 0
Case Else
MsgBox Err.Number & " " & Err.Description
Set objApp = Nothing
End Select
On Error GoTo 0
Set OffApp = objApp
Set objApp = Nothing
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 ...