Private Sub Worksheet

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

AW: Private Sub Worksheet

06.02.2007 14:12:28

Peter

Gar nicht ...

06.02.2007 14:14:31

mpb

AW: Gar nicht ...

06.02.2007 15:28:48

Gerhard

AW: Gar nicht ...

06.02.2007 21:25:48

Peter

Hallo
anbei die beiden Prozeduren die ich gerne in einer verknüpfen würde!
1.Prozedur:


Private Sub Worksheet_SelectionChange(ByVal Target As Range)
On Error GoTo Beenden:
If CommandBars("Zeilenmarkierer").Controls(3).Caption = "Ein" Then
Application.SendKeys "+{ }"
End If
Beenden:
End Sub

2.Prozedur


Private Sub Worksheet_SelectionChange(ByVal Target As Range)
' Const strPath As String = "D:\0_OCT_Bilder\"
Const strPath As String = "I:\de\muc\optik\rdo\rdo-intern\LAS intern\EDS\Projekte\2006\08_06_AR_OCT-Zoom\Schriftverkehr\Zeichnungen\"
Dim rng As Range
Dim strFile As String
Dim objPic As Object
On Error Resume Next
Me.Shapes("temp").Delete
On Error GoTo ErrExit
Set rng = Target(1, 1)
If rng.Column = 3 And rng.Row > 3 Then
strFile = strPath & "Bild" & rng.Row - 3 & ".jpg"
'strFile = strPath & rng.Text & rng.Row - 3 & ".jpg"
If Dir(strFile) <> "" Then
Application.ScreenUpdating = False
Set objPic = Me.Pictures.Insert(strFile)
With objPic.ShapeRange
.Name = "temp"
.Left = rng.Left + rng.Width
.Top = rng.Top
.LockAspectRatio = True
.Width = 170
End With
End If
End If
ErrExit:
Application.ScreenUpdating = True
Set objPic = Nothing
Set rng = Nothing
End Sub

Vielen Dank für Eure Hilfe
Gruß
Gerhard

Hallo Gerhard,
ich kann mir Deine Testumgebung nicht nachbauen, deshalb völlig ungetestet:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
' Const strPath As String = "D:\0_OCT_Bilder\"
Const strPath As String = "I:\de\muc\optik\rdo\rdo-intern\LAS intern\EDS\Projekte\2006\08_06_AR_OCT-Zoom\Schriftverkehr\Zeichnungen\"
Dim rng      As Range
Dim strFile  As String
Dim objPic   As Object
   On Error GoTo Beenden:
   If CommandBars("Zeilenmarkierer").Controls(3).Caption = "Ein" Then
      Application.SendKeys "+{ }"
   End If
   On Error Resume Next
   Me.Shapes("temp").Delete
   On Error GoTo ErrExit
   Set rng = Target(1, 1)
   If rng.Column = 3 And rng.Row > 3 Then
      strFile = strPath & "Bild" & rng.Row - 3 & ".jpg"
     'strFile = strPath & rng.Text & rng.Row - 3 & ".jpg"
      If Dir(strFile) <> "" Then
         Application.ScreenUpdating = False
         Set objPic = Me.Pictures.Insert(strFile)
         With objPic.ShapeRange
            .Name = "temp"
            .Left = rng.Left + rng.Width
            .Top = rng.Top
            .LockAspectRatio = True
            .Width = 170
         End With
      End If
   End If
ErrExit:
   Application.ScreenUpdating = True
   Set objPic = Nothing
   Set rng = Nothing
Beenden:
End Sub

Viele Grüße Peter
Eine kurze Nachricht, ob es läuft, wäre nett - danke.

Beliebteste Forumthreads (12 Monate)

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

301 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Private Sub Worksheet

4 Beiträge zum Forumthread Beiträge zu diesem Forumthread

301 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread