So, jetzt noch die letzte Version mit Namen-...
05.12.2014 02:33:27
Luc:-?
…Anwendungsmöglichkeit für bestimmte Konstanten, Leute;
hier die PgmCodes der Version1.2, die die der Version1.1 an gleicher Stelle ersetzen:
DokumentKlassenModul der Mappe: (Alles ersetzen!)
Option Explicit
Rem Achtung! Ruft nur bei aktivem relevanten Blatt d.BildBehdlgsProzedur auf!
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim relShName As String
On Error Resume Next
If IsError(Me.Names(naRindSh).Name) Then relShName = naRelSh _
Else relShName = Evaluate(Me.Names(naRindSh).Value)
On Error GoTo fx
If Me.ActiveSheet.Name = relShName Then Run pRufK, True
fx: If CBool(Err.Number) Then MsgBox Err.Description, vbCritical, "Speichern: F" & Err.Number
End Sub
Modul1: (Alles ersetzen!)
Option Explicit
Rem Achtung! Werte nfolgd Konstanten 1-11 könn b.Bed geändt wdn:
' 1.Konst: max DplKlicks, 2.Konst: ±-ZoomFaktor pro DplKlick,
' 3.Konst: Zoom-KarenzFaktor, 4.Konst: DplKlick-KarenzFaktor,
' 5.Konst: KurzRufZchn f.ZoomPgm (GBn: [[strg][umsch]]+[bst]),
' 6.Konst: StddName relevBlatt, 7.Konst: xlName indiv Konst6,
' 8.Konst: xlName indiv Konst1, 9.Konst: xlName indiv Konst2,
' 10.Konst: xlName indiv Konst3, 11.Konst: xlName indiv Konst4,
' 12.Konst: StddName Vorbereit/KontrPgm, 13.Konst: dto ZoomPgm.
' Achtung! Indiv xlNamen sind als Namen d.ArbMappe anzulegen!
Public Const modVal As Integer = 4, zoomFakt As Double = 1.5, _
noReakt As Double = 2.5, zoomReakt As Double = 0.8, _
zKey$ = "Z", naRelSh$ = "Tabelle1", naRindSh$ = "relArBl", _
naKindX$ = "DKlickZmax", naZindF$ = "ZoomFaktor", _
naNindReakt$ = "EKlickAbst", naZindReakt$ = "DKlickAbst", _
pRufK$ = "BildKontrolle", pRufZ$ = "BildZoom"
Public mVal As Integer, nReakt As Double, zFakt As Double, zReakt As Double
Rem Überprüft vor jedem Speichern Bilder auf per Const angegebenem
' Blatt auf Eintrag v.KlickZähler u.Zoom-MakroAufruf u.nimmt dsn
' ggf vor; in 1er xlSitzg wdn b.Speichern nur neu hinzugekommene
' Bilder behandelt, bei 1.Speichern bzw DirektAufruf stets alle,
' wobei auch stets d.PgmOptionen (u.a.KurzRuf) neu angelegt wdn.
' Achtung! BildNamen wdn 1×ig durch _ID-Hinzufüg z.Namen geändt.
' Vs1.2 -LSr\CyWorXxl -cD:20141202 -1pub:[1.0]20141203herber -lUpD:20141204t
Sub BildKontrolle(Optional ByVal isSaving As Boolean)
Static sn As Long
Dim sx As Long, ws As Worksheet, sh As Shape
On Error GoTo fx
If Not isSaving Then sn = 0 'Anm: Nur (f.Test) b.DirektAufruf!
Set ws = ActiveSheet: If CBool(sn) Then sx = sn + 1 Else sx = 1
sn = ws.Shapes.Count
If sx = 1 Then
With Application
.MacroOptions pRufZ, "±-Zoom des doppel" & Chr(31) & _
"geklickten (1.DKlick Markierung) bzw markierten Bildes", , , _
True, zKey, , pRufZ & " bereit"
.MacroOptions pRufK, , , , False, , , pRufK & "-Aufruf"
End With
On Error Resume Next
With ActiveWorkbook.Names
If IsError(.Item(naKindX).Name) Then mVal = modVal _
Else mVal = Evaluate(.Item(naKindX).Value)
If IsError(.Item(naZindF).Name) Then zFakt = zoomFakt _
Else zFakt = Evaluate(.Item(naZindF).Value)
If IsError(.Item(naNindReakt).Name) Then nReakt = noReakt _
Else nReakt = Evaluate(.Item(naNindReakt).Value)
If IsError(.Item(naZindReakt).Name) Then zReakt = zoomReakt _
Else zReakt = Evaluate(.Item(naZindReakt).Value)
End With
On Error GoTo fx
End If
Do Until sx > sn
Set sh = ws.Shapes(sx)
If sh.Type = msoPicture Then
If sh.AlternativeText = "" Or Not IsNumeric(sh.AlternativeText) Then
sh.AlternativeText = "0 " & CStr(zReakt / (24 * 60 ^ 2))
If Mid(sh.Name, InStrRev(sh.Name, "_") + 1) CStr(sh.ID) Then _
sh.Name = sh.Name & "_" & CStr(sh.ID)
If sh.OnAction = "" Then sh.OnAction = pRufZ
End If
End If
sx = sx + 1
Loop
fx: If CBool(Err.Number) Then _
MsgBox Err.Description, vbCritical, pRufK & ": F" & Err.Number
Set ws = Nothing: Set sh = Nothing
End Sub
Rem Vgrößert normale Bilder schrittws ab 2.DplKlick m.DplKlick;
' ab 1gestelltem letzten Klick (mVal) wdn sie ebso vkleinert;
' Bild wird b.Vgrößern in VGrd u.b.VKleinern in HGrd gesetzt;
' b.1.DplKlick wird Bild markiert u.kann nach MarkAufheben m.
' nächst DplKlick vgrößert (ab Max vkleinert) bzw m.EinfKlick
' in jedem Zoom-Stadium ganz rückgesetzt wdn; b.markiert Bild
' kann statt DplKlick auch Direkt(Kurz-)Ruf [^Z] vwendet wdn.
' Achtung! B.Bedarf sind nur d.Const-Werte adäquat zu ändern!
' BildEinstellg relationales SeitenVhältn wird vorausgesetzt!
' Vs1.2 -LSr\CyWorXxl -cD:20141202 -1pub:[1.0]20141203herber -lUpD:20141204t
Sub BildZoom()
Dim isNoClick As Boolean, KlickZ As Integer, aktZ As Double, _
naSh As String, avAlTx As Variant, ws As Worksheet, sh As Shape
On Error Resume Next: Set ws = ActiveSheet
If IsError(Application.Caller) Then isNoClick = True
On Error GoTo fx: aktZ = CDbl(TimeValue(Now))
If Not isNoClick Then
naSh = Application.Caller
ElseIf VarType(Selection) = vbObject Then
naSh = Selection.Name: KlickZ = 1
Else: Err.Raise xlErrNA
End If
Set sh = ws.Shapes(naSh): avAlTx = Split(sh.AlternativeText)
KlickZ = CInt(avAlTx(0)): KlickZ = KlickZ - CInt(KlickZ = 0 And isNoClick)
On Abs(isNoClick) GoTo az
If Abs(aktZ - CDbl(avAlTx(1))) nReakt * zReakt / (24 * 60 ^ 2) Then
If CBool((Abs(KlickZ + CInt(Sgn(KlickZ) > 0)))) Then
sh.ZOrder msoSendToBack: KlickZ = Abs(KlickZ) + CInt(KlickZ > 1)
While KlickZ > 0
sh.Height = sh.Height / zFakt: KlickZ = KlickZ - 1
Wend
End If
sh.AlternativeText = "0 " & CStr(aktZ)
Else: sh.AlternativeText = avAlTx(0) & " " & CStr(aktZ)
End If
End If
' MsgBox sh.AlternativeText, vbInformation, pRufZ & ": " & naSh 'Anm: nur f.Test
fx: If CBool(Err.Number) Then
MsgBox IIf(Err.Number = xlErrNA, "Bitte auf ein Bild (doppel-)klicken!", _
Err.Description), vbCritical, pRufZ & ": F" & CStr(Err.Number)
End If
Set sh = Nothing: Set ws = Nothing
End Sub
Neben Hinzufügung der Anwendbarkeit von Namen zur individuellen Anpassung durch den jeweiligen Nutzer, wurde auch der KlickModus geändert. Der ±-Zoom wird jetzt ab dem 1.DoppelKlick stets durch weitere DoppelKlicks ausgelöst, mit einfachem Klick kann beim Zoomen von jedem Stadium aus gleich zur OriginalGröße zurückgekehrt wdn. Dafür ist mitunter ein ZwischenKlick mit nicht DoppelKlick-relevantem Abstand zum VorKlick erforderlich. Da das etwas schwergängig ist, und evtl auch nicht ganz durch individuelle NutzerKonstanten behoben wird, habe ich noch einen direkten ZoomPgmAufruf per Tastatur-KurzRuf (Shortcut) vorgesehen → ^Z ([[strg][umsch]]+[Z]). Der wirkt sich allerdings auf nur jeweils ein selektiertes Bild aus, dessen Selektierung dann erhalten bleibt! Wenn das Bild in diesem Zustand mit EinfachKlick sofort auf die OriginalGröße zurückgesetzt wdn soll, muss erst die Selektierung aufgehoben wdn, was auch für die Selektierung mit 1.DoppelKlick gilt, bevor weiter doppelgeklickt wdn kann.
Viel Spaß! Morrn, Luc :-?