Hallo, Sorry om terug te komen op dit onderwerp, ik was 2 maanden afwezig en het onderwerp dat ik had geopend is niet opgelost.
Ik heb een probleem met een macro-slurry.
Als ik het gebruik, heb ik een bestand met de naam XXXXXD05 en als ik het via mijn macro kopieer, verandert het in xxxxxd05 .
het is alsof ik een bestand had met de naam "OrAngE" en ik heb het opgeslagen onder de naam "oranje", maar ik kan niet vinden hoe ik het moet vertellen om het originele formaat te behouden.
Ik heb geprobeerd een vergelijkingstekst te plaatsen, maar het verandert niets
Hier is een beetje van mijn macro.
Option Explicit
Option Compare Text ' ne prend pas compte du fait des majuscule "XXXXX"="xxxxx"
Dim Part As Object
Dim boolstatus As Boolean
Dim longstatus As Long, longwarnings As Long
Dim DerligneOuvre As Integer
Dim DerligneFerme As Integer
Dim swApp As SldWorks.SldWorks
Dim swModelDoc As SldWorks.ModelDoc2
Dim swModelDocExt As SldWorks.ModelDocExtension
Dim swPackAndGo As SldWorks.PackAndGo
Dim openFile As String
Dim pgFileNames As Variant
Dim pgFileStatus As Variant
Dim pgGetFileNames As Variant
Dim pgDocumentStatus As Variant
Dim status As Boolean
Dim Warnings As Long
Dim Errors As Long
Dim i As Long
Dim namesCount As Long
Dim myPath As String
Dim statuses As Variant
Dim oFSO As Scripting.FileSystemObject
Dim oDrv As Drive
Dim oFl As Folder
Public Function DossierExiste(MonDossier As String)
If Len(Dir(MonDossier, vbDirectory)) > 0 Then
DossierExiste = True
Else
DossierExiste = False
End If
End Function
' ----------------------------------------------------création dossier---------------------------------------------------------------------------------
Private Sub CommandButton1_Click()
If TextBox1.value = "" Then
MsgBox "mettre un numero de dossier"
Exit Sub
End If
'creer un repertoire affaire
Dim MonDossier As String
Sheets("CopieDeProjet").Range("F2") = TextBox1.value
MonDossier = Sheets("CopieDeProjet").Range("F4")
If DossierExiste(MonDossier) = True Then
MsgBox "Le dossier existe... prendre un numero non utiliser"
Exit Sub
Else
MsgBox "dossier creer..."
MkDir Sheets("CopieDeProjet").Range("F4")
End If
'----------------------------------------------------enregistrement assemblage-----------------------------------------------------------------------------------------
Set swApp = CreateObject("SldWorks.application")
Set Part = swApp.ActiveDoc
boolstatus = Part.ForceRebuild3(True)
boolstatus = Part.Save2(False)
Set swModelDoc = swApp.ActiveDoc
Set swModelDocExt = swModelDoc.Extension
Part.ClearSelection2 True
Part.EditRebuild3
'---------------------------------------------------------debut copie-----------------------------------------------------------------------------------------------------
Set swApp = CreateObject("SldWorks.Application")
' Get Pack and Go object
Set swPackAndGo = swModelDocExt.GetPackAndGo
' Get number of documents in assembly
namesCount = swPackAndGo.GetDocumentNamesCount
' Include any drawings, SOLIDWORKS Simulation results, and SOLIDWORKS Toolbox components
swPackAndGo.IncludeDrawings = True
swPackAndGo.IncludeSimulationResults = False
swPackAndGo.IncludeToolboxComponents = False
' Get current save-to paths and filenames of the assembly's documents
status = swPackAndGo.GetDocumentSaveToNames(pgFileNames, pgFileStatus)
' Set document paths and names for Pack and Go
For i = 0 To (namesCount - 1)
If InStr(pgFileNames(i), "34980") <> 0 Then
pgFileNames(i) = Replace(pgFileNames(i), "34980", "34950")
Else
pgFileNames(i) = ""
End If
Next i
status = swPackAndGo.SetDocumentSaveToNames(pgFileNames)
' Set folder where to save the files
myPath = " chemin du dossier "
status = swPackAndGo.SetSaveToName(True, myPath)
' Flatten the Pack and Go folder structure; save all files to the root directory
swPackAndGo.FlattenToSingleFolder = True
' Pack and Go
statuses = swModelDocExt.SavePackAndGo(swPackAndGo)
End sub
na een paar tests heb ik de indruk dat dit moeilijk op te lossen zal zijn via de functies van "GetPackAndGo", de functie "GetDocumentNames" lijkt namen terug te geven die systematisch kleine letters zijn...
Ter info, een afhaalsamenstelling heeft altijd het geval van de bestandsnamen veranderd en dit sinds de 2004-versie van het geheugen waar het de extensie al veranderde van SLDPRT naar sldprt. Dit alles uit mijn hoofd, maar ik weet dat we destijds last hadden van een software uit de MYCAD-suite die, in tegenstelling tot Windows, het verschil maakte tussen deze 2 extensiepauzes.
Oké, bedankt voor de informatie, het is altijd nuttig aan mijn kant, momenteel hebben we "lancering gekopieerd van project", wat het geval van de onderdelen behoudt door de eerste 5 tekens te vervangen door 5 andere, het kan me interesseren , daarom denk ik dat ik kan spelen met de functie "Vervangen", maar ik weet het niet Niet hoe.
daarom vraag ik me af of GetDocumentSaveToNames geen rekening houdt met kleine letters en hoofdletters.
Of als ik de vervangfunctie gebruik dat alles in kleine letters wordt geschreven.
Door na te gaan wat er bij elke stap gebeurt, realiseren we ons dat het probleem zich voordoet zodra de functie "GetDocumentNames" wordt aangeroepen, die stroomopwaarts is van de functie "Vervangen" die niets met het probleem te maken heeft.
Ik heb het inderdaad geprobeerd, het probleem is hier
Option Explicit
Option Compare Text ' ne prend pas compte du fait des majuscule "XXXXX"="xxxxx"
Dim Part As Object
Dim boolstatus As Boolean
Dim longstatus As Long, longwarnings As Long
Dim DerligneOuvre As Integer
Dim DerligneFerme As Integer
Dim swApp As SldWorks.SldWorks
Dim swModelDoc As SldWorks.ModelDoc2
Dim swModelDocExt As SldWorks.ModelDocExtension
Dim swPackAndGo As SldWorks.PackAndGo
Dim openFile As String
Dim pgFileNames As Variant
Dim pgFileStatus As Variant
Dim pgGetFileNames As Variant
Dim pgDocumentStatus As Variant
Dim status As Boolean
Dim Warnings As Long
Dim Errors As Long
Dim i As Long
Dim namesCount As Long
Dim myPath As String
Dim statuses As Variant
Dim oFSO As Scripting.FileSystemObject
Dim oDrv As Drive
Dim oFl As Folder
Public Function DossierExiste(MonDossier As String)
If Len(Dir(MonDossier, vbDirectory)) > 0 Then
DossierExiste = True
Else
DossierExiste = False
End If
End Function
' ----------------------------------------------------création dossier---------------------------------------------------------------------------------
Private Sub CommandButton1_Click()
If TextBox1.value = "" Then
MsgBox "mettre un numero de dossier"
Exit Sub
End If
'creer un repertoire affaire
Dim MonDossier As String
Sheets("CopieDeProjet").Range("F2") = TextBox1.value
MonDossier = Sheets("CopieDeProjet").Range("F4")
If DossierExiste(MonDossier) = True Then
MsgBox "Le dossier existe... prendre un numero non utiliser"
Exit Sub
Else
MsgBox "dossier creer..."
MkDir Sheets("CopieDeProjet").Range("F4")
End If
'----------------------------------------------------enregistrement assemblage-----------------------------------------------------------------------------------------
Set swApp = CreateObject("SldWorks.application")
Set Part = swApp.ActiveDoc
boolstatus = Part.ForceRebuild3(True)
boolstatus = Part.Save2(False)
'longstatus = Part.SaveAs3(Sheets("CopieDeProjet").Range("F3") & "\" & Sheets("CopieDeProjet").Range("E2") & ".SLDASM", 0, 2)
'Set Part = Nothing
'swApp.CloseDoc Sheets("CopieDeProjet").Range("E2") & ".SLDASM"
'Set Part = swApp.OpenDoc6(Sheets("CopieDeProjet").Range("F3") & "\" & Sheets("CopieDeProjet").Range("E2") & ".SLDASM", 2, 0, "", longstatus, longwarnings)
'Set Part = swApp.ActiveDoc
'Part.ClearSelection2 True
'Part.EditRebuild3
Set swModelDoc = swApp.ActiveDoc
Set swModelDocExt = swModelDoc.Extension
Part.ClearSelection2 True
Part.EditRebuild3
'---------------------------------------------------------debut copie-----------------------------------------------------------------------------------------------------
Set swApp = CreateObject("SldWorks.Application")
' Get Pack and Go object
Set swPackAndGo = swModelDocExt.GetPackAndGo
' Get number of documents in assembly
namesCount = swPackAndGo.GetDocumentNamesCount
' Include any drawings, SOLIDWORKS Simulation results, and SOLIDWORKS Toolbox components
swPackAndGo.IncludeDrawings = True
swPackAndGo.IncludeSimulationResults = False
swPackAndGo.IncludeToolboxComponents = False
' Get current paths and filenames of the assembly's documents
status = swPackAndGo.GetDocumentNames(pgFileNames)
Debug.Print ""
Debug.Print " Current path and filenames: "
If (Not (IsEmpty(pgFileNames))) Then
For i = 0 To UBound(pgFileNames)
Debug.Print " The path and filename is: " & pgFileNames(i)
Next i
End If
' Get current save-to paths and filenames of the assembly's documents
status = swPackAndGo.GetDocumentSaveToNames(pgFileNames, pgFileStatus)
Debug.Print ""
Debug.Print " Current default save-to filenames: "
If (Not (IsEmpty(pgFileNames))) Then
For i = 0 To UBound(pgFileNames)
Debug.Print " The path and filename is: " & pgFileNames(i)
Next i
End If
In het bijzonder is de
' Get current paths and filenames of the assembly's documents
status = swPackAndGo.GetDocumentNames(pgFileNames)
Debug.Print ""
Debug.Print " Current path and filenames: "
If (Not (IsEmpty(pgFileNames))) Then
For i = 0 To UBound(pgFileNames)
Debug.Print " The path and filename is: " & pgFileNames(i)
Next i
End If
' Get current save-to paths and filenames of the assembly's documents
status = swPackAndGo.GetDocumentSaveToNames(pgFileNames, pgFileStatus)
Debug.Print ""
Debug.Print " Current default save-to filenames: "
If (Not (IsEmpty(pgFileNames))) Then
For i = 0 To UBound(pgFileNames)
Debug.Print " The path and filename is: " & pgFileNames(i)
Next i
End If
Ik heb misschien een oplossing gevonden dat als ik een code van dit type aan het einde van mijn macro toevoeg om alles in hoofdletters te hernoemen, denk je dat mijn referenties in sw zullen volgen??
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
ReDim pgGetFileNames(namesCount - 1)
ReDim pgDocumentStatus(namesCount - 1)
status = swPackAndGo.GetDocumentSaveToNames(pgGetFileNames, pgDocumentStatus)
' Pack and Go
statuses = swModelExt.SavePackAndGo(swPackAndGo)
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''Add the following lines after Pack and go command
For i = 0 To (namesCount - 1) '''''''''''''change lowecase to uppercase
Name pgGetFileNames(i) As UCase(pgGetFileNames(i)) ' Rename file.
If (Right(UCase(pgGetFileNames(i)), 7) = ".SLDPRT") Then
DRAW = Replace(UCase(pgGetFileNames(i)), "SLDPRT", "SLDDRW")
If Dir(DRAW) <> "" Then Name DRAW As UCase(DRAW)
End If
Next i
Dit lost het probleem van het mengen van kleine letters en hoofdletters niet op, zoals in je voorbeeld met het woord "OrAngE", je hebt alles in hoofdletters in plaats van alles in kleine letters.
Ja, helaas kan ik geen oplossing vinden, dus heb ik een stukje code toegevoegd dat door vensters gaat om mijn onderdelen in hoofdletters te hernoemen, ik heb maar één probleem is dat mijn onderdelen in hoofdletters staan.
maar als ik Solidworks open, zijn het kleine letters
Het is niet de breuk die ik wilde hebben, maar ik heb geen keuze naar mijn mening ... :/
Ik zie niet in waarom je door Windows gaat om je onderdelen in hoofdletters te hernoemen, je hoeft alleen maar te zetten:
For i = 0 To (namesCount - 1)
pgFileNames(i) = Replace(pgFileNames(i), pgFileNames(i), UCase(pgFileNames(i)))
Next i
Voor je regels:
myPath = " chemin du dossier "
status = swPackAndGo.SetSaveToName(True, myPath)
En wanneer u vervolgens uw assemblage opent vanuit de PackAnGo, controleer dan of uw eerste assemblage is gesloten, anders kan Solidworks verwijzen naar de oude assemblage in plaats van de nieuwe omdat deze niet hoofdlettergevoelig is.
