Code:
Const NMB_FORMAT As String = "00"
Option Explicit
Dim swapp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2
Dim myD1 As SldWorks.Dimension
Dim objSource As Excel.Worksheet
Dim xl As Excel.Workbook
Dim Errors As Long
Dim Warnings As Long
Dim Name1, Name2 As String
Sub Nummerngenerator()
Dim Konstrukteur_K As String
Dim NMB_SRC_FILE_PATH As String
Dim sName As String
Dim sDate As String
Set swapp = Application.SldWorks
Set swModel = swapp.ActiveDoc
sName = swModel.CustomInfo("3dCreatedBy")
If sName = "" Then
MsgBox ("Bitte Konstrukteur angeben!")
Exit Sub
End If
If sName = "Beispiel1" Then
Konstrukteur_K = "RA"
ElseIf sName = "Beispiel9" Then
Konstrukteur_K = "MC"
ElseIf sName = "Beispiel8" Then
Konstrukteur_K = "LH"
ElseIf sName = "Beispiel7" Then
Konstrukteur_K = "LL"
ElseIf sName = "Beispiel6" Then
Konstrukteur_K = "KM"
ElseIf sName = "Beispiel5" Then
Konstrukteur_K = "NE"
ElseIf sName = "Beispiel21" Then
Konstrukteur_K = "KO"
ElseIf sName = "Beispiel4" Then
Konstrukteur_K = "JW"
ElseIf sName = "Beispiel2" Then
Konstrukteur_K = "JZ"
End If
sDate = Format(Date, "yymmdd")
If Dir("T:\Austauschordner\Test\" & Konstrukteur_K & sDate & ".xlsx") <> "" Then
Else
MsgBox ("Nummerngenerator nicht aktiv!")
Exit Sub
End If
NMB_SRC_FILE_PATH = "T:\Austauschordner\Test\" & Konstrukteur_K & sDate & ".xlsx"
main NMB_SRC_FILE_PATH, Konstrukteur_K, sDate
End Sub
Sub main(NMB_SRC_FILE_PATH As String, Konstrukteur_K As String, sDate As String)
Set swapp = Application.SldWorks
Dim swModel As SldWorks.ModelDoc2
Set swModel = swapp.ActiveDoc
Dim lastNumber As Integer
Dim Excel As Excel.Application
Dim x, y As Integer
Dim excel_NOK As Boolean
Dim FileName As String
Dim wb As Excel.Workbook
Set Excel = GetObject(, "Excel.Application")
' Wenn ein Fehler auftritt dann läuft Excel noch nicht
If Err.number <> 0 Then excel_NOK = True
Err.Clear
' Wenn Excel noch nicht läuft, dann wird es gestartet
If excel_NOK = True Then
Set Excel = CreateObject("excel.application")
End If
FileName = swapp.GetCurrentMacroPathName
Set wb = Excel.Workbooks.Open(NMB_SRC_FILE_PATH)
x = 1
y = 1
lastNumber = Excel.ActiveSheet.Cells(y, x).Value
wb.Save
Excel.Quit
Dim thisNumber As Integer
thisNumber = lastNumber + 1
swModel.CustomInfo("PartNo") = Konstrukteur_K & sDate & Format(thisNumber, NMB_FORMAT)
StoreNumber NMB_SRC_FILE_PATH, thisNumber
End Sub
Sub StoreNumber(filePath As String, number As Integer)
Dim Excel As Excel.Application
Dim x, y As Integer
Dim excel_NOK As Boolean
Dim FileName As String
Dim wb As Excel.Workbook
Set Excel = GetObject(, "Excel.Application")
' Wenn ein Fehler auftritt dann läuft Excel noch nicht
If Err.number <> 0 Then excel_NOK = True
Err.Clear
' Wenn Excel noch nicht läuft, dann wird es gestartet
If excel_NOK = True Then
Set Excel = CreateObject("excel.application")
End If
FileName = swapp.GetCurrentMacroPathName
Set wb = Excel.Workbooks.Open(filePath)
x = 1
y = 1
Excel.ActiveSheet.Cells(y, x).Value = number
wb.Save
Excel.Quit
End Sub
Foren auf CAD.de (alle Foren)
| 
