Option Explicit
Dim swApp                  As SldWorks.SldWorks
Dim swModel                As SldWorks.ModelDoc2
Dim vConfNameArr          As Variant
Dim sConfigName            As String
Dim sRenderFileName        As String
Dim i                      As Long
Dim bShowConfig            As Boolean
Dim bRebuild              As Boolean
Dim bRet                  As Boolean
Dim pwPhotoWorks          As PhotoWorks.PhotoWorks
Dim pwOpt                  As PhotoWorks.PwOptions
Dim filename             As String



Sub main()
    Set swApp = CreateObject("SldWorks.Application")
    Set swModel = swApp.ActiveDoc
    Set pwPhotoWorks = swApp.GetAddInObject("PhotoWorks.PhotoWorks")
    Set pwOpt = pwPhotoWorks.PwOptions
    
    'Rendereigenschaften
    pwPhotoWorks.RenderFileFormat = 5 '5 fuer tif
    pwPhotoWorks.RenderFileUnits = 0 '0 fuer Pixels
    pwPhotoWorks.RenderFileHeight = 45
    pwPhotoWorks.RenderFileWidth = 60
   
    vConfNameArr = swModel.GetConfigurationNames
    filename = GetFilenNameNoExtension(swModel.GetPathName)
   
    'Alle Konfis durchlaufen
    For i = 0 To UBound(vConfNameArr)
        sConfigName = vConfNameArr(i)
        bShowConfig = swModel.ShowConfiguration2(sConfigName)
        bRebuild = swModel.ForceRebuild3(False)
        swModel.GraphicsRedraw2
        
        'Pfad für Bilder
        'Achtung: schon vorhandene Bilder mit gleichem Dateinamen
        'werden ohne Rückfrage überschrieben!!!
        'Pfad muß vorhanden sein, sonst kein Rendern
                
        sRenderFileName = "C:\temp\SWX_Render\" & filename & "_" & sConfigName & ".tif"
       
        pwPhotoWorks.RenderFilename = sRenderFileName
        pwPhotoWorks.RenderToFile (True)
    Next i
End Sub


Private Function GetFilenNameNoExtension(strPath As String) As String
  '
  Dim intCounter As Integer
  Dim intCounter2 As Integer
  Dim strTmp As String

  ' Pfad abtrennen
  For intCounter = Len(strPath) To 1 Step -1
    ' It its a slash, grab the sub string
    If Mid$(strPath, intCounter, 1) <> "\" Then
      strTmp = Mid$(strPath, intCounter, 1) & strTmp
    Else
      Exit For
    End If
  Next intCounter
  
  ' und die Extension abtrennen
  For intCounter2 = Len(strTmp) To 1 Step -1
    If Mid$(strTmp, intCounter2, 1) = "." Then
      Exit For
    End If
  Next intCounter2

  ' und den Wert zurückgeben
  GetFilenNameNoExtension = Left$(strTmp, intCounter2 - 1)

End Function