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
|