Hallo
Ik had deze techniek al gezien, maar ik had graag een
Misschien een ontbrekende referentie?
Bekijk dit onderwerp als u de juiste oplossing vindt:
https://r1132100503382-eu1-3dswym.3dexperience.3ds.com/#community:yUw32GbYTEqKdgY7-jbZPg/iquestion:QG0F7bLmQaOUb70yb4BJfw
Ik heb verschillende macro's geprobeerd, Christian Chu's een werkt, maar het opent niet het dialoogvenster dat ik wil, het is de vereenvoudigde versie van de mapselectie die het opent voor mijn deel de andere macro's werken niet
een oude macro crasht excel en SW
Private Type BrowseInfo
hWndOwner As Long
pIDLRoot As Long
pszDisplayName As Long
lpszTitle As Long
ulFlags As Long
lpfnCallback As Long
lParam As Long
iImage As Long
End Type
Private Declare ptrsafe Sub CoTaskMemFree Lib "ole32.dll" (ByVal hMem As Long)
Private Declare ptrsafe Function lstrcat Lib "kernel32" (ByVal lpString1 As String, ByVal lpString2 As String) As Long
Private Declare ptrsafe Function SHBrowseForFolder Lib "shell32" (lpbi As BrowseInfo) As Long
Private Declare ptrsafe Function SHGetPathFromIDList Lib "shell32" (ByVal pidList As Long, ByVal lpBuffer As String) As Long
Public Function ChoixDossier(Titre)
Dim Rien As Integer
Dim Liste As Long
Dim Resultat As String
Dim Browse_info As BrowseInfo
With Browse_info
.lpszTitle = lstrcat(Titre, "")
.ulFlags = 1
End With
Liste = SHBrowseForFolder(Browse_info)
If Liste Then
Resultat = String$(260, 0)
SHGetPathFromIDList Liste, Resultat
CoTaskMemFree Liste
Rien = InStr(Resultat, vbNullChar)
If Rien Then
ChoixDossier = Left$(Resultat, Rien - 1)
End If
End If
End Function
Sub Test()
MsgBox ChoixDossier("Choisissez le dossier")
End Sub
wat ik zoek is het equivalent van msoFileDialogFolderPicker / Application.FileDialog(4). Tonen
Dit dialoogvenster kan worden geactiveerd zoals op de schermafbeelding, maar ik zie niet hoe ik het vanuit vba kan starten
capture_000130.png
Ik vond dit onderwerp op dit zelfde forum:
https://www.lynkoa.com/forum/import-export-formats-neutres/vba-afficher-bo%C3%AEte-de-dialogue-de-s%C3%A9lection-de-dossier-avec-chem
Met een beetje geluk vind je wat je zoekt.
Hallo
Hierdoor wordt niet het juiste dialoogvenster weergegeven
Je moet kijken naar het laatste bericht van de vorige link die verwijst naar een link en een bericht van @liryc
https://www.lynkoa.com/forum/solidworks/bouton-parcourir-macro-vba
In de hoop dat het deze keer het juiste dialoogvenster is:
Voor de code in de 1e module:
Dim swApp As SldWorks.SldWorks
Dim FileName As String
Dim Filter As String
Dim fileConfig As String
Dim fileDispName As String
Dim fileOptions As Long
'Sub main()
'Set swApp = Application.SldWorks
'Filter = "SolidWorks Files (*.slddrw)|*.slddrw" 'Filtre les types de fichiers
'FileName = swApp.GetOpenFileName("File to Attach", "", Filter, fileOptions, fileConfig, fileDispName)
'End Sub
Dim MonDoss As String
Sub main()
MonDoss = FolderBrowse("Choisir un répertoire à traiter...", "C:\")
End Sub
In een andere module voor hetzelfde swp-bestand:
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 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
'====== 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
Hallo
het is niet het juiste dialoogvenster dat wordt weergegeven, bovendien is het een echte gasfabriek, die thuis SW crasht en die kan worden geschreven met een veel kortere code in de exes die ik al heb gezien
Hallo @ll,
De code voor uw eerste macro verwijst naar het fileDialog-object dat bestaat in het Office-universum van Microsoft, maar niet in VBA- of SolidWorks-API's.
Als u Excel op uw pc hebt geïnstalleerd, kan de volgende code, die gebruikmaakt van het Excel-toepassingsobject , werken.
Vriendelijke groeten.
Option Explicit
Sub selectionDossier()
' Valeur de constante à passer à fileDialog en fonction de l'usage attendu (cf. aide Microsoft)
Const msoFileDialogOpen = 1 ' Permet à l'utilisateur d'ouvrir un fichier.
Const msoFileDialogSaveAs = 2 ' Permet à l'utilisateur d'enregistrer un fichier.
Const msoFileDialogFilePicker = 3 ' Permet à l'utilisateur de sélectionner un fichier.
Const msoFileDialogFolderPicker = 4 ' Permet à l'utilisateur de sélectionner un dossier.
Dim xlsheet As Object
Dim xlFileDialog As Object
Dim dossier As String
Set xlsheet = CreateObject("Excel.Sheet")
Set xlFileDialog = xlsheet.Application.FileDialog(msoFileDialogFolderPicker)
With xlFileDialog
.Title = "Selectionner dossier"
.InitialFileName = "C:\"
.Show
dossier = .SelectedItems(1)
End With
Set xlsheet = Nothing
If Len(dossier) > 0 Then
MsgBox "Dossier sélectionné : " & dossier
Else
MsgBox "Abandon"
End If
End Sub
1 like
Het werkt goed, bedankt
Als iemand de code voor het SW-dialoogvenster heeft in plaats van Excel, moet deze korter zijn
Ik heb het geval van de knop Ongedaan maken toegevoegd
Sub selectionDossier()
'Const msoFileDialogOpen = 1 ' Ouvrir un fichier
'Const msoFileDialogSaveAs = 2 ' Enregistrer un fichier
'Const msoFileDialogFilePicker = 3 ' Sélectionner un fichier
Const msoFileDialogFolderPicker = 4 ' Sélectionner un dossier
Dim xlsheet As Object
Dim xlFileDialog As Object
Dim dossier As String
Set xlsheet = CreateObject("Excel.Sheet")
Set xlFileDialog = xlsheet.Application.FileDialog(msoFileDialogFolderPicker)
With xlFileDialog
.Title = "Selectionner dossier"
.InitialFileName = "C:\"
If .Show <> 0 Then '<> BT Annuler
dossier = .SelectedItems(1)
End If
End With
Set xlsheet = Nothing
End Sub
Niets te maken met het onderwerp
Ik heb een Minecraft-macro op SW beschikbaar gesteld voor degenen die geïnteresseerd zijn: Lynkoa Community / TUTORIALS
Bedankt voor de code @m.blt
je hoeft alleen maar het Met-blok te vervangen door deze code om de fout bij annulering af te handelen:
dossier = vbNullString
With xlFileDialog
.Title = "Selectionner dossier"
.InitialFileName = "C:\"
.Show
On Error Resume Next 'gère la cancel error
dossier = .SelectedItems(1)
End With
Via solidworks direct = onmogelijk met FileDialog zoals @m.blt zegt:
https://r1132100503382-eu1-3dswym.3dexperience.3ds.com/#community:yUw32GbYTEqKdgY7-jbZPg/iquestion:oJZLfucoQ9OmlIPXWjDnzA
Er zijn 2 omwegen gevonden:
https://thecadcoder.com/vba/browse-solidworks-file/
een via Excel zoals @m.blt en een andere die er niet echt beter uitziet (niet sneller of korter) via userform (te testen als je wilt).
Ik vraag niet per se om de aanroep van de box door FileDialog, ongeacht de code
Dit dialoogvenster bestaat in SolidWorks omdat het als volgt kan worden geopend
capture_000131.png
Het bestaat, maar helaas is SW niet gecodeerd in vba, dus niet alles wat in SW bestaat, bestaat in vba.
Ik beheers niet alle vormen van programmeren, maar ik heb wel eens codes gezien die 'shell iets' aanroepen. Ik denk dat als iemand goed kan programmeren het misschien mogelijk is om dit dialoogvenster aan te roepen, net zoals de opties van het ingebouwde SW dialoogvenster het gebruiken
Het basisprobleem is vba onder 64 bits, omdat er onder 32 veel meer bedieningselementen beschikbaar zijn, inclusief dialoogvensters, die niet compatibel zijn met vba 64... Het is afwijkend, hartverscheurend en frustrerend...
Ik heb deze dialoog ook nodig en ik word er gek van. Het Excel-dialoogvenster is een noodoplossing (bedankt @m.blt ), maar het is zo traag om te openen ...
Nou, dus deze traagheid van het openen van het dialoogvenster dwong me om te testen op basis van @m.blt om het sneller te maken. Wat ik deed, naast het verkleinen van de code. Ik heb er terloops een functie van gemaakt. Hier is:
Dim xlFolderDlg As Office.FileDialog
Private Sub UserForm_Initialize()
Set xlFolderDlg = Excel.Application.FileDialog(4)
End Sub
Function FolderDialog$(Optional folder$)
With xlFolderDlg
.Title = "Sélectionner un dossier"
.ButtonName = "Sélectionner"
.InitialFileName = folder
If .Show Then folder = .SelectedItems(1)
End With
FolderDialog = folder
End Function
Private Sub CMDfolderDlg_Click()
TXTfolder = FolderDialog(TXTfolder)
End Sub
.
Waarbij CMDfolderDlg een CommandButton is en TXTfolder een tekstvak.
Er is echter één nadeel; Wanneer het dialoogvenster wordt gesloten, wordt de hand niet hersteld (het venster is gedeselecteerd). Jammer, maar niet dramatisch.
interessant
Ik heb een compilatiefout op de 1e regel
Hallo
De @Sylk code vereist het gebruik van een formulier (UserForm in VBA) met een knop en een tekstvak om de functie te activeren.
Vergeet niet om verwijzingen naar Office en Excel toe te voegen aan de VBA-referentiepagina door de bijbehorende vakjes aan te vinken (zie onderstaande afbeelding).
De bijgevoegde macro moet functioneel zijn.
Vriendelijke groeten.
explorerfiles.swp
2 likes
Inderdaad @m.blt dank je. Alleen dat, aangezien ik in de tussentijd mijn bericht heb bewerkt en de naam van de knop van CMDopenFolder naar CMDfolderDlg (om het consistenter te maken), ik de naam van de knop in het bijgevoegde swp-bestand moet vervangen.
Persoonlijk gebruik ik het tekstvak in de vergrendelde true-modus, zodat de inhoud zichtbaar, selecteerbaar en scrollbaar is (wanneer het langer is dan het tekstvak), maar zonder de mogelijkheid om het te wijzigen door te typen, om een beheer van verboden tekens te voorkomen.
Als u een standaardmap wilt instellen, wijzigt u eenvoudig de eigenschap Text wanneer het besturingselement wordt gemaakt. Of laat het leeg, waardoor standaard "mijn documenten" wordt geopend.