#2 데이터를 선택하여, 모델을 변경 하기

□ 기능 소개

Excel VBA 프로그램을 실행 하면, 자동으로 Data Sheet에서 Dimension Name을 가져오는 코드입니다.이벤트가 발생 합니다. Dimension Group Name를 가져오는 코드를 포함 합니다.

Dimension Name은 Data Sheet에 추가 할수 있습니다.  Dimension Group Name은 추가 할수 있습니다.
하지만 Drop & Down List 기능으로 65개 이하만 가능 합니다. 프로그램 코딩은 프로그램을 시작하면서 실행하는 이벤트를 사용 합니다. "현재 통합 문서"에 코딩을 해야 합니다. 

□  코드 

Private Sub Workbook_Open()
 
        Dim DimensionName As Long
        'Dim SQName As Long
        Dim i As Long
        'Dim j As Long
        
        '//Dimension Name Count
        DimensionName = Worksheets("PRO_DATA").Cells(1, Columns.Count).End(xlToLeft).Column
        DimensionName = DimensionName - 1
        
        For i = 0 To DimensionName - 1
                   Worksheets("Program01").Cells(13, i + 4) = Worksheets("PRO_DATA").Cells(1, i + 2)
        Next i
        
        
        '//SQ Size Name
        'SQName = Worksheets("PRO_DATA").Cells(Rows.Count, "A").End(xlUp).Row
        'SQName = SQName - 1
        
        
        '//Dimension Name Display
        'Dim ModelDimensionName() As Variant
        'ReDim ModelDimensionName(SQName)
    
        'For j = 0 To SQName - 1
            'ModelDimensionName(j) = Array(Worksheets("PRO_DATA").Cells(j + 2, 1))
        'Next j
        
        '//Drop Box List
        
        Dim WS As Worksheet
        Dim cell As Range
        Dim listString As String

        Set WS = Worksheets("PRO_DATA")

        '// Build the list string by iterating through SQName range
        For Each cell In WS.Range("A2", WS.Cells(Rows.Count, "A").End(xlUp))
            listString = listString & cell.Value & ","  '// Add each cell value to the list string, separated by comma
        Next cell

        '// Remove the trailing comma from the list string
        listString = Left(listString, Len(listString) - 1)

        '// Check for errors in list string
        If InStr(listString, ",") = 0 Then
            MsgBox "List string cannot be empty or contain only one value."
            Exit Sub
        End If

        '// Replace commas with another delimiter if necessary
        If Len(listString) > 255 Then
            MsgBox "List string is too long. Please reduce the number of items or use a different delimiter."
            Exit Sub
        End If

        '// Set the validation with the built list string

         Worksheets("Program01").Range("F9").Select
         With Selection.Validation
                .Delete
                .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
                xlBetween, Formula1:=listString
                .IgnoreBlank = True
                .InCellDropdown = True
                .InputTitle = ""
                .ErrorTitle = ""
                .InputMessage = ""
                .ErrorMessage = ""
                .IMEMode = xlIMEModeNoControl
                .ShowInput = True
                .ShowError = True
         End With
        
        MsgBox "ToolBOX VBA : 환영 합니다.", vbInformation, "www.idt21c.com"
       
End Sub

 

□ 검색 기능

모델에서 치수 이름을 검색 하고, 치수 이름을 가져 옵니다. SQ Size 의 Dimension Group Name을 확인하고,  Data sheet 에서 Dimension Value들을 가져 옵니다

 

□  코드 

Option Explicit
Sub Open_template()
    On Error GoTo RunError
    
    Application.EnableEvents = False
    
    '// Check if "Program01" worksheet exists
    If Not WorksheetExists("Program01") Then
        MsgBox "Worksheet 'Program01' not found.", vbExclamation, "Error"
        Exit Sub
    End If
    
    Dim asynconn As New pfcls.CCpfcAsyncConnection
    Dim conn As pfcls.IpfcAsyncConnection
    
    '// Check Creo Connect
    Set conn = asynconn.Connect("", "", ".", 5)
    
    If conn Is Nothing Then
        MsgBox "An error occurred while starting a new Creo Parametric Session", vbInformation, "www.idt21c.com"
        Exit Sub
    End If

    Dim BaseSession As pfcls.IpfcBaseSession
    Dim model As pfcls.IpfcModel

    Set BaseSession = conn.Session
    Set model = BaseSession.CurrentModel
               
               
    '// Current Model Information
    Worksheets("Program01").Cells(2, "D") = BaseSession.GetCurrentDirectory
    Worksheets("Program01").Cells(3, "D") = model.filename
    
    '// Display template model dimension values
    
    Dim Modelowner As IpfcModelItemOwner
    Dim modelitems As IpfcModelItems
    Dim Dimensionlitem As IpfcModelItem
    Dim BaseDimension As IpfcBaseDimension
    Dim DimensionNameCount As Long
    
    Set Modelowner = model
    Set modelitems = Modelowner.ListItems(EpfcModelItemType.EpfcITEM_DIMENSION)
        
    DimensionNameCount = Worksheets("Program01").Cells(13, Columns.Count).End(xlToLeft).Column
    DimensionNameCount = DimensionNameCount - 3 '// "A13". "B13", "C13" (3ea)
    
    Dim i As Long
    Dim j As Long
    
    
    For i = 0 To DimensionNameCount - 1
                For j = 0 To modelitems.Count - 1
                          Set Dimensionlitem = modelitems(j)
                               
                                If Cells(13, i + 4) = Dimensionlitem.GetName Then  '// Compare dimension names
                                    Set BaseDimension = modelitems(j)
                                    Cells(14, i + 4) = BaseDimension.DimValue
                                End If
                 Next j
    Next i
    
    '// Null value check
     For i = 0 To DimensionNameCount - 1
    
        If Cells(14, i + 4).Value = "" Then
            Cells(14, i + 4) = "DIM 없음"
        End If
        
     Next i
    
   MsgBox "Template 모델 치수를 가져왔습니다.!", vbInformation, "www.idt21c.com"

    
    conn.Disconnect (2)
    
    ' Cleanup
    Set asynconn = Nothing
    Set conn = Nothing
    Set BaseSession = Nothing
    Set model = Nothing
    
Exit Sub

RunError:
    If Err.Number <> 0 Then
        MsgBox "Process Failed: An error occurred." & vbCrLf & _
               "Error No: " & CStr(Err.Number) & vbCrLf & _
               "Error Description: " & Err.Description & vbCrLf & _
               "Error Source: " & Err.Source, vbCritical, "Error"
        If Not conn Is Nothing Then
            If conn.IsRunning Then
                conn.Disconnect (2)
            End If
        End If
    End If
End Sub
Function WorksheetExists(shtName As String) As Boolean
    On Error Resume Next
    WorksheetExists = Not Worksheets(shtName) Is Nothing
    On Error GoTo 0
End Function

 

 아래 블로그를 참고 하여, 유효성 검사 기능을 Drop BOX List로 구현 하였습니다. 
  주) Formula1:="= " & 시트목록.Address는 1004 오류를 발생 시킬수 있습니다.

(VBA) Formula1에 범위 지정하기 - 유효성 검사 목록 자동 update