Hot News:

Unser Angebot:

  Foren auf CAD.de (alle Foren)
  AutoCAD VBA
  64 Bit Filedialog aus Excel nutzen

Antwort erstellen  Neues Thema erstellen
CAD.de Login | Logout | Profil | Profil bearbeiten | Registrieren | Voreinstellungen | Hilfe | Suchen

Anzeige:

Darstellung des Themas zum Ausdrucken. Bitte dann die Druckfunktion des Browsers verwenden. | Suche nach Beiträgen nächster neuer Beitrag | nächster älterer Beitrag
  
Gut zu wissen: Hilfreiche Tipps und Tricks aus der Praxis prägnant, und auf den Punkt gebracht für Autodesk Produkte
Autor Thema:  64 Bit Filedialog aus Excel nutzen (2200 mal gelesen)
rexxitall
Mitglied
Dipl. -Ing. Bau


Sehen Sie sich das Profil von rexxitall an!   Senden Sie eine Private Message an rexxitall  Schreiben Sie einen Gästebucheintrag für rexxitall

Beiträge: 266
Registriert: 07.06.2013

Various: systems, Operating systems, cad systems, cad versions, programming languages.

erstellt am: 28. Jan. 2016 02:07    Editieren oder löschen Sie diesen Beitrag!  <-- editieren / zitieren -->   Antwort mit Zitat in Fett Antwort mit kursivem Zitat    Unities abgeben: 1 Unity (wenig hilfreich, aber dennoch)2 Unities3 Unities4 Unities5 Unities6 Unities7 Unities8 Unities9 Unities10 Unities

Hi, weil ich gerade "mal eben" nen 64bittigen filedialog brauchte ohne stundenlang das winapi zu bemühen...
Bischen lahm aber besser wie nix ohne API aber dafür muss halt ein passendes Excel installiert sein.
Besser wie nix 

Function getfolder(S() As String) As booelan
getfolder = False
Dim found As Boolean
found = False
Dim oexcel As Excel.Application
Set oexcel = CreateObject("Excel.Application")
Dim PATH As String
    Dim oFileDialog As Object
'in der nächsten zeile kann man den Dialog Typ einstellen
    Set oFileDialog = oexcel.FileDialog(msoFileDialogFolderPicker)
    With oFileDialog
        .Title = "Select folder"
        .ButtonName = "Open"
        .AllowMultiSelect = True
        If .Show = True Then
            Dim vItem As Variant
            For Each vItem In .SelectedItems
            PATH = PATH & vItem & vbLf
                If Len(vItem) > 0 Then found = True
            Next
        End If
    End With
    oexcel.Quit
    PATH = Trim(PATH)
    If found Then
    Dim S() As String
    S = Split(PATH, vbLf)
    getfolder = True
    End If
End Function

------------------
Wer es nicht versucht, hat schon verlorn 
Und bei 3 Typos gibts den vierten gratis !
<<< for sale !

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

rexxitall
Mitglied
Dipl. -Ing. Bau


Sehen Sie sich das Profil von rexxitall an!   Senden Sie eine Private Message an rexxitall  Schreiben Sie einen Gästebucheintrag für rexxitall

Beiträge: 266
Registriert: 07.06.2013

Various: systems, Operating systems, cad systems, cad versions, programming languages.

erstellt am: 03. Aug. 2016 13:10    Editieren oder löschen Sie diesen Beitrag!  <-- editieren / zitieren -->   Antwort mit Zitat in Fett Antwort mit kursivem Zitat    Unities abgeben: 1 Unity (wenig hilfreich, aber dennoch)2 Unities3 Unities4 Unities5 Unities6 Unities7 Unities8 Unities9 Unities10 Unities

Und das ganze mit Api - nicht auf meinem Mist gewachsen, deswegen tuts 

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

Sub testgetfiled()
getFiled "c:\", "*.*", "TitleDirectory Path and/or File name"
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

------------------
Wer es nicht versucht, hat schon verlorn 
Und bei 3 Typos gibts den vierten gratis !
<<< for sale !

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

Anzeige.:

Anzeige: (Infos zum Werbeplatz >>)

Darstellung des Themas zum Ausdrucken. Bitte dann die Druckfunktion des Browsers verwenden. | Suche nach Beiträgen

nächster neuerer Beitrag | nächster älterer Beitrag
Antwort erstellen


Diesen Beitrag mit Lesezeichen versehen ... | Nach anderen Beiträgen suchen | CAD.de-Newsletter

Administrative Optionen: Beitrag schliessen | Archivieren/Bewegen | Beitrag melden!

Fragen und Anregungen: Kritik-Forum | Neues aus der Community: Community-Forum

(c)2023 CAD.de | Impressum | Datenschutz