AW: Zugewiesene Tastenkombi funktioniert nur einmal
22.07.2012 11:20:29
Tim
...hier der Code des Tabellenblatts:
Option Explicit
'image settings for Sub Worksheet_SelectionChange
Const MaxWidth As Long = 471 'max. width for images
Const MaxHeight As Long = 500 'max. height for images
Const PosLeft As Long = 553 'image positon from left
Const PosTop As Long = 143 'image position from top
Private objImg As Object
Dim mstrOld As String
Dim RaBereich As Range
Private Declare Function MakeSureDirectoryPathExists Lib "imagehlp.dll" (ByVal lpPath As String) As Long
Private Sub Worksheet_Change(ByVal Target As Range)
' Action: Creates external log file (.txt) for entered search terms for each user, as defined _
in Settings
Dim strDatei As String, strText As String
Dim intFile As Integer, rng As Range
intFile = FreeFile
'log file title and saving location, as defined in Settings
strDatei = Worksheets(2).Range("I24") & Environ("USERNAME") & ".txt" _
If MakeSureDirectoryPathExists(strDatei) 0 Then
If Target.Address(0, 0) = "E2" Then
Open strDatei For Append As #intFile
If LOF(intFile) = 0 Then
'log file headers
strText = "Entered Search Terms:"
Print #intFile, strText
End If
If Range("E2") mstrOld Then
'log file content
Print #intFile, Range("E2"), Range("E6")
End If
Close #intFile
End If
Else
' message to appear if log file cannot be saved
MsgBox "No Search Log saved as saving location not found !", vbExclamation, "Error _
Message"
End If
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
' Action 1: Blocks marking of more than one cell if user is not Administrator, as defined in _
Users list
' Action 2: Sets column F to display Action Details (Repeat Offenders) by mouse click (a)
' sets column K to display Policy Details by mouse click (b)
' Action 3: Checks for matching images, resizes saved images and displays them as follows
' sets column C to display matching images by mouse click
' removes previously displayed image on mouse click elsewhere than column C
If Worksheets(2).Range("I17") "Administrator" Then
If Target.Count > 1 Then Target(1).Select
End If
'settings for Actions 2a and 2b
If Target.Column = 11 Then
If Cells(Target.Row, 20).Value "" Then
UserForm3.TextBox31 = Cells(Target.Row, 20)
UserForm3.TextBox32 = Cells(Target.Row, 21)
UserForm3.Show
End If
End If
'image saving location, as defined in Settings
Dim imagePath As String
imagePath = Worksheets(2).Range("I23").Value
Dim dblWidth As Double, dblHeight As Double
Dim strFile As String
Set RaBereich = Intersect(Range("E2"), Range(Target.Address))
If Not RaBereich Is Nothing Then
mstrOld = Range("E2")
End If
If Not objImg Is Nothing Then objImg.Visible = False
DoEvents
'settings for Action 3
If Target.Column = 3 And Target.Count = 1 Then
If Target "" Then
strFile = imagePath & IIf(Right(imagePath, 1) "\", "\", "") & Target.Value & ". _
jpg"
If InStr(strFile, vbLf) > 0 Then
strFile = Left(strFile, InStr(strFile, vbLf) - 1)
End If
If Dir(strFile) "" Then
On Error Resume Next
If objImg Is Nothing Then Set objImg = Me.OLEObjects("imageContainer")
On Error GoTo 0
If objImg Is Nothing Then createImageContainer
With objImg
.Object.AutoSize = True
.Object.Picture = LoadPicture(strFile)
.Top = ActiveWindow.VisibleRange.Top + PosTop
.Left = PosLeft
If .Height > MaxHeight Or .Width > MaxWidth Then
.Object.AutoSize = False
dblWidth = MaxWidth / .Width
dblHeight = MaxHeight / .Height
If dblWidth
Private Sub createImageContainer()
' Action: Creates image container
' image container settings
Set objImg = Me.OLEObjects.Add(ClassType:="Forms.Image.1", Link:=False, _
DisplayAsIcon:=False, Left:=0, Top:=0, Width:=0, Height:=0)
With objImg
.Visible = False
.Object.PictureSizeMode = 1
.Name = "imageContainer"
End With
End Sub
VG, Tim