Obrázek v komentáři-úprava kódu Vyřešeno

Programy pro práci v kanceláři (Word, Excel, Access…=>Office)

Moderátor: Mods_senior

luko02420
Level 2
Level 2
Příspěvky: 203
Registrován: únor 12
Pohlaví: Nespecifikováno
Stav:
Offline

Obrázek v komentáři-úprava kódu

Příspěvekod luko02420 » 12 dub 2018 10:33

Dobrý den, potřeboval bych, upravit kód na vkládaní obrázku do komentáře.
Současný kód co mám funguje tak, že zapisuji po jedné buňce, potřeboval bych ho předělat na hromadné vložení. Pokud to jde.
Děkuji všem za pomoc.

Kód: Vybrat vše

Option Explicit


Private Sub Worksheet_Change(ByVal Target As Range)
  Dim Cmnt As Excel.Comment, DiskPath As String, Extsn As String
 
  '  je zmena v pozadovane oblasti bunek
  If Intersect(Target, Me.Range("Q2:Q1000")) Is Nothing Then Exit Sub
  ' redukce na jednu bunku (napr. pri mazani vice bunek)
  Set Target = Target.Resize(1, 1)
  ' disk a cesta, rozsireni
  DiskPath = "Z:\\"
  Extsn = ".jpg"
  With Target.Offset(0, -12) 'kde 2 znamena ze se komentar vlozi o dve bunky do prava.
    .ClearComments
    ' bunka je prazdna
    If Target.Value = vbNullString Then Exit Sub
    Set Cmnt = .AddComment
    'vlozi obrazek podle nazvu v bunce
    'a formatuje komentar
    With Cmnt
      On Error Resume Next
      .Shape.Fill.UserPicture DiskPath & .Parent.Offset(0, 12).Value & Extsn
      ' osetreni chyby pri odkazu na obrazek
      If Err.Number <> 0 Then
        '*vyber si moznost odstranenim a pridanim apostrofu k prislusnemu radku, zde prvni moznost*
        ' bud bez vlozeni prazdneho komentare
         'Target.ClearComments: GoTo ErrHandler
        ' nebo vlozeny komentar se sdelenim
        .Text Text:="Obrazek nebyl nalezen"
        '**********************************
      End If
      On Error GoTo 0
      ' nastavit rozmery komentare
      .Shape.Height = 450 ' vyska
      .Shape.Width = 650 ' sirka
      ' zobrazeni komentare pouze pri najeti kurzoru na bunku = False nebo trvale = True
      .Visible = False  ' True
    End With
  End With
ErrHandler:
  Set Cmnt = Nothing
End Sub

Reklama
Uživatelský avatar
elninoslov
Level 2.5
Level 2.5
Příspěvky: 366
Registrován: červen 13
Pohlaví: Muž
Stav:
Offline

Re: Obrázek v komentáři-úprava kódu

Příspěvekod elninoslov » 13 dub 2018 10:01

Napr. takto.

Kód: Vybrat vše

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim Cmnt As Excel.Comment, DiskPath As String, Extsn As String, Zmena As Range, ARE As Range, Bunka As Range, H(), Pocet As Long
 
  '  je zmena v pozadovane oblasti bunek
  Set Zmena = Intersect(Target, Range("Q2:Q1000"))
  If Zmena Is Nothing Then Exit Sub
  ' disk a cesta, pripona
  DiskPath = "Z:\\"
  Extsn = ".jpg"
 
  Application.ScreenUpdating = False
  ' Smazat pripadne stare komentare
  Zmena.Offset(, -12).ClearComments
 
  ' projit vsechny skupiny oblasti
  For Each ARE In Zmena
    With ARE
      Pocet = .Cells.Count
      ReDim H(1 To Pocet, 1 To 1)
      ' nacist data zmeny pro celou skupinu
      If Pocet = 1 Then H(1, 1) = .Value2 Else H = .Value2: Pocet = 1
     
      ' projdi vsechny bunky v cilove oblasti pro komentare
      For Each Bunka In .Offset(, -12).Cells 'kde -12 znamena ze se komentar vlozi o 12 bunek do leva.
        ' vlozi komentar kdyz neni datova bunka prazdna
        If Not IsEmpty(H(Pocet, 1)) Then
          'vlozi obrazek podle nazvu v bunce
          'a formatuje komentar
          With Bunka.AddComment
            On Error Resume Next
            .Shape.Fill.UserPicture DiskPath & H(Pocet, 1) & Extsn
            ' osetreni chyby pri odkazu na obrazek
            If Err.Number <> 0 Then .Text Text:="Obrazek nebyl nalezen"
            On Error GoTo 0
            ' nastavit rozmery komentare
            .Shape.Height = 450 ' vyska
            .Shape.Width = 650 ' sirka
            ' zobrazeni komentare pouze pri najeti kurzoru na bunku = False nebo trvale = True
            .Visible = False  ' True
          End With
        End If
       
        Pocet = Pocet + 1
      Next Bunka
     
    End With
  Next ARE
 
  Application.ScreenUpdating = True
  Set Cmnt = Nothing: Set Bunka = Nothing: Set ARE = Nothing: Set Zmena = Nothing
End Sub
Přílohy
Hromadné pridanie obrázkov do komentárov.zip
(1.44 MiB) Staženo 14 x

luko02420
Level 2
Level 2
Příspěvky: 203
Registrován: únor 12
Pohlaví: Nespecifikováno
Stav:
Offline

Re: Obrázek v komentáři-úprava kódu  Vyřešeno

Příspěvekod luko02420 » 13 dub 2018 18:46

elninoslov píše:Napr. takto.

Kód: Vybrat vše

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim Cmnt As Excel.Comment, DiskPath As String, Extsn As String, Zmena As Range, ARE As Range, Bunka As Range, H(), Pocet As Long
 
  '  je zmena v pozadovane oblasti bunek
  Set Zmena = Intersect(Target, Range("Q2:Q1000"))
  If Zmena Is Nothing Then Exit Sub
  ' disk a cesta, pripona
  DiskPath = "Z:\\"
  Extsn = ".jpg"
 
  Application.ScreenUpdating = False
  ' Smazat pripadne stare komentare
  Zmena.Offset(, -12).ClearComments
 
  ' projit vsechny skupiny oblasti
  For Each ARE In Zmena
    With ARE
      Pocet = .Cells.Count
      ReDim H(1 To Pocet, 1 To 1)
      ' nacist data zmeny pro celou skupinu
      If Pocet = 1 Then H(1, 1) = .Value2 Else H = .Value2: Pocet = 1
     
      ' projdi vsechny bunky v cilove oblasti pro komentare
      For Each Bunka In .Offset(, -12).Cells 'kde -12 znamena ze se komentar vlozi o 12 bunek do leva.
        ' vlozi komentar kdyz neni datova bunka prazdna
        If Not IsEmpty(H(Pocet, 1)) Then
          'vlozi obrazek podle nazvu v bunce
          'a formatuje komentar
          With Bunka.AddComment
            On Error Resume Next
            .Shape.Fill.UserPicture DiskPath & H(Pocet, 1) & Extsn
            ' osetreni chyby pri odkazu na obrazek
            If Err.Number <> 0 Then .Text Text:="Obrazek nebyl nalezen"
            On Error GoTo 0
            ' nastavit rozmery komentare
            .Shape.Height = 450 ' vyska
            .Shape.Width = 650 ' sirka
            ' zobrazeni komentare pouze pri najeti kurzoru na bunku = False nebo trvale = True
            .Visible = False  ' True
          End With
        End If
       
        Pocet = Pocet + 1
      Next Bunka
     
    End With
  Next ARE
 
  Application.ScreenUpdating = True
  Set Cmnt = Nothing: Set Bunka = Nothing: Set ARE = Nothing: Set Zmena = Nothing
End Sub


Říkám to už po druhé, tento Pán má zlaté ručičky.
Funguje skvěle, díky moc skvělá práce.


  • Mohlo by vás zajímat
    Odpovědi
    Zobrazení
    Poslední příspěvek

Zpět na “Kancelářské balíky”

Kdo je online

Uživatelé prohlížející si toto fórum: Google [Bot] a 4 hosti