VBA wstawianie zdjęcia z folderu

0

Poniższy kod pobiera nazwę z wybranej komórki excel , wyszukuje zdjęcia na serwerze o pobranej nazwie z komórki po czym dodaje rozszerzenie .jpg i wstawia to zdjęcie do komórki obok.

Przykład
w komórce A1 mam ABCDEF
funkcja szuka zdjęcia o nazwie ABCDEF.jpg w katalogu \serwer\KATALOG\ i wstawia zdjęcie do komórki B1

Jak przerobić poniższy kod aby funkcja znalazła to zdjęcie dla niepełnej nazwy w A1. np. "ABC" "ABC*.jpg"

Sub wstaw_foto()
Dim Filename$, place As Range, myPic As Object, kom$
For Each place In Selection
kom = place.Offset(, 1).Address
Filename = "\\serwer\KATALOG\" & place
Set myPic = ActiveSheet.Shapes.AddPicture(Filename & ".jpg", False, True, lngLeft, lngTop, 100, 100)

With myPic
    .Top = Range(kom).Top
    .Left = Range(kom).Left
    .Height = Range(kom).RowHeight
    .Width = Range(kom).Width
End With
Next
Set myPic = Nothing
End Sub
0

Skąd funkcja ma wiedzieć czy ma pobrać plik "ABC1.jpg" czy "ABC2.jpg"?

0

No tego nie będzie wiedzieć. Pytanie czy może pobrać pierwszy znaleziony, czyli ABC1.jpg ?

1

Mozna pobrać pierwszy pasujący plik do maski np. jak poniżej:

Function fSzukajPliku(strWej As String)
    Dim strPlik As String
    strPlik = Dir(strWej)
    
    Do While Len(strPlik) > 0
        fSzukajPliku = strPlik
        Exit Function
    Loop
End Function

Sub wstaw_foto()
    Dim Filename$, place As Range, myPic As Object, kom$
    
        For Each place In Selection
            kom = place.Offset(, 1).Address
            'Filename = "\serwer\KATALOG\" & place
            
            Filename = "\serwer\KATALOG\" & fSzukajPliku("\serwer\KATALOG\ABC*.jpg")
            
            Set myPic = ActiveSheet.Shapes.AddPicture(Filename & ".jpg", False, True, lngLeft, lngTop, 100, 100)
            
            With myPic
            .Top = Range(kom).Top
            .Left = Range(kom).Left
            .Height = Range(kom).RowHeight
            .Width = Range(kom).Width
            End With
        Next
    
    Set myPic = Nothing
End Sub
1

Jeśli piszecie o wyszukiwaniu pliku to działa. Wywołanie poniżej. Dałem propozycję rozwiązania, a już konkretne wdrożenie i testowanie zostawiłem pytającemu.

Function fSzukajPliku(strWej As String)
    Dim strPlik As String
    strPlik = Dir(strWej)
 
    Do While Len(strPlik) > 0
        fSzukajPliku = strPlik
        Exit Function
    Loop
End Function

Sub PierwszyPlik()

    MsgBox fSzukajPliku("c:\windows\tw*.dll")

End Sub

1

Pisałem, że Do..Loop nie zadziała. Bo nie ma prawa działać. Pokaż mi miejsce w tej pętli, gdzie strPlik się zmienia... To że funkcja działa, to wynik wcześniejszej funkcji Dir().
Całość powinna wyglądać mniej więcej tak:

Function fSzukajPliku(strWej As String)
    Dim strPlik As String
    strPlik = Dir(strWej)
   If strPlik<>"." And strPlik<>".." then fSzukajPliku=strPlik 
End Function

' albo krótko:
Function fSzukajPliku(strWej As String)
    fSzukajPliku = Dir(strWej, vbNormal)
End Function

0

Ok, zgadzam się. Funkcję na szybko skróciłem (pierwotnie pokazywała wszystkie pliki spełniające maskę).

0

jakie makro zeby przycisk w exelu otwieral mi nowe okno (msgBox) ze zdjeciem,pdf.

1 użytkowników online, w tym zalogowanych: 0, gości: 1