Code:
Private Sub MF_BL1_SFEL_Nr_Click()
On Error GoTo ErrorHandler
' Check if a document is open
Dim oApp As Inventor.Application
Set oApp = ThisApplication
If oApp.ActiveDocument Is Nothing Then
MsgBox "Kein Dokument geöffnet"
Exit Sub
End If
' Initialize document and property sets
Dim oDoc As Document
Set oDoc = oApp.ActiveDocument
Dim oPropSets As PropertySets
Set oPropSets = oDoc.PropertySets
' Update "Creation Time" property
UpdateCreationTimeMFBl1 oPropSets
' Handle "SFEL Nr." property
Dim cuPropSet As PropertySet
Set cuPropSet = oDoc.PropertySets.Item("Inventor User Defined Properties")
Dim PropName As String
PropName = "BL1-SFEL Nr."
Dim oExist As Boolean
oExist = CheckPropertyExistenceMFBl1(cuPropSet, PropName)
' Read SFEL data from Excel
Dim sfelArray As Variant
Dim sfelbArray As Variant
ReadExcelDataMFBl1 "\\SFS02\Cad_Konfig\Sheffield\ASite Zeichnungsnummern.xlsx", sfelArray, sfelbArray
' Show SFEL selection form
Dim selectedSFEL As String
selectedSFEL = ShowSFELFormMFBl1(sfelArray, sfelbArray)
If selectedSFEL = "" Then
MsgBox "Keine SFEL Nr. ausgewählt. Vorgang abgebrochen."
Exit Sub
End If
' Confirm or edit SFEL Nr.
selectedSFEL = InputBox("Aktuelle SFEL Nr.: " & selectedSFEL & vbCrLf & "Bitte bestätigen oder bearbeiten Sie die SFEL Nr.:", "SFEL Nr. bearbeiten", selectedSFEL)
' Update or create the "SFEL Nr." property
UpdateOrCreatePropertyMFBl1 cuPropSet, "BL1-SFEL Nr.", selectedSFEL, oExist
' Update or create the "Zeichnungsnummer" property
UpdateOrCreatePropertyMFBl1 cuPropSet, "Zeichnungsnummer", selectedSFEL, CheckPropertyExistenceMFBl1(cuPropSet, "Zeichnungsnummer")
' Notify user and update document
NotifyUserMFBl1 oDoc, "BL1-SFEL Nr.", selectedSFEL
oDoc.Update
Exit SubErrorHandler:
MsgBox "Ein Fehler ist aufgetreten: " & err.Description, vbCritical
End Sub
Private Sub UpdateCreationTimeMFBl1(oPropSets As PropertySets)
Dim oPropSet As PropertySet
For Each oPropSet In oPropSets
For i = 1 To oPropSet.Count
If oPropSet(i).Name = "Creation Time" Then
On Error Resume Next
oPropSet(i).value = Split(Now, " ")(0)
On Error GoTo 0
End If
Next i
Next oPropSet
End Sub
Private Function CheckPropertyExistenceMFBl1(cuPropSet As PropertySet, PropName As String) As Boolean
Dim i As Property
For Each i In cuPropSet
If i.DisplayName = PropName Then
CheckPropertyExistenceMFBl1 = True
Exit Function
End If
Next
CheckPropertyExistenceMFBl1 = False
End Function
Private Sub ReadExcelDataMFBl1(excelFilePath As String, ByRef sfelArray As Variant, ByRef sfelbArray As Variant)
If Dir(excelFilePath) = "" Then
MsgBox "Die Excel-Datei wurde nicht gefunden. Bitte überprüfen Sie den Pfad.", vbCritical
Exit Sub
End If
On Error Resume Next
Dim xlApp As Object
Set xlApp = CreateObject("Excel.Application")
If err.Number <> 0 Then
MsgBox "Excel konnte nicht geöffnet werden. Stellen Sie sicher, dass Excel installiert ist.", vbCritical
Exit Sub
End If
On Error GoTo 0
xlApp.ScreenUpdating = False
Dim xlBook As Object
Set xlBook = xlApp.Workbooks.Open(excelFilePath)
Dim xlSheet As Object
Set xlSheet = xlBook.Sheets(2) ' Access the second sheet
Dim lastRow As Long
lastRow = xlSheet.Cells(xlSheet.Rows.Count, 2).End(-4162).Row
sfelArray = xlSheet.Range("B2:E" & lastRow).value
xlBook.Close SaveChanges:=False
xlApp.Quit
End Sub
Private Function ShowSFELFormMFBl1(sfelArray As Variant, sfelbArray As Variant) As String
Dim sfelForm As Object
Set sfelForm = New frmSFELSelection
' Konfigurieren der Listbox
With sfelForm.lstSFEL
.ColumnCount = 4
.ColumnWidths = "100 pt;100 pt;100 pt;100 pt"
.Clear
' Convert sfelArray to a suitable format
Dim dataArray() As Variant
Dim i As Long, j As Long
Dim numRows As Long, numCols As Long
numRows = UBound(sfelArray, 1) - LBound(sfelArray, 1) + 1
numCols = UBound(sfelArray, 2) - LBound(sfelArray, 2) + 1
ReDim dataArray(1 To numRows, 1 To numCols)
For i = LBound(sfelArray, 1) To UBound(sfelArray, 1)
For j = LBound(sfelArray, 2) To UBound(sfelArray, 2)
dataArray(i - LBound(sfelArray, 1) + 1, j - LBound(sfelArray, 2) + 1) = sfelArray(i, j)
Next j
Next i
' Assign the array to the ListBox
.List = dataArray
End With
sfelForm.Show vbModal
' Rückgabe des Werts aus der Spalte E (4)
ShowSFELFormMFBl1 = ""
If sfelForm.lstSFEL.ListIndex <> -1 Then
ShowSFELFormMFBl1 = sfelArray(sfelForm.lstSFEL.ListIndex + 1, 4)
End If
Unload sfelForm
End Function
Private Sub UpdateOrCreatePropertyMFBl1(cuPropSet As PropertySet, PropName As String, PropValue As String, oExist As Boolean)
If oExist Then
Dim i As Property
For Each i In cuPropSet
If i.DisplayName = PropName Then
i.value = PropValue
End If
Next
Else
cuPropSet.Add PropValue, PropName
End If
End Sub
Private Sub NotifyUserMFBl1(oDoc As Document, PropName As String, PropValue As String)
Dim invCustomPropertySet As PropertySet
Set invCustomPropertySet = oDoc.PropertySets.Item("Inventor User Defined Properties")
Dim invTestProperty As Property
For Each invTestProperty In invCustomPropertySet
If invTestProperty.Name = PropName Then
MsgBox "Die aktuelle " & PropName & " ist: " & invTestProperty.value & vbCrLf & "Bitte sicherstellen, dass diese Nummer korrekt ist.", vbInformation, PropName & " Information"
End If
Next
End Sub
Foren auf CAD.de (alle Foren)
| 
