Solid DXF

'Solid DXF

Dim swApp As SldWorks.SldWorks
Dim Model As ModelDoc2
Dim DTable As DesignTable
Dim WS_OBJ As Excel.Worksheet
Dim part As Object
Dim SelMgr As Object
Dim NR_View As Byte


Sub MODEL_SUB(ByVal NFD As String, ByVal ACTACT As Byte)
ACT_MOD = INFO_DAT(NFD, 0, 6)

Set swApp = CreateObject("SldWorks.Application")
swApp.Visible = False

Set part = swApp.OpenDoc6(SLD_PTH & Left(INFO_DAT(NFD, 0, 6), 10) & INFO_DAT(NFD, 0, 9) & ".SLDPRT", 1, 0, "", 0, 0) 'AGGIUNTA REVISIONE
Select Case swApp.ActiveDoc.Extension.HasDesignTable()
Case True
Case False
MsgBox "THIS FILE DO NOT CONTAINS ANY TABLE DESIGN", vbCritical
Exit Sub
End Select
Set Model = swApp.ActiveDoc
filePth = Model.GetPathName

STR_FNAME = Right(filePth, InStr(1, StrReverse(filePth), "\", vbBinaryCompare) - 1)

Set DTable = Model.GetDesignTable
GET_ERR = swApp.GetErrorMessages(vMsgs, vMsgIds, vMsgTypes) 'RESETTA LO STACK MESSAGGI

isGood = DTable.Attach
If isGood = False Then
MsgBox "Table attachment failed", vbCritical
Exit Sub
End If

Set WS_OBJ = DTable.Worksheet
Call TAB_EDT(NFD)
Call MOD_CHECK(NFD)

VVVV = Replace(INFO_DAT(NFD, 0, 7), "H", "")
VVVV = Replace(VVVV, "G", "")
VVVV = Replace(VVVV, "P", "")
VVVV = Val(VVVV)

 VW = VW_SET(VVVV)
 RW = DTable.Worksheet.Range("VW_ROT", "VW_ROT").Value
 MD = INFO_DAT(NFD, 0, 9)

For i = 1 To 100
If InStr(1, INFO_DAT(NFD, 1, i), "MOD", vbTextCompare) > 0 Then
REV_ON_DAT = INFO_DAT(NFD, 2, i)
Exit For
End If
Next i

If MD <> REV_ON_DAT Then MsgBox "ATTENZIONE: INDICE DI REVISIONE ERRATO SU MODELLO " & INFO_VAR(0, 0), vbCritical
    DTable.UpdateModel
    DTable.Detach
GET_ERROR = swApp.GetErrorMessages(vMsgs, vMsgIds, vMsgTypes)
If GET_ERROR > 0 Then INFO_DAT(NFD, 0, 20) = ERR_TRAPP(GET_ERROR, vMsgs, vMsgIds, vMsgTypes) Else INFO_DAT(NFD, 0, 20) = ""

Call SUB_DXF(NFD, VW, RW, ACTACT)

Erase INFO_VAR
NR_View = Empty

Set part = swApp.ActiveDoc
Set SelMgr = part.SelectionManager
Set part = Nothing
swApp.CloseDoc STR_FNAME
'swApp.ExitApp


RRR:


End Sub

Sub TAB_EDT(ByVal NFG As Integer)
Set DTable = part.GetDesignTable
If DTable.Attach = False Then
MsgBox "Table attachment failed", vbCritical
Exit Sub
End If

On Error GoTo ERR_LBL
VARCOUNT = 0
TAB_NAM = ActiveWorkbook.Name
For Each NAMS In Workbooks(TAB_NAM).Names
If InStr(1, NAMS.Name, "VAR_", vbBinaryCompare) Then
DTable.Worksheet.Range(NAMS.Name, NAMS.Name).Value = 0
VARCOUNT = VARCOUNT + 1
End If
Next NAMS

For i = 1 To 100
LAB = Replace(INFO_DAT(NFG, 1, i), ".", "")
VLR = INFO_DAT(NFG, 2, i)

If InStr(1, LAB, "VER", vbBinaryCompare) > 0 Then
VLR = Replace(VLR, "H", "")
VLR = Replace(VLR, "G", "")
VLR = Replace(VLR, "P", "")
VLR = Val(VLR)
End If

For Each NAMS In Workbooks(TAB_NAM).Names
If InStr(1, NAMS.Name, ".", vbBinaryCompare) > 0 Then MsgBox "ERRORE ETICHETTA SU TABELLA " & swApp.ActiveDoc
If NAMS.Name = "VAR_" & LAB Then
DTable.Worksheet.Range("VAR_" & LAB, "VAR_" & LAB).Value = VLR
VARWRITE = VARWRITE + 1
End If
Next NAMS
Next i

DTable.UpdateModel
DTable.Detach
GoTo ENDSUB
ERR_LBL:
MsgBox "ERRORE SU TABELLA " & INFO_DAT(NFG, 0, 6)
ENDSUB:
End Sub

Sub SUB_DXF(ByVal NFG As Integer, ByVal V_VIEW As Byte, ByVal R_VIEW As Double, ByVal ACTACT As Byte)

Dim boolstatus As Boolean
Dim longstatus As Long, longwarnings As Long
Dim Feature As Object
Dim filePth As String
Dim DrawWiew As Object
Dim sVWiew  As SldWorks.View

Set swModel = swApp.ActiveDoc
Set part = swApp.ActiveDoc
Set SelMgr = part.SelectionManager

filePth = swModel.GetPathName
drvVal = Left(filePth, 1)
lenext = InStr(1, StrReverse(filePth), "\", vbBinaryCompare) - 1
fileName = Left(Right(filePth, lenext), Len(Right(filePth, lenext)) - InStr(1, StrReverse(Right(filePth, lenext)), ".", vbBinaryCompare))

part.SetBendState 2
boolstatus = part.EditRebuild3

'Set part = swApp.OpenDoc6("\\NT1\TEP-VAULT\SWP\WitturETODrawing.DRWDOT", 3, 0, "", longstatus, longwarnings)
Set part = swApp.OpenDoc6("\\nt1\UFFTEP\3D_parametrizzati\SWP\WitturETODrawing.DRWDOT", 3, 0, "", longstatus, longwarnings)
Set DrawWiew = part.CreateDrawViewFromModelView2(filePth, VDS(V_VIEW), 0, 0, 0)

boolstatus = part.Extension.SelectByID2(NAME_VW, "DRAWINGVIEW", 0, 0, 0, False, 0, Nothing, 0)
boolstatus = part.DrawingViewRotate(R_VIEW / 57.29578)   'TO ROTATE VIEW

    Set swModel = swApp.ActiveDoc
    Set swSelMgr = swModel.SelectionManager
    Set swModelDocExt = swModel.Extension

 Call DRW_CLR(1)


If ACTACT = 1 Then
If Application.UserName = "Galloni A." Or Application.UserName = "Sassi, Samuele (Wittur Italy)" Or Application.UserName = "Armencea, Decebal (Wittur Italy)" Then
part.SaveAs2 OUTPUT_FOLDER & INFO_DAT(NFG, 0, 16) & ".DXF", 0, True, False 'NOME CON CUI SI SALVA IL DXF
Else
part.SaveAs2 DXF_CFOLD & INFO_DAT(NFG, 0, 16) & ".DXF", 0, True, False 'NOME CON CUI SI SALVA IL DXF
End If
End If
If ACTACT = 2 Then part.SaveAs2 OUTPUT_FOLDER & INFO_DAT(NFG, 0, 16) & ".DXF", 0, True, False


Set part = swApp.ActiveDoc
Set SelMgr = part.SelectionManager
Set part = Nothing
swApp.CloseDoc swApp.ActiveDoc.GetTitle
Set part = swApp.ActivateDoc2(filePth, False, longstatus)

part.SetBendState 3
boolstatus = part.EditRebuild3


End Sub


Function VDS(ByVal NVIEW As Byte) As String

LNG = UCase(swApp.GetCurrentLanguage)

Select Case LNG
Case "ENGLISH"
 CLang = 1
Case "ITALIANO", "ITALIAN"
 CLang = 2
Case Else
MsgBox "Errore su linguaggio", vbCritical
End Select

Select Case NVIEW
Case 1
  If CLang = 1 Then VDS = "*Top"
  If CLang = 2 Then VDS = "*Superiore"
Case 2
  If CLang = 1 Then VDS = "*Bottom"
  If CLang = 2 Then VDS = "*Inferiore"
Case 3
  If CLang = 1 Then VDS = "*Right"
  If CLang = 2 Then VDS = "*Destra"
Case 4
  If CLang = 1 Then VDS = "*Left"
  If CLang = 2 Then VDS = "*Sinistra"
Case 5
  If CLang = 1 Then VDS = "*Front"
  If CLang = 2 Then VDS = "*Frontale"
End Select


End Function


Function NAME_VW() As String

    Dim swModel                 As SldWorks.ModelDoc2
    Dim swDraw                  As SldWorks.DrawingDoc
    Dim swSheet                 As SldWorks.Sheet
    Dim sVWiew                  As SldWorks.View

    Set swModel = swApp.ActiveDoc
    Set swDraw = swModel
    Set sVWiew = swDraw.GetFirstView
    Set sVWiew = sVWiew.GetNextView

    NAME_VW = sVWiew.GetName2

If NAME_VW <> "" Then Else MsgBox "NESSUNA VISTA CARICATA", vbCritical


End Function


Function VW_SET(ByVal NV As String) As Byte

NV = Replace(NV, "G", "")
NV = Replace(NV, "H", "")

On Error Resume Next
VW_SET = 99
NVR = Val(Trim(NV))

VW_SET = DTable.Worksheet.Range("VW_00", "VW_00").Value
If VW_SET = 99 Then


Select Case NVR
Case 1, 3
VW_SET = DTable.Worksheet.Range("VW_01", "VW_01").Value
Case 2, 4
VW_SET = DTable.Worksheet.Range("VW_02", "VW_02").Value
End Select
End If

End Function






Sub DRW_CLR(ByVal ZSD As Byte)

Set swDraw = swApp.ActiveDoc
Set swSheet = swDraw.GetCurrentSheet
Set swView = swDraw.GetFirstView
Set swView = swView.GetNextView
Set swAnn = swView.GetFirstAnnotation
Do While Not Nothing Is swAnn
swAnn.Visible = 3
Set swAnn = swAnn.GetNext3
Loop

Set part = swApp.ActiveDoc
Set SelMgr = part.SelectionManager
boolstatus = part.SetUserPreferenceToggle(196, False)

End Sub


Sub MOD_CHECK(ByVal NFG As Integer)

On Error GoTo ERR
INFO_VAR(0, 1) = DTable.Worksheet.Range("REV_IND", "REV_IND").Value
GoTo ENDFUNCT
ERR:
MsgBox "ATTENZIONE: NON RILEVATO INDICE DI REVISIONE SU MODELLO " & INFO_DAT(NFG, 0, 0)
ENDFUNCT:

End Sub


Function ERR_TRAPP(Count, vMsgs As Variant, vMsgIds As Variant, vMsgTypes As Variant) As String
ERR_STR = ""
For i = 0 To (Count - 1)
ERR_STR = ERR_STR & " " & vMsgs(i)
Next i
ERR_STR = Replace(ERR_STR, Chr(13), "")
ERR_TRAPP = Trim(Replace(ERR_STR, "Avvertenza: ", ""))

End Function