Option Explicit
Sub myMeta()
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
Select Case Application.Name
Case "Microsoft Word"
With Dialogs(wdDialogFileOpen)
If .Display Then sPath = CurDir() & "\" & .Name
End With
Case "Microsoft Excel"
Case Else
End
End Select
If sPath = "Falsch" Then End
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)
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:
Call MsgBox(sMsg, vbInformation, sPath)
Case Is = 13:
Call MsgBox("keine Information!", vbCritical, sPath)
Case Else:
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
Stop: Resume
Case vbNo
End Select
End Select
End Sub
Function GetProperty(strFile, n)
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