Try this (collected from various sources biut it WORKS !!!!!
Just put in new module and try "public" functions 🙂
Cheers,
Jure
___________________
Option Explicit
'// Module: OpenFile
'//
'// This is code that uses the Windows API to invoke the Open File '// common dialog. It is used by users to choose an Excel file that '// contains organizational data.
'Vba6 True Visual Basic for Applications, version 6.0 compatible.
'Vba6 False not Visual Basic for Applications, version 6.0 compatible.
'Vba7 True Visual Basic for Applications, version 7.0 compatible.
'Vba7 False not Visual Basic for Applications, version 7.0 compatible.
'Win16 False Indicates development environment is not 16-bit compatible.
'Win32 True 32-bit compatible.
'Win64 True 64-bit compatible.
' 64 bit declarations
'http://www.jkp-ads.com/articles/apideclarations.asp
'http://www.jkp-ads.com/articles/apideclarations.asp
#If Win64 Then
Private Declare PtrSafe Function GetOpenFileName Lib "comdlg32.dll" _
Alias "GetOpenFileNameA" (OFN As OPENFILENAME) As Boolean
Private Type OPENFILENAME
lStructSize As Long
hwndOwner As LongPtr
hInstance As LongPtr
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 LongPtr
lpTemplateName As String
End Type
Private Declare PtrSafe Function GetVersionExA Lib "kernel32" _
(lpVersionInformation As OSVERSIONINFO) As Integer
Private Type OSVERSIONINFO
dwOSVersionInfoSize As Long
dwMajorVersion As Long
dwMinorVersion As Long
dwBuildNumber As Long
dwPlatformId As Long
szCSDVersion As String * 128
End Type
Private Declare PtrSafe Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" _
(ByVal hWnd As Long, ByVal lpOperation As String, ByVal lpFile As String, _
ByVal lpParameters As String, ByVal lpDirectory As String, _
ByVal nShowcmd As Long) As Long
Function GetFolderName(Msg As String) As String
' returns the name of the folder selected by the user
Dim bInfo As BROWSEINFO, path As String, r As Long
Dim x As Long, pos As Integer
bInfo.pidlRoot = 0& ' Root folder = Desktop
If IsMissing(Msg) Then
bInfo.lpszTitle = "Izberi mapo"
' the dialog title
Else
bInfo.lpszTitle = Msg ' the dialog title
End If
bInfo.ulFlags = &H1 ' Type of directory to return
x = SHBrowseForFolder(bInfo) ' display the dialog
' Parse the result
path = Space$(512)
r = SHGetPathFromIDList(ByVal x, ByVal path)
If r Then
pos = InStr(path, Chr$(0))
GetFolderName = Left(path, pos - 1)
Else
GetFolderName = ""
End If
End Function
Private Type BROWSEINFO ' used by the function GetFolderName
hOwner As LongPtr
pidlRoot As LongPtr
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As LongPtr
lParam As LongPtr
iImage As Long
End Type
Public Sub RunWord(ByVal PP As String)
Dim Handle As Long
Dim operation As String
Dim lpFile As String
Dim lpParm As String
Dim lpDir As String
Dim nShowcmd As Long
Handle = ThisDrawing.HWND32 'Handle calling application
operation = "open" 'Operation performed
lpFile = Mid(PP, 4) 'Name and path of the file to be opened less drive letter
lpParm = "" 'Set to null string in VB
lpDir = Left(PP, 3) '3 character drive ("C:\")
nShowcmd = 1 'Show application window (Hidden, Max, etc.)
ShellExecute Handle, operation, lpFile, lpParm, lpDir, nShowcmd
End Sub
#ElseIf Win32 Then ' !=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=
Private Declare Function GetOpenFileName Lib "comdlg32.dll" _
Alias "GetOpenFileNameA" (OFN As OPENFILENAME) As Boolean
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
Private Declare Function GetVersionExA Lib "kernel32" _
(lpVersionInformation As OSVERSIONINFO) As Integer
Private Type OSVERSIONINFO
dwOSVersionInfoSize As Long
dwMajorVersion As Long
dwMinorVersion As Long
dwBuildNumber As Long
dwPlatformId As Long
szCSDVersion As String * 128
End Type
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" _
(ByVal hWnd As Long, ByVal lpOperation As String, ByVal lpFile As String, _
ByVal lpParameters As String, ByVal lpDirectory As String, _
ByVal nShowcmd As Long) As Long
Function GetFolderName(Msg As String) As String
' returns the name of the folder selected by the user
Dim bInfo As BROWSEINFO, path As String, r As Long
Dim x As Long, pos As Integer
bInfo.pidlRoot = 0& ' Root folder = Desktop
If IsMissing(Msg) Then
bInfo.lpszTitle = "Izberi mapo"
' the dialog title
Else
bInfo.lpszTitle = Msg ' the dialog title
End If
bInfo.ulFlags = &H1 ' Type of directory to return
x = SHBrowseForFolder(bInfo) ' display the dialog
' Parse the result
path = Space$(512)
r = SHGetPathFromIDList(ByVal x, ByVal path)
If r Then
pos = InStr(path, Chr$(0))
GetFolderName = Left(path, pos - 1)
Else
GetFolderName = ""
End If
End Function
Private Type BROWSEINFO ' used by the function GetFolderName
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type
Public Sub RunWord(ByVal PP As String)
Dim Handle As Long
Dim operation As String
Dim lpFile As String
Dim lpParm As String
Dim lpDir As String
Dim nShowcmd As Long
Handle = ThisDrawing.hWnd 'Handle calling application
operation = "open" 'Operation performed
lpFile = Mid(PP, 4) 'Name and path of the file to be opened less drive letter
lpParm = "" 'Set to null string in VB
lpDir = Left(PP, 3) '3 character drive ("C:\")
nShowcmd = 1 'Show application window (Hidden, Max, etc.)
ShellExecute Handle, operation, lpFile, lpParm, lpDir, nShowcmd
End Sub
#End If
Private Sub FindFile(ByRef Filepath As String, sFilter As String, ByRef cancelled As Boolean)
Dim OpenFile As OPENFILENAME
Dim lReturn As Long
'Dim sFilter As String
' On Error GoTo errTrap
OpenFile.lStructSize = LenB(OpenFile)
'// Sample filter:
'// "Text Files (*.txt)" & Chr$(0) & "*.sky" & Chr$(0) & "All Files (*.*)" & Chr$(0) & "*.*"
'sFilter = "Excel Files (*.xl*)" & Chr(0) & "*.xl*"
OpenFile.lpstrFilter = sFilter
OpenFile.nFilterIndex = 1
OpenFile.lpstrFile = VBA.String(257, 0)
OpenFile.nMaxFile = Len(OpenFile.lpstrFile) - 1
OpenFile.lpstrFileTitle = OpenFile.lpstrFile
OpenFile.nMaxFileTitle = OpenFile.nMaxFile
'OpenFile.lpstrInitialDir = Application.ActiveDocument.path
If Filepath > "" Then
OpenFile.lpstrInitialDir = Filepath
Else
OpenFile.lpstrInitialDir = "C:\"
End If
OpenFile.lpstrTitle = "Find " + sFilter
OpenFile.flags = 0
lReturn = GetOpenFileName(OpenFile)
If lReturn = 0 Then
cancelled = True
Filepath = vbNullString
Else
cancelled = False
Filepath = VBA.Trim(OpenFile.lpstrFile)
Filepath = Replace(Filepath, VBA.Chr(0), vbNullString)
End If
Exit Sub
errTrap:
Exit Sub
Resume
End Sub
Public Function getFiled(sPath As String, sExt As String, sDescr As String) As String
'(getfiled "Title" "Directory Path and/or File name" "File Extension" Flag)
Dim bCancelled As Boolean
Dim fType As String
fType = sDescr + " (" + sExt + ")" + VBA.Chr(0) + sExt
FindFile sPath, fType, bCancelled
If bCancelled Then getFiled = "" Else getFiled = sPath
End Function
'==================================== TESTING ROUTINES ==========================================================
'Private Sub Filepath_Click()
' Label1.Caption = getFiled("D:\", "tif", "Raster")
'End Sub
Public Function getVersion() As String
Dim osinfo As OSVERSIONINFO
Dim retvalue As Integer
Dim Wver As String
Dim Vname As String
osinfo.dwOSVersionInfoSize = 148
osinfo.szCSDVersion = VBA.Space$(128)
retvalue = GetVersionExA(osinfo)
Wver = osinfo.dwMajorVersion & "." & osinfo.dwMinorVersion
Select Case Wver
Case "6.2": Vname = "Windows 8"
'Case "6.2": Vname = "Windows Server 2012"
Case "6.1": Vname = "Windows 7"
'Case "6.1": Vname = "Windows Server 2008 R2"
Case "6.0": Vname = "Windows Server 2008"
'Case "6.0": Vname = "Windows Vista"
'Case "5.2": Vname = "Windows Server 2003 R2"
'Case "5.2": Vname = "Windows Home Server"
Case "5.2": Vname = "Windows Server 2003"
'Case "5.2": Vname = "Windows XP Professional x64 Edition"
Case "5.1": Vname = "Windows XP"
Case "5.0": Vname = "Windows 2000"
End Select
'getVersion = Wver + "_" + Vname
getVersion = Vname
End Function
Private Sub TestEnvionment()
Dim a$
#If Win64 Then
a$ = a$ + "Win64=True" + vbCrLf
#Else
a$ = a$ + "Win64=False" + vbCrLf
#End If
#If Win32 Then
a$ = a$ + "Win32=True" + vbCrLf
#Else
a$ = a$ + "Win32=False" + vbCrLf
#End If
#If Win16 Then
a$ = a$ + "Win16=True" + vbCrLf
#Else
a$ = a$ + "Win16=False" + vbCrLf
#End If
#If VBA6 Then
a$ = a$ + "Vba6=True" + vbCrLf
#Else
a$ = a$ + "Vba6=False" + vbCrLf
#End If
#If VBA7 Then
a$ = a$ + "Vba7=True" + vbCrLf
#Else
a$ = a$ + "Vba7=False" + vbCrLf
#End If
MsgBox a$
End Sub
