Hallo, tut mir leid, auf dieses Thema zurückzukommen, ich war 2 Monate abwesend und das Thema, das ich eröffnet hatte, ist nicht gelöst.
Ich habe ein Problem mit einer Makroaufschlämmung.
Wenn ich es benutze, habe ich eine Datei mit dem Namen XXXXXD05 und wenn ich sie über mein Makro kopiere, wird sie zu xxxxxd05 .
Es ist, als hätte ich eine Datei mit dem Namen "OrAngE" und ich habe sie unter dem Namen "orange" gespeichert, aber ich kann nicht finden, wie ich ihr sagen soll, dass sie das ursprüngliche Format behalten soll.
Ich habe versucht, einen Vergleichstext zu setzen, aber es ändert sich nichts
Hier ist ein bisschen von meinem Makro.
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
Ich hatte diesen hier als Basis
http://help.solidworks.com/2015/English/api/sldworksapi/Pack_and_Go_an_Assembly_Example_VB.htm
