VBA! Durch Klick gezielt Bilder hochladen aus einem Ordner

[sksasall]

Guten Morgen,

ich habe folgende Idee, kann diese leider nicht umsetzen, da ich schon im Umgang mit Excel und Word überfordert bin.  
Im Rahmen meiner Werkstudententätigkeit im Chemielabor untersuche ich momentan und bis Mitte nächsten Jahres die Korrosivität von Schrauben, d.h. 80 verschiedene Chemikalien auf 160 Schrauben. Anschließend muss ich ein Prüfbericht anlegen, wobei der Text zu 95% gleich ist und ich eine kleine Exceltabelle einfüge mit den Ergebnissen, sowie (und jetzt kommen wir zum Thema) von allen 13 Zyklen jeweils Bilder hochladen tue. 

Ich habe mich gefragt ob ich nicht eine mithilfe eines VBA - Codes einen Butten erstellen kann, der bei Klick darauf gezielt in den vorher benannten Ordner geht, die 13 Bilder rausholt und automatisch die Bilder in das Word Dokument einfügt. 


Dies bzgl. habe ich auch was im Internet gefunden, nur scheint der Code veraltet zu sein und die Befehle nicht mehr aktuell.
Kann jemand mal drüber schauen, mir sagen ob das überhaupt funktionieren wird oder mir sagen ob der Gedanke von mir überhaupt realisierbar ist (falls ja, ob ich es selber überhaupt schreiben könnt)

Für diejenigen die es bis hier hin geschafft haben, vielen Dank fürs Lesen!! (auch wenn ihr nicht helfen konntet) 

Liebe Grüße


Daniel

Code:

Private Sub btnFotos_importiern_Click()

'--------------------< btnFotos_importiern_Click() >--------------------

' makro_Bilder_einfuegen Makro

' füge 6 Bilder in das Word-Dokument ein

'--< Dateidialog >--

Dim objFiledialog As FileDialog

objFiledialog = Application.FileDialog(msoFileDialogFilePicker)

objFiledialog.AllowMultiSelect = True

objFiledialog.ButtonName = "Importieren"

objFiledialog.Filters.Add("Bilder", "*.jpg")

objFiledialog.Title = "doppelklicken Sie auf ein Foto"

'objFiledialog.InitialFileName = "C:\Users\Besitzer\Desktop"

Dim sFilename As String

If objFiledialog.Show() = True Then

sFilename = objFiledialog.SelectedItems(1)

End If

'--< Dateidialog >--

'< Ordner bestimmen >

Dim sFolder As String

sFolder = Left(sFilename, InStrRev(sFilename, "\", , vbTextCompare))

'</ Ordner bestimmen >

'--< Kontrolle >--

'< Ordner ist leer >

If sFolder Like "" Then

Exit Sub

End If

'</ Ordner ist leer >

'< Kontrolle: ist Ordner >

Dim objFilesystem As New FileSystemObject

If Not objFilesystem.FolderExists(sFolder) = True Then

MsgBox("Der eingegebene Pfad ist kein Ordner", vbOKOnly, "Ordner prüfen")


Exit Sub

End If

'</ Kontrolle: ist Ordner >

'--</ Kontrolle >--

'< Ordner laden >

Dim objFolder As Folder

objFolder = objFilesystem.GetFolder(sFolder)

'</ Ordner laden >

'----< sortierbare Tabelle erstellen >----

Dim recOrder As New ADODB.Recordset

recOrder.Fields.Append("FileName", adVarChar, 255, adFldIsNullable)

recOrder.Open()

'----</ sortierbare Tabelle erstellen >----

'-------< @Loop: Eingabe-Files >--------

Dim objFile As File

For Each objFile In objFolder.Files

'----< File >----

If objFile.Type Like "JP*G*" Then

'----< File ist Foto >----

'< Datei eintragen >

recOrder.AddNew()

sFilename = objFile.Path

recOrder("FileName") = sFilename

recOrder.Update()

'</ Datei eintragen >

'----</ File ist Foto >----

End If

'----</ File >----

Next

'-------</ @Loop: Eingabe-Files >--------

'< Tabelle sortieren >

'*nach Dateinamen

recOrder.Sort = "FileName"

'</ Tabelle sortieren >

'< neues Dokument ersetellen >

Dim newDoc As Document

newDoc = Application.Documents.Add

'</ neues Dokument ersetellen >

'-------< @Loop: Sortierte Ausgabe-Files einfuegen >--------

Dim objInlineShape As InlineShape

recOrder.MoveFirst()

Do Until recOrder.EOF

Dim sDateiname As String

sDateiname = recOrder("FileName")

On Error Resume Next

'----< File als Bitmap einfuegen >----

objInlineShape = newDoc.InlineShapes.AddPicture(FileName:=sDateiname, LinkToFile:=False, SaveWithDocument:=True)

objInlineShape.Select()

Selection.Cut()

'< als png einfuegen >

'*ist dann schon kleiner auch fuer den Speicher

On Error Resume Next

Selection.PasteSpecial(Link:=False, DataType:=wdPasteBitmap, Placement:=wdInLine, DisplayAsIcon:=False)

'</ als png einfuegen >

'----</ File als Bitmap einfuegen >----

'< Filename schreiben >

sFilename = Mid(sDateiname, InStrRev(sDateiname, "\", , vbTextCompare) + 1)

Selection.InsertParagraph()

Selection.TypeText(sFilename)

Selection.InsertParagraph()

'</ Filename schreiben >

'< next >

recOrder.MoveNext()

'</ next >

Loop

'-------</ @Loop: Sortierte Ausgabe-Files einfuegen >--------

On Error Resume Next

newDoc.Save()

'--------------------</ btnFotos_importiern_Click() >--------------------

End Sub

[schauan]

Hallöchen,

probier mal den von dort:

https://microsoft-programmierer.de/Details?d=1759&a=8&f=235&l=0&v=d

sieht ähnlich aus, funktioniert aber