Moin,

ursprünglich als Excel-Makro - läuft so aber auch in WORD - *.docm

'******************************************************************************
' Modul: mdl_Bildformat / erstellt : .......  am : 08.03.2015
'------------------------------------------------------------------------------
' Zweck / Inhalt :
' Bilddatei auswerten
'******************************************************************************
'
Option Explicit
'
Sub myMeta()
'
'******************************************************************************
' Name : myMeta / erstellt : 08.03.2015 / 19:01 / Sub
'------------------------------------------------------------------------------
'
' Ordner und Dateiauswahl
' Bildeigenschaften (31 Auflösung, 161 dpi, 162 Pixel, 164 Pixel u. a.)
'
Const m_ModName As String = "mdl_Bildformat"
Const m_PrcName As String = "myMeta"
Dim m_SendKey As String: m_SendKey = Chr(123) & "F8" & Chr(125)
'
'******************************************************************************
'
Const myFmt As String = "Bildformat (*.*), *.*"
Dim oReg As Object
Dim sPath As String, sMsg As String
Dim p1, p2
'
   On Error GoTo myMeta_Error
'
   'Abfragen und ggf. Abbruch durch END
   Select Case Application.Name
      Case "Microsoft Word"
         With Dialogs(wdDialogFileOpen)
            If .Display Then sPath = CurDir() & "\" & .Name
         End With
      Case "Microsoft Excel"
         'sPath = Application.GetOpenFilename(myFmt)
      Case Else
         End
   End Select
   '
   If sPath = "Falsch" Then End
'
   'action
   Set oReg = CreateObject("vbscript.regexp")
   With oReg
      .Global = True
      .IgnoreCase = True
      .MultiLine = False
      .Pattern = "[^0-9]"
   End With
   p1 = GetProperty(sPath, 162)
   p2 = GetProperty(sPath, 164)
   p1 = oReg.Replace(p1, "")
   p2 = oReg.Replace(p2, "")
   p1 = CDbl(p1)
   p2 = CDbl(p2)
'
   'Auswertung
   Select Case p1 / p2
      Case 1
         sMsg = "Quadrat"
      Case Is < 1
         sMsg = "Hochformat"
      Case Else
         sMsg = "Querformat"
   End Select
'
   On Error GoTo 0
'
myMeta_Error:
'------------------------------------------------------------------------------
Select Case Err.Number
  Case Is = 0: 'errorless
   'fehlerfrei, Erfolgsmeldung
   '************************************************************************
      Call MsgBox(sMsg, vbInformation, sPath)
  Case Is = 13: 'custom
      Call MsgBox("keine Information!", vbCritical, sPath)
  Case Else: 'display
      Select Case MsgBox(Format(Err.Number, "   #0") & "/" & Err.Description & _
         Chr(13) & Chr(13) & "   Debugmodus starten ?", _
         vbYesNo Or vbCritical Or vbDefaultButton1, _
         m_ModName & " / " & m_PrcName)
      Case vbYes
         'Application.SendKeys Keys:=m_SendKey & m_SendKey, Wait:=False
         Stop: Resume
      Case vbNo
         ' Abbruch
   End Select
End Select
'------------------------------------------------------------------------------
End Sub
'
'
Function GetProperty(strFile, n)
'
'******************************************************************************
' Name : GetProperty / erstellt : 2007-12-13 / Function
'------------------------------------------------------------------------------
'
' Thx to HansV Windows Secrets
'
'******************************************************************************
'
Dim objShell
Dim objFolder
Dim objFolderItem
Dim i
Dim strPath
Dim strName
Dim intPos
intPos = InStrRev(strFile, "\")
strPath = Left(strFile, intPos)
strName = Mid(strFile, intPos + 1)
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.Namespace(strPath)
Set objFolderItem = objFolder.ParseName(strName)
If Not objFolderItem Is Nothing Then _
   GetProperty = objFolder.GetDetailsOf(objFolderItem, n)
End Function