라이브러리들을 편리하게 사용 할수 있는 프로그램 입니다. 어셈 블리 모드에서 엑셀 파일에 표시된 라이브러리 파일들을 쉽게 검색하여, 사용 가능 합니다. Windchill 프로그램이 없는 여러 사용자가 협업 하는 곳에 필수로 입니다.
■ 프로그램 파일 Download
라이브러리는 중앙에서 관리 합니다. 중복데이터를 생성 하면 안됩니다. 라이브러리를 구성 하기 위해서는 수동으로 작업을 해야 합니다. Window 공유 폴더를 사용 합니다. Nas 장비를 사용 하는곳은 FTP 서버를 설정 하여 사용 가능 합니다.
공유 PC가 준비되면 Window 공유 폴더를 설정 하고, config.pro > Search.pro 파일을 설정 합니다
1. Window 공유 폴더 사용
- 관리자가 공유 폴더를 설정 합니다. 관리자만 공유 폴더 아래에 라이브러리 폴더를 구성 할수 있습니다
- 관리자만 공유 폴더 아래의 라이브러리 폴더에 파일을 저장 할 수 있습니다
2. config.pro 파일을 설정 합니다.
- Creo가 Window 공유 폴더를 인식할수 있도록 Path 설정을 해야 합니다. config.pro 에 설정 합니다
- Window 메모장으로 "std_search.pro" 파일을 생성 합니다. Path를 설정 합니다.
- config.pro 파일에 search_path_file 추가 합니다. 아래 예시를 참고 합니다.
예제 ) search_path_file c:\ptc\creo_stds\configs\std_search.pro
- std_search.pro 파일 안에 아래 예시와 같이 추가 합니다
예제 ) c:\ptc\creo_stds\std_library\screw
c:\ptc\creo_stds\std_library\bolt
c:\ptc\creo_stds\std_library\nut
3. 엑셀 VBA 프로그 이용하여 라이브러리 구축 하기
PC 서버에 공유 폴더를 구축 하고, > Creo 파일이 저장 될 폴더들을 만듭니다. > Creo에서 폴더들을 인식 할수 있도록 Config.pro 파일을 구성 하였습니다.
설계자가 쉽게 검색하여 라이브러리를 어셈블 모드에서 사용 할수 있도록 만들어야 합니다.
1) 탭을 복사하여 새로운 라이브러리 카테고리를 만듭니다. 구분자 Maker, Size, Length, DIA . . .등을 변경 할수 있습니다.
탭 이름은 라이브러리 카테고리 이름입니다. 대문자를 사용 하십시요
2) 라이브러리 구성 하기
- Parameter List 탭을선택 합니다
. Folder Select : 라이브러리 파일이 있는 폴더를 선택 합니다.
. New (Part) : 라이브러리 폴더에 있는 모든 "PRT" 파일일 표시됩니다
. Jpg : 이미지 파일일 생성 됩니다
. send : 입력된 Sheet 탭에 이미지와 함께, 파일 이름이 표시 됩니다.
. Clear : 데이터 영역이 제거 됩니다.
* 어셈블 입력 및 Parameter 입력, 표시 기능 버튼은 추가 하지 않았습니다.
추가는 가능 합니다. 메일 주십시요 lionkk@idt21c.com
4. 동영상
코드 - 선택한 Cell 의 파일 이름으로 어셈블 하기
Sub CreoFileassy()
Application.EnableEvents = False
Call Creo_Connect
On Error GoTo RunError
Dim oAssembly As IpfcAssembly
Dim oAsmcomp As IpfcComponentFeat
Dim oCreoFileName As String
If oModel Is Nothing Then
MsgBox "Open The Assemble File", vbInformation, "www.idt21c.com"
ElseIf oModel.Type <> 0 Then
MsgBox "Open The Assemble File", vbInformation, "www.idt21c.com"
Else
Dim oCreateModelDescriptor As New CCpfcModelDescriptor
Dim oModelDescriptor As IpfcModelDescriptor
'// cells Selecte File Open
oCreoFileName = Selection.Value
Set oModelDescriptor = oCreateModelDescriptor.CreateFromFileName(oCreoFileName)
Set oSolid = oSession.RetrieveModel(oModelDescriptor) '// Session으로 모델 불러오기
Set oAssembly = oModel
Set oAsmcomp = oAssembly.AssembleComponent(oSolid, Nothing)
oAsmcomp.RedefineThroughUI
End If
conn.Disconnect (2)
'Cleanup
Set asynconn = Nothing
Set conn = Nothing
Set oSession = Nothing
Set oModel = Nothing
RunError:
If Err.Number <> 0 Then
MsgBox "Process Failed : Unknown error occurred." + Chr(13) + _
"Error No: " + CStr(Err.Number) + Chr(13) + _
"Error: " + Err.Description, vbCritical, "Error"
If Not conn Is Nothing Then
If conn.IsRunning Then
conn.Disconnect (2)
End If
End If
End If
End Sub
코드 - 선택한 Cell 의 파일 이름 open 하기
Sub CreoFileOpen()
Application.EnableEvents = False
Call Creo_Connect
On Error GoTo RunError
Dim owindow As IpfcWindow
Dim oCreoFileName As String
Dim oCreateModelDescriptor As New CCpfcModelDescriptor
Dim oModelDescriptor As IpfcModelDescriptor
'// cells Selecte File Open
oCreoFileName = Selection.Value
Set oModelDescriptor = oCreateModelDescriptor.CreateFromFileName(oCreoFileName)
Set owindow = oSession.OpenFile(oModelDescriptor) '// Window로 모델 불러오기
owindow.Activate
conn.Disconnect (2)
'Cleanup
Set asynconn = Nothing
Set conn = Nothing
Set oSession = Nothing
Set oModel = Nothing
RunError:
If Err.Number <> 0 Then
MsgBox "Process Failed : Unknown error occurred." + Chr(13) + _
"Error No: " + CStr(Err.Number) + Chr(13) + _
"Error: " + Err.Description, vbCritical, "Error"
If Not conn Is Nothing Then
If conn.IsRunning Then
conn.Disconnect (2)
End If
End If
End If
End Sub
폴더 선택 하기
Sub selectFolder()
With Application.FileDialog(msoFileDialogFolderPicker)
.Show
Worksheets("Parameter List").Cells(6, "E") = .SelectedItems(1)
End With
End Sub
하드디스에서 모델을 불러 이미지 만들기
- 디스크에서 session으로 > Window로 표시
Sub jpgexport()
Application.EnableEvents = False
Call Creo_Connect
'// Workfolder change
oSession.ChangeDirectory (Cells(6, "E"))
On Error GoTo RunError
'// Back Ground Color White
Dim BackgroundWhitemacro As String
BackgroundWhitemacro = "al_screen_cap @MAPKEY_LABEL스크린 샷을 찍기위해서 흰배경으로 변경;\mapkey(continued) ~ Select `main_dlg_cur` `appl_casc`;~ Close `main_dlg_cur` `appl_casc`;\mapkey(continued) ~ Command `ProCmdRibbonOptionsDlg` ;\mapkey(continued) ~ Select `ribbon_options_dialog` `PageSwitcherPageList` 1 `colors_layouts`;\mapkey(continued) ~ Open `ribbon_options_dialog` `colors_layouts.Color_scheme_optMenu`;\mapkey(continued) ~ Close `ribbon_options_dialog` `colors_layouts.Color_scheme_optMenu`;\mapkey(continued) ~ Select `ribbon_options_dialog` `colors_layouts.Color_scheme_optMenu` 1 `2`;\mapkey(continued) ~ Activate `ribbon_options_dialog` `OkPshBtn`;\mapkey(continued) ~ Command `ProCmdViewSpinCntr` 0;nCntr` 0;"
oSession.RunMacro (BackgroundWhitemacro)
Call oSession.SetConfigOption("display_planes", "no")
Call oSession.SetConfigOption("display_axes", "no")
Call oSession.SetConfigOption("display_coord_sys", "no")
Call oSession.SetConfigOption("display_points", "no")
Call oSession.SetConfigOption("display_annotations", "no")
Call oSession.SetConfigOption("display", "shadewithedges")
'// sheet scale
ActiveWindow.Zoom = 100
Application.ScreenUpdating = True
'// jpg 변환 옵션변수 정의
Dim rasterHeight As Double: rasterHeight = 22
Dim rasterWidth As Double: rasterWidth = 17
Dim JPEGImageExportCreate As New CCpfcJPEGImageExportInstructions
Dim oJPEGExport As IpfcJPEGImageExportInstructions
Set oJPEGExport = JPEGImageExportCreate.Create(rasterHeight, rasterWidth)
Dim instructions As IpfcRasterImageExportInstructions
Set instructions = oJPEGExport
Dim oJpgfoldername As String: oJpgfoldername = Worksheets("DATA").Cells(3, "B") '// jpg Location
instructions.DotsPerInch = EpfcDotsPerInch.EpfcRASTERDPI_100
instructions.ImageDepth = EpfcRasterDepth.EpfcRASTERDEPTH_8
'// Part list 파일 개수
Dim rng As Range: Set rng = Range("A10", Cells(rows.Count, "A").End(xlUp))
Dim oModelDescriptorCreate As New CCpfcModelDescriptor
Dim oModelDescriptor As IpfcModelDescriptor
Dim owindow As IpfcWindow
Dim i As Integer
Dim oCreoFileName As String
Dim str2, ret As String
Dim Pic As Variant
Dim Imagecell As Range
Dim oFailedFeatures As IpfcFeatures
For i = 0 To rng.Count - 1
oCreoFileName = Cells(i + 10, "D")
Set oModelDescriptor = oModelDescriptorCreate.CreateFromFileName(oCreoFileName)
Set oModel = oSession.RetrieveModel(oModelDescriptor)
Set owindow = oSession.OpenFile(oModelDescriptor)
owindow.Activate
' // jpg View Name
Dim oViewOwner As IpfcViewOwner: Set oViewOwner = oSession.CurrentModel
Dim oIpfcView As IpfcView: Set oIpfcView = oViewOwner.RetrieveView("ISOVIEW")
If oIpfcView Is Nothing Then
Set oIpfcView = oViewOwner.RetrieveView("default")
End If
Dim oJpgFileName As String: oJpgFileName = oModel.InstanceName & ".JPG"
'// jpg image location
oSession.ChangeDirectory (oJpgfoldername)
'// jpg image 변환 실행
Call owindow.ExportRasterImage(oJpgFileName, instructions)
owindow.Close
'//****************************************************************************************
'// jpg image Insert
'//****************************************************************************************
str2 = oJpgfoldername & "\" & oJpgFileName
ret = Dir(str2)
If ret <> "" Then
Set Pic = ActiveSheet.Pictures.Insert(str2)
Set Imagecell = Cells(i + 10, "B")
Cells(i + 10, "B").RowHeight = 60
With Pic
.ShapeRange.LockAspectRatio = msoFalse
.Left = Imagecell.Left + 5
.Top = Imagecell.Top + 5
.Width = Imagecell.Width - 5
.Height = Imagecell.Height - 5
End With
End If
oSession.ChangeDirectory (Cells(6, "E"))
Next i
'// Workfolder change
oSession.ChangeDirectory (Cells(6, "E"))
MsgBox ("JPG 변환 : " & rng.Count & " 개를 완료 하였습니다"), vbInformation, "www.idt21c.com"
'Disconnect with Creo
conn.Disconnect (2)
'Cleanup
Set asynconn = Nothing
Set conn = Nothing
Set oSession = Nothing
Set oModel = Nothing
Exit Sub
RunError:
If Err.Number <> 0 Then
MsgBox "Process Failed : Unknown error occurred." + Chr(13) + _
"Error No: " + CStr(Err.Number) + Chr(13) + _
"Error: " + Err.Description, vbCritical, "Error"
If Not conn Is Nothing Then
If conn.IsRunning Then
conn.Disconnect (2)
End If
End If
End If
End Sub
다른 worksheet로 데이터 보내기
Sub CellSend()
'// WorkSheet Name
Dim oWsName As String
oWsName = Cells(7, "D")
Dim rng As Range
Set rng = Range("D10", Cells(rows.Count, "D").End(xlUp))
Dim oJpgFileName As String, str2 As String, ret As String
Dim Pic As Variant
Dim Imagecell As Range
Dim oJpgfoldername As String
oJpgfoldername = Worksheets("DATA").Cells(3, "B")
'// Worksheets(oWsName).Activate
Dim i As Integer
For i = 0 To rng.Count - 1
Worksheets(oWsName).Cells(i + 8, "A") = i + 1
Worksheets(oWsName).Cells(i + 8, "C") = Worksheets("Parameter List").Cells(i + 10, "D")
oJpgFileName = Worksheets("Parameter List").Cells(i + 10, "D")
oJpgFileName = Replace(oJpgFileName, "prt", "jpg")
'//****************************************************************************************
'// jpg image Insert
'//****************************************************************************************
str2 = oJpgfoldername & "\" & oJpgFileName
ret = Dir(str2)
If ret <> "" Then
Set Pic = Worksheets(oWsName).Pictures.Insert(str2)
Set Imagecell = Worksheets(oWsName).Cells(i + 8, "B")
Worksheets(oWsName).Cells(i + 8, "B").RowHeight = 60
With Pic
.ShapeRange.LockAspectRatio = msoFalse
.Left = Imagecell.Left + 5
.Top = Imagecell.Top + 5
.Width = Imagecell.Width - 5
.Height = Imagecell.Height - 5
End With
End If
Next i
Worksheets("Parameter List").Activate
MsgBox ("Sheet > " & oWsName & " 전송 완료"), vbInformation, "www.idt21c.com"
End Sub
위코드 일부는 인공지능 ChatGPT를 이용하여 코드를 만들었습니다
by lionkk@idt21c.com
'VBA For Creo' 카테고리의 다른 글
To : Jonny Stocco (0) | 2023.03.15 |
---|---|
ChatGPT - CREO UDF 파일 불러오기 (0) | 2023.02.21 |
부품 정보 리스트 프로그램 (0) | 2023.02.14 |
도면이 가지고 있는 치수 값을 가지고 오기 #1 (0) | 2023.02.14 |
모델이 가지고 있는 치수 값을 가지고 오기 - 두번째 (0) | 2023.02.11 |