Formula - Comment!

You have formulas, which were provided with the formula editor? You would have these formulas gladly in the comment of a freely selectable cell (InputBox)? Or you would like a picture in the comment? Try the following. The files at the end of the article are Excelfiles of the version 2003 and 2007. The following code belonged in a "Module."


Du hast Formeln mit dem Formeleditor erstellt? Du möchtest diese Formeln in einer frei wählbaren Zelle (InputBox) in den Kommentar kopieren? Oder Du möchtest Bilder im Kommentar darstellen? Probiere den folgenden Code. Die Dateien am Ende des Artikels sind Exceldateien der Version 2003 und 2007. Der folgede Code gehört in ein "Modul."


Option Explicit
Dim strPath As String
Dim PicHeight As Long
Dim PicWidth As Long
Public Sub Ex_Pic()
Dim MyPicture As String
Dim MyChart As String
Dim MyObject As Shape
Dim strTMP As String
On Error GoTo Fin
strPath = Environ$("TEMP") & "\"
For Each MyObject In Sheet1.Shapes
Application.ScreenUpdating = True
If MyObject.DrawingObject.progID = "Equation.3" Then
MyPicture = MyObject.Name
With MyObject
PicHeight = .Height
PicWidth = .Width
.Height = .Height / 2
.Width = .Width / 2
End With
DoEvents
Application.ScreenUpdating = False
Charts.Add
ActiveChart.Location Where:=xlLocationAsObject, Name:="Sheet1"
Selection.Border.LineStyle = 0
MyChart = Selection.Name & " " & Split(ActiveChart.Name, " ")(2)
With Sheet1
With .Shapes(MyChart)
.Width = PicWidth
.Height = PicHeight
End With
With MyObject
.Height = PicHeight
.Width = PicWidth
End With
.Shapes(MyPicture).Copy
With ActiveChart
.ChartArea.Select
.Paste
End With
.ChartObjects(1).Chart.Export Filename:=strPath & _
"TMP.jpg", FilterName:="jpg"
.Shapes(MyChart).Cut
End With
strTMP = "$" & fncColumn(MyObject.TopLeftCell.Column + 3) & _
"$" & MyObject.TopLeftCell.Row
Call Pic_Comment(strTMP)
End If
Next MyObject
Fin:
Application.ScreenUpdating = True
If Err.Number <> 0 And Not Err.Number = 438 Then _
MsgBox "Keine Formel oder Zelle ausgewählt!"
End Sub
Private Sub Pic_Comment(strAddress As String)
Dim varTMP As Variant
Dim myCom As Object
Application.ScreenUpdating = True
Set varTMP = Application.InputBox("Auswahl", _
"Zelle", strAddress, , , , , 8)
Application.ScreenUpdating = False
With Sheet1
If Not .Cells(varTMP.Row, varTMP.Column).Comment Is Nothing Then _
.Cells(varTMP.Row, varTMP.Column).Comment.Delete
.Cells(varTMP.Row, varTMP.Column).AddComment
Set myCom = .Cells(varTMP.Row, varTMP.Column).Comment.Shape
With myCom
.Fill.UserPicture strPath & "TMP.jpg"
.Width = PicWidth
.Height = PicHeight
End With
End With
End Sub
Private Function fncColumn(lngTMP As Long) As String
fncColumn = Replace(Cells(1, lngTMP).Address(0, 0), "1", "")
End Function

The following code belonged In another Module:

Option Explicit
Dim strPath As String
Dim PicHeight As Long
Dim PicWidth As Long
Public Sub Ex_Pic_1()
Dim MyPicture As String
Dim MyChart As String
Dim MyObject As Shape
Dim strTMP As String
On Error GoTo Fin
strPath = Environ$("TEMP") & "\"
For Each MyObject In Sheet2.Shapes
Application.ScreenUpdating = True
If MyObject.Type = msoPicture Then
MyPicture = MyObject.Name
With MyObject
PicHeight = .Height
PicWidth = .Width
.Height = .Height / 2
.Width = .Width / 2
End With
DoEvents
Application.ScreenUpdating = False
Charts.Add
ActiveChart.Location Where:=xlLocationAsObject, Name:="Sheet2"
Selection.Border.LineStyle = 0
MyChart = Selection.Name & " " & Split(ActiveChart.Name, " ")(2)
With Sheet2
With .Shapes(MyChart)
.Width = PicWidth
.Height = PicHeight
End With
With MyObject
.Height = PicHeight
.Width = PicWidth
End With
.Shapes(MyPicture).Copy
With ActiveChart
.ChartArea.Select
.Paste
End With
.ChartObjects(1).Chart.Export Filename:=strPath & _
"TMP.jpg", FilterName:="jpg"
.Shapes(MyChart).Cut
End With
strTMP = "$" & fncColumn(MyObject.TopLeftCell.Column + 3) & _
"$" & MyObject.TopLeftCell.Row
Call Pic_Comment(strTMP)
End If
Next MyObject
Fin:
Application.ScreenUpdating = True
If Err.Number <> 0 And Not Err.Number = 438 Then _
MsgBox "Keine Formel oder Zelle ausgewählt!"
End Sub
Private Sub Pic_Comment(strAddress As String)
Dim varTMP As Variant
Dim myCom As Object
Application.ScreenUpdating = True
Set varTMP = Application.InputBox("Auswahl", _
"Zelle", strAddress, , , , , 8)
Application.ScreenUpdating = False
With Sheet2
If Not .Cells(varTMP.Row, varTMP.Column).Comment Is Nothing Then _
.Cells(varTMP.Row, varTMP.Column).Comment.Delete
.Cells(varTMP.Row, varTMP.Column).AddComment
Set myCom = .Cells(varTMP.Row, varTMP.Column).Comment.Shape
With myCom
.Fill.UserPicture strPath & "TMP.jpg"
.Width = PicWidth
.Height = PicHeight
End With
End With
End Sub
Private Function fncColumn(lngTMP As Long) As String
fncColumn = Replace(Cells(1, lngTMP).Address(0, 0), "1", "")
End Function


Sample 2003

Sample 2007

Kommentare

Beliebte Posts aus diesem Blog

Formeln - auch Array - per VBA eintragen...

Alle Dateien eines Ordners - Optional mit Unterordner

Excel -> Word in Textmarken (Bookmarks)...