Also, von der Funktion her hat er noch viel mehr als nur fein
programmiert...!
Hier mal der gesamte (Original)Code von Christian:
Option Explicit
' FileOpen Commondialog
Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias _
"GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long
Private Type OPENFILENAME
lStructSize As Long
hwndOwner As Long
hInstance As Long
lpstrFilter As String
lpstrCustomFilter As String
nMaxCustFilter As Long
nFilterIndex As Long
lpstrFile As String
nMaxFile As Long
lpstrFileTitle As String
nMaxFileTitle As Long
lpstrInitialDir As String
lpstrTitle As String
flags As Long
nFileOffset As Integer
nFileExtension As Integer
lpstrDefExt As String
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type
Public Const OFN_ALLOWMULTISELECT As Long = &H200
Public Const OFN_CREATEPROMPT As Long = &H2000
Public Const OFN_ENABLEHOOK As Long = &H20
Public Const OFN_ENABLETEMPLATE As Long = &H40
Public Const OFN_ENABLETEMPLATEHANDLE As Long = &H80
Public Const OFN_EXPLORER As Long = &H80000
Public Const OFN_EXTENSIONDIFFERENT As Long = &H400
Public Const OFN_FILEMUSTEXIST As Long = &H1000
Public Const OFN_HIDEREADONLY As Long = &H4
Public Const OFN_LONGNAMES As Long = &H200000
Public Const OFN_NOCHANGEDIR As Long = &H8
Public Const OFN_NODEREFERENCELINKS As Long = &H100000
Public Const OFN_NOLONGNAMES As Long = &H40000
Public Const OFN_NONETWORKBUTTON As Long = &H20000
Public Const OFN_NOREADONLYRETURN As Long = &H8000&
Public Const OFN_NOTESTFILECREATE As Long = &H10000
Public Const OFN_NOVALIDATE As Long = &H100
Public Const OFN_OVERWRITEPROMPT As Long = &H2
Public Const OFN_PATHMUSTEXIST As Long = &H800
Public Const OFN_READONLY As Long = &H1
Public Const OFN_SHAREAWARE As Long = &H4000
Public Const OFN_SHAREFALLTHROUGH As Long = 2
Public Const OFN_SHAREWARN As Long = 0
Public Const OFN_SHARENOWARN As Long = 1
Public Const OFN_SHOWHELP As Long = &H10
Dim OFName As OPENFILENAME
Function StripTerminator(sInput As String) As String
Dim ZeroPos As Long
ZeroPos = InStr(1, sInput, vbNullChar)
If ZeroPos > 0 Then
StripTerminator = Left$(sInput, ZeroPos - 1)
Else
StripTerminator = sInput
End If
End Function
Function ShowOpen(c_TemplatePfad As String, Optional sTitel As String)
As String
'Set the structure size
OFName.lStructSize = Len(OFName)
'Set the owner window
OFName.hwndOwner = &O0
'Set the filter
OFName.lpstrFilter = "Grafikformate (*.jpg,*.gif;*.png)" & _
vbNullChar & "*.jpg;*.gif;*.png" & vbNullChar
'Create a buffer
OFName.lpstrFile = String(1023, vbNullChar)
'Set the maximum number of chars
OFName.nMaxFile = 255
'Create a buffer
OFName.lpstrFileTitle = String(254, vbNullChar)
'Set the maximum number of chars
OFName.nMaxFileTitle = 255
'Set the initial directory
OFName.lpstrInitialDir = c_TemplatePfad
'Set the dialog title
OFName.lpstrTitle = sTitel
'no extra flags
OFName.flags = OFN_FILEMUSTEXIST Or OFN_LONGNAMES Or _
OFN_ALLOWMULTISELECT
'Show the 'Open File'-dialog
If GetOpenFileName(OFName) Then
ShowOpen = Trim$(OFName.lpstrFile)
Else
ShowOpen = ""
End If
ShowOpen = StripTerminator(ShowOpen)
End Function
Sub test()
Dim strFiles() As String
Dim i As Integer
Dim strMSG As String
Dim oDoc As Document
Dim shp As Shape
'Pfad bitte anpassen!
strFiles() = Split(ShowOpen("C:\NGTest", "Grafiken auswählen"), " ")
If UBound(strFiles()) = -1 Then Exit Sub
Set oDoc = Documents.Add
If LBound(strFiles()) = UBound(strFiles()) Then
Set shp = oDoc.Shapes.AddPicture(strFiles(0), _
True, False, 200, 200, , , Selection.Range)
ShapePosition shp, oDoc
strMSG = strMSG & strFiles(i) & vbCrLf
Else
For i = LBound(strFiles()) + 1 To UBound(strFiles())
strMSG = strMSG & strFiles(i) & vbCrLf
Set shp = oDoc.Shapes.AddPicture(strFiles(0) & strFiles(i), _
True, False, 200, 200, , , Selection.Range)
If i = UBound(strFiles()) Then
ShapePosition shp, oDoc, False
Else
ShapePosition shp, oDoc
End If
Next i
End If
MsgBox strMSG
Application.Options.ShowControlCharacters = True
End Sub
Function ShapePosition(shp As Shape, oDoc As Document, _
Optional bBreak As Boolean = True)
With shp
.WrapFormat.AllowOverlap = True
If .ZOrderPosition > 0 Then shp.ZOrder msoSendBehindText
.WrapFormat.Type = wdWrapNone
.WrapFormat.Side = wdWrapBoth
.RelativeHorizontalPosition = wdRelativeHorizontalPositionPage
.RelativeVerticalPosition = wdRelativeVerticalPositionPage
.Left = (ActiveDocument.PageSetup.PageWidth - .Width) / 2
.Top = (ActiveDocument.PageSetup.PageHeight - .Height) / 2
.Anchor.InsertAfter vbCrLf
End With
Selection.Move wdStory, 1
If bBreak = True Then
Selection.InsertBreak wdPageBreak
End If
Selection.Collapse wdCollapseEnd
Selection.Select
End Function
Hilft das weiter?
Vielen Dank!
Grüße und einen schönen Abend!
Andreas
PS: Möööönsch, habt Ihr aber ein dickes Buch geschrieben...! ;-))
Und auf den ersten Blick scheint das auch gar nicht so schlecht zu
sein...!