Hot News:

Unser Angebot:

  Foren auf CAD.de (alle Foren)
  AutoCAD VBA
  Excel datei öffnen mit einer Dialogbox

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:  Excel datei öffnen mit einer Dialogbox (183 mal gelesen)
michimueller85
Mitglied



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

Beiträge: 24
Registriert: 06.12.2010

erstellt am: 28. Jun. 2022 14:40    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

Hallo zusammen,

kennt jemand den Code damit ich im Autocad 2019(64Bit) eine
Excel Datei mit einer Dialogbox öffnen kann um mir eine Zeile auszulesen.

Mit Excel funktioniert es ganz einfach:

Sub ArbeitsmappeOeffnen()

    Dim strDatei As String

    strDatei = Application.GetOpenFilename()
    Workbooks.Open (strDatei)

End Sub

Jedoch funktioniert dieser Code nicht mit Autocad VBA

Vielen Dank

[Diese Nachricht wurde von michimueller85 am 28. Jun. 2022 editiert.]

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

michimueller85
Mitglied



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

Beiträge: 24
Registriert: 06.12.2010

erstellt am: 29. Jun. 2022 16:36    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

Hallo zusammen, also ich habe nun einen Quellecode passend für VBA7 (64BIT) gefunden:

viel Spaß damit

''===================================================================================================================
'' Following code is copied from Autodesk discussion forum here:
'' http://forums.autodesk.com/t5/inventor-customization/folder-browser-needed-for-vba-7-64-bit/m-p/4365989#M45667
''===================================================================================================================

Option Explicit

#If VBA7 Then

Private Declare PtrSafe Function GetOpenFileName Lib "comdlg32.dll" Alias _
        "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long

Private Declare PtrSafe Function GetSaveFileName Lib "comdlg32.dll" Alias _
        "GetSaveFileNameA" (pOpenfilename As OPENFILENAME) As Long

Private Declare PtrSafe Function SHBrowseForFolder Lib "shell32.dll" Alias _
        "SHBrowseForFolderA" (lpBrowseInfo As BrowseInfo) As Long

Private Declare PtrSafe Function SHGetPathFromIDList Lib "shell32.dll" _
        (ByVal pidList As LongPtr, ByVal lpBuffer As String) As Long


Public Declare PtrSafe Function SendMessageA Lib "user32" _
        (ByVal Hwnd As LongPtr, ByVal wMsg As Long, _
        ByVal wParam As LongPtr, lParam As Any) As LongPtr

Private Declare PtrSafe Sub CoTaskMemFree Lib "ole32.dll" (ByVal hMem As LongPtr)


Private Const BIF_RETURNONLYFSDIRS As Long = 1
Private Const CSIDL_DRIVES As Long = &H11
Private Const WM_USER As Long = &H400
Private Const MAX_PATH As Long = 260            '// message from browser
Private Const BFFM_INITIALIZED As Long = 1
Private Const BFFM_SELCHANGED As Long = 2
Private Const BFFM_VALIDATEFAILEDA As Long = 3  '// lParam:szPath ret:1(cont),0(EndDialog)
Private Const BFFM_VALIDATEFAILEDW As Long = 4  '// lParam:wzPath ret:1(cont),0(EndDialog)
Private Const BFFM_IUNKNOWN As Long = 5        '// provides IUnknown to client. lParam: IUnknown*
'// messages to browser
Private Const BFFM_SETSTATUSTEXTA As Long = WM_USER + 100
Private Const BFFM_ENABLEOK As Long = WM_USER + 101
Private Const BFFM_SETSELECTIONA As Long = WM_USER + 102
Private Const BFFM_SETSELECTIONW As Long = WM_USER + 103
Private Const BFFM_SETSTATUSTEXTW As Long = WM_USER + 104
Private Const BFFM_SETOKTEXT As Long = WM_USER + 105 '// Unicode only
Private Const BFFM_SETEXPANDED As Long = WM_USER + 106 '// Unicode only
   
Public Const OFN_ALLOWMULTISELECT As Long = &H200
Public Const OFN_CREATEPROMPT As Long = &H2000
Public Const OFN_ENABLEHOOK As Long = &H20
Public Const OFN_ENABLETEMPLATE As Long = &H40
Public Const OFN_ENABLETEMPLATEHANDLE As Long = &H80
Public Const OFN_EXPLORER As Long = &H80000
Public Const OFN_EXTENSIONDIFFERENT As Long = &H400
Public Const OFN_FILEMUSTEXIST As Long = &H1000
Public Const OFN_HIDEREADONLY As Long = &H4
Public Const OFN_LONGNAMES As Long = &H200000
Public Const OFN_NOCHANGEDIR As Long = &H8
Public Const OFN_NODEREFERENCELINKS As Long = &H100000
Public Const OFN_NOLONGNAMES As Long = &H40000
Public Const OFN_NONETWORKBUTTON As Long = &H20000
Public Const OFN_NOREADONLYRETURN As Long = &H8000& '*see comments
Public Const OFN_NOTESTFILECREATE As Long = &H10000
Public Const OFN_NOVALIDATE As Long = &H100
Public Const OFN_OVERWRITEPROMPT As Long = &H2
Public Const OFN_PATHMUSTEXIST As Long = &H800
Public Const OFN_READONLY As Long = &H1
Public Const OFN_SHAREAWARE As Long = &H4000
Public Const OFN_SHAREFALLTHROUGH As Long = 2
Public Const OFN_SHAREWARN As Long = 0
Public Const OFN_SHARENOWARN As Long = 1
Public Const OFN_SHOWHELP As Long = &H10
Public Const OFN_ENABLESIZING As Long = &H800000
Public Const OFS_MAXPATHNAME As Long = 260

'OFS_FILE_OPEN_FLAGS:
Public Const OFS_FILE_OPEN_FLAGS = OFN_EXPLORER Or _
            OFN_LONGNAMES Or _
            OFN_CREATEPROMPT Or _
            OFN_NODEREFERENCELINKS
           
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

Public Type BrowseInfo
    hwndOwner As LongPtr
    pIDLRoot As LongPtr
    pszDisplayName As String
    lpszTitle As String
    ulFlags As Long
    lpfnCallback As LongPtr
    lParam As LongPtr
    iImage As Long
End Type

'====== File Browsers for 64 bit VBA 7 ========
Public Function FileBrowseOpen( _
    ByVal sInitFolder As String, _
    ByVal sTitle As String, _
    ByVal sFilter As String, _
    ByVal nFilterIndex As Integer, _
    Optional ByVal multiSelect = False) As String

    Dim OpenFile As OPENFILENAME
    Dim lReturn As Long

    sInitFolder = CorrectPath(sInitFolder)
    OpenFile.lpstrInitialDir = sInitFolder

    ' Swap filter separator for api separator
    sFilter = Replace(sFilter, "|", Chr(0))

    OpenFile.lpstrFilter = sFilter
    OpenFile.nFilterIndex = nFilterIndex
    OpenFile.lpstrTitle = sTitle
   
   
   
    OpenFile.hwndOwner = 0
    OpenFile.lpstrFile = String(257, 0)
    OpenFile.nMaxFile = LenB(OpenFile.lpstrFile) - 1
    OpenFile.lStructSize = LenB(OpenFile)
   
    OpenFile.lpstrFileTitle = OpenFile.lpstrFile
    OpenFile.nMaxFileTitle = OpenFile.nMaxFile
   
    If Not multiSelect Then
        OpenFile.flags = 0
    Else
        OpenFile.flags = OFS_FILE_OPEN_FLAGS + OFN_ALLOWMULTISELECT
    End If
   
    lReturn = GetOpenFileName(OpenFile)

    If lReturn = 0 Then
        FileBrowseOpen = ""
    Else
        If multiSelect Then
            Dim str As String
            str = Trim(Replace(Trim(OpenFile.lpstrFile), vbNullChar, ","))
            Dim ed As String
            ed = Mid(str, Len(str))
            While (ed = ",")
                str = Trim(Left(str, Len(str) - 1))
                ed = Mid(str, Len(str))
            Wend
            FileBrowseOpen = str
        Else
            FileBrowseOpen = Trim(Left(OpenFile.lpstrFile, InStr(1, OpenFile.lpstrFile, vbNullChar) - 1))
        End If
    End If
   
End Function


Public Function GetFiles( _
    ByVal sInitFolder As String, _
    ByVal sTitle As String, _
    ByVal sFilter As String, _
    ByVal nFilterIndex As Integer) As String()
   
    Dim strReturn As String
   
    strReturn = FileBrowseOpen(sInitFolder, sTitle, sFilter, nFilterIndex, True)
    GetFiles = Split(strReturn, ",")
   
End Function

Public Function FileBrowseSave( _
    ByVal sDefaultFilename As String, _
    ByVal sInitFolder As String, _
    ByVal sTitle As String, _
    ByVal sFilter As String, _
    ByVal nFilterIndex As Integer, _
    Optional ByVal overwritePrompt = False) As String
   
    Dim PadCount As Integer
    Dim OpenFile As OPENFILENAME
    Dim lReturn As Long

    sInitFolder = CorrectPath(sInitFolder)
   
    ' Swap filter separator for api separator
    sFilter = Replace(sFilter, "|", Chr(0))
   
    OpenFile.lpstrFilter = sFilter
    OpenFile.nFilterIndex = 1
    OpenFile.hwndOwner = 0

    PadCount = 260 - Len(sDefaultFilename)
    OpenFile.lpstrFile = sDefaultFilename & String(PadCount, Chr(0))
    'OpenFile.lpstrFile = String(257, 0)
    OpenFile.nMaxFile = LenB(OpenFile.lpstrFile) - 1
    OpenFile.lStructSize = LenB(OpenFile)
   
    OpenFile.lpstrFileTitle = OpenFile.lpstrFile
    OpenFile.nMaxFileTitle = OpenFile.nMaxFile
    OpenFile.lpstrInitialDir = sInitFolder
    OpenFile.lpstrTitle = sTitle
    If Not IsMissing(overwritePrompt) And overwritePrompt Then
        OpenFile.flags = OFN_OVERWRITEPROMPT
    Else
        OpenFile.flags = 0
    End If
    lReturn = GetSaveFileName(OpenFile)

    If lReturn = 0 Then
        FileBrowseSave = ""
    Else
        FileBrowseSave = Trim(Left(OpenFile.lpstrFile, InStr(1, OpenFile.lpstrFile, vbNullChar) - 1))
    End If
   
End Function

'====== Folder Browser for 64 bit VBA 7 ========
Public Function FolderBrowse(ByVal sDialogTitle As String, ByVal sInitFolder As String) As String

    Dim ReturnPath As String
    Dim b(MAX_PATH) As Byte
    Dim pItem As Long
    Dim sFullPath As String
    Dim bi As BrowseInfo
    Dim ppidl As Long

    sInitFolder = CorrectPath(sInitFolder)

    ' Note VBA windows and dialogs do not have an hWnd property.
    bi.hwndOwner = 0 'Windows Main Screen handle.

    ' SHGetSpecialFolderLocation bi.hWndOwner, CSIDL_DRIVES, ppidl
    bi.pIDLRoot = 0 'ppidl

    bi.pszDisplayName = VarPtr(b(0))
    bi.lpszTitle = sDialogTitle
    bi.ulFlags = BIF_RETURNONLYFSDIRS
    If FolderExists(sInitFolder) Then bi.lpfnCallback = PtrToFunction(AddressOf BFFCallback)
    bi.lParam = StrPtr(sInitFolder)
    pItem = SHBrowseForFolder(bi)
   
    If pItem Then ' Succeeded
        sFullPath = Space$(MAX_PATH)
        If SHGetPathFromIDList(pItem, sFullPath) Then
            ReturnPath = Left$(sFullPath, InStr(sFullPath, vbNullChar) - 1) ' Strip nulls
        CoTaskMemFree pItem
        End If
    End If

    If ReturnPath <> "" Then
        If Right$(ReturnPath, 1) <> "\" Then
            ReturnPath = ReturnPath & "\"
        End If
    End If

    FolderBrowse = ReturnPath

End Function
' typedef int (CALLBACK* BFFCALLBACK)(HWND hwnd, UINT uMsg, LPARAM lParam, LPARAM lpData);
Private Function BFFCallback( _
    ByVal Hwnd As LongPtr, ByVal uMsg As LongPtr, _
    ByVal lParam As LongPtr, ByVal sData As String) As LongPtr
   
    If uMsg = BFFM_INITIALIZED Then
        SendMessageA Hwnd, BFFM_SETSELECTIONA, True, ByVal sData
    End If
   
End Function

Private Function PtrToFunction(ByVal lFcnPtr As LongPtr) As LongPtr
    PtrToFunction = lFcnPtr
End Function

Private Function CorrectPath(ByVal sPath As String) As String
    If Right$(sPath, 1) = "\" Then
        If Len(sPath) > 3 Then sPath = Left$(sPath, Len(sPath) - 1) ' Strip backslash from non-root
    Else
        If Len(sPath) = 2 Then sPath = sPath & "\" ' Append backslash to root
    End If
    CorrectPath = sPath
End Function

Public Function FolderExists(ByVal sFolderName As String) As Boolean
    Dim att As Long
    On Error Resume Next
    att = GetAttr(sFolderName)
    If Err.Number = 0 Then
    FolderExists = True
    Else
    Err.Clear
    FolderExists = False
    End If
    On Error GoTo 0
End Function

Option Explicit

Public Sub TestOpen()
    Dim fName As String
    fName = FileBrowseSave("Test.dwg", "C:\Temp", "Save Drawing File", "AutoCAD Drawing (*.dwg)|*.dwg", 0, False)
End Sub

Public Sub TestSave()
   
    Dim fName As String
    fName = FileBrowseOpen("Z:\ZB-Projekte", "Open Drawing File", "Excel Datei wählen (*.xlsx)|*.xlsx", 0, False)
    MsgBox fName
   
End Sub

Public Sub TestFolder()
    Dim folder As String
    folder = FolderBrowse("Select Folder", "C:\Temp")
End Sub

#End If

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

KlaK
Ehrenmitglied V.I.P. h.c.
Dipl. Ing. Vermessung, CAD- und Netz-Admin



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

Beiträge: 2567
Registriert: 02.05.2006

AutoCAD LandDesktop R2 bis 2004
Civil 3D 2005 - 2020
Plateia, Canalis
Visual Basic

erstellt am: 30. Jun. 2022 13:41    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 Nur für michimueller85 10 Unities + Antwort hilfreich

Hallo Michi,

Theoretisch kannst Du das auch mit Deinem Code machen:

Code:
Sub Excelopen()

  ' in Verweise Microsoft Excel xx Object Library aktivieren
 
  Dim xlWB As Workbook
  Dim tExcelApp As Object
  Dim strDatei As String

  Set tExcelApp = GetObject(, "Excel.Application") 'verbindet sich mit Excel, wenn dieses schon laeuft
  If tExcelApp Is Nothing Then
    Set tExcelApp = CreateObject("Excel.Application")
  End If
 
  strDatei = tExcelApp.GetOpenFilename()
  Set xlWB = tExcelApp.Workbooks.Open(strDatei)
  xlWB.Activate
  MsgBox "Tabelle wird nach Bearbeitung geschlossen"
  xlWB.Close
  Set xlWB = Nothing
End Sub


Grüße
Klaus 

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)2022 CAD.de | Impressum | Datenschutz