Public Sub DO_JPG()
'VARS
Dim InvDocs As Document
Dim Invdocument As Document
Dim oAsmDoc As AssemblyDocument
Dim oPrtDoc As PartDocument
Dim Nummer As Property
Dim Status As Property
Dim zaehler As Integer
Dim counter As Integer
Dim File As String
Dim nonumberdir As String
Dim nostatusdir As String
'****************
 ' Specify the size of the output image in pixels.  If you
    ' use zero then it will be the actual size of the window.
    Dim pixelWidth As Integer
    Dim pixelHeight As Integer
    pixelWidth = 200
    pixelHeight = 200
    ' Specify the path where the files exist.  The rest of the
    ' code expects this path name to end with a backslash.
    Dim dirName As String
    dirName = "C:\Temp\caddetest\"
    Dim actdirname As String
 'VARS
File = Filename(ThisApplication.ActiveDocument.fullFilename)
On Error Resume Next
dirName = dirName & Format(Now(), "YYYYMMDDhhmmss") & "_" & File & "\"
MkDir dirName
nonumberdir = dirName & "NO_STOCK_NUMBER\"
MkDir nonumberdir
nostatusdir = dirName & "NO_STATUS_DESCRIPTION\"
MkDir nostatusdir
On Error GoTo 0
ThisApplication.SilentOperation = True
ThisApplication.UserInterfaceManager.UserInteractionDisabled = True

Set Invdocument = ThisApplication.ActiveDocument

If Invdocument.DocumentType = kAssemblyDocumentObject Then
Set oAsmDoc = ThisApplication.ActiveDocument
 ' Get all of the referenced documents.
    Dim oRefDocs As DocumentsEnumerator
    Set oRefDocs = oAsmDoc.AllReferencedDocuments
    ' Iterate through the list of documents.
    Dim oRefDoc As Document
    For Each oRefDoc In oRefDocs
        Set doc = ThisApplication.Documents.Open(oRefDoc.fullFilename)
        
        File = Filename(ThisApplication.ActiveDocument.fullFilename)
              
        Set Nummer = doc.PropertySets.Item("Design Tracking Properties").Item("Stock Number")
        Set Status = doc.PropertySets.Item("Design Tracking Properties").Item("Description")
               
       If Nummer.Value = "" Then
       
       actdirname = nonumberdir
        ElseIf Status.Value <> "" Then
       
       actdirname = nostatusdir
       Else
       actdirname = dirName
       End If
           
        savejpg pixelWidth, pixelHeight, actdirname, File
        ' Close the current document.
        Call doc.Close(True)
    Next
Else
Set doc = ThisApplication.ActiveDocument
  File = Filename(ThisApplication.ActiveDocument.fullFilename)
        ThisApplication.ActiveDocument.ObjectVisibility.AllWorkFeatures = False
        ThisApplication.ActiveView.Update
               
        Set Nummer = doc.PropertySets.Item("Design Tracking Properties").Item("Stock Number")
        Set Status = doc.PropertySets.Item("Design Tracking Properties").Item("Description")
        
     If Nummer.Value = "" Then
       
       actdirname = nonumberdir
        ElseIf Status.Value <> "" Then
       
       actdirname = nostatusdir
       Else
       actdirname = dirName
       End If
                 
        savejpg pixelWidth, pixelHeight, actdirname, File
End If

ThisApplication.UserInterfaceManager.UserInteractionDisabled = False
Invdocument.Save2 True
ThisApplication.SilentOperation = False
End Sub

Function savejpg(w As Integer, h As Integer, dirName As String, name As String)
Dim window As View
Set window = ThisApplication.ActiveView
window.DisplayMode = kShadedRendering
window.ShowAmbientShadows = True
window.ShowGroundShadows = True
window.ShowObjectShadows = True

ThisApplication.ActiveView.GoHome
On Error Resume Next
ThisApplication.ActiveDocument.ObjectVisibility.AllWorkFeatures = False
On Error GoTo 0
window.Fit True
window.Update
ThisApplication.ActiveDocument.SetThumbnailSaveOption (kActiveComponentIsoViewOnSave)
ThisApplication.ActiveDocument.Save

Dim imageFilename As String
        'imageFilename = dirName & _
         '               Left$(name, InStr(name, ".")) & "jpg"
        imageFilename = dirName & name & ".jpg"
        Call window.SaveAsBitmap(imageFilename, w, h)
window.DisplayMode = kShadedWithEdgesRendering
End Function

Function Filename(ByVal fullFilename As String) As String
    ' Extract the filename by getting everything to
    ' the right of the last backslash.
     Filename = Right$(fullFilename, Len(fullFilename) - InStrRev(fullFilename, "\"))
End Function