Сделай свою работу в Solidworks эффективнее

[vasyam 483]

В 03.11.2019 в 14:25, CTAHICJIAB сказал:

Добрый день всем. Возникла такая проблема при попытке перенести все макросы с SW2017 на SW2019. Не подтягивается толщина листа из ГеОСа на чертеж. Как я понял виной всему лишняя @.Может кто поможет или подскажет тему где почитать. Скрин для понимания ниже.

 

 

  Показать содержимое

 

Скачайте новую версию ГЕОСа

 

[Kir95 951]

Макрос, показывает сложность геометрии детали (количество треугольников) в левом углу строки состояния.

Скрытый текст

Option Explicit

Dim swApp           As SldWorks.SldWorks
Dim swModel         As SldWorks.ModelDoc2 'PartDoc
Dim swModelDocExt   As SldWorks.ModelDocExtension
Dim value           As Long

Sub main()

Set swApp = Application.SldWorks
Set swModel = swApp.ActiveDoc
Set swModelDocExt = swModel.Extension


If swModel.GetType <> swDocPART Then
    MsgBox "Откройте деталь."
    Exit Sub
End If

value = swModel.GetTessTriangleCount()
'Debug.Print value
swModelDocExt.ShowSmartMessage "Количество треугольников - " & value, 5000, True, True
End Sub

 

Сложность геометрии регулируется в свойствах документа -> качество изображения (меню "инструменты")

[Kir95 951]

Ещё один макрос для производительности, меняет в свойствах документа качество изображения попеременно на низкое или высокое (но не максимальное). Экономит 5 кликов мышью, как минимум (Инструменты->Параметры->Свойства документа->Качество изображения)

 

Скрытый текст

'https://forum.solidworks.com/thread/235630

'Макрос попеременно меняет настройки качества изображения модели с низкого на высокое
'Инструменты->Параметры->Свойства документа->Качество изображения
Option Explicit
Dim swApp       As SldWorks.SldWorks
Dim swDoc       As SldWorks.ModelDoc2
Dim swDocExt    As SldWorks.ModelDocExtension
Dim CurVal      As Double
Dim MaxVal      As Double
Dim MinVal      As Double
Dim message     As String

Sub main()
 Set swApp = Application.SldWorks
 Set swDoc = swApp.ActiveDoc
 Set swDocExt = swDoc.Extension
 swDoc.Extension.GetUserPreferenceDoubleValueRange swImageQualityShadedDeviation, CurVal, MinVal, MaxVal
 
 If CurVal <> MinVal And CurVal > MinVal Then
    swDoc.SetUserPreferenceToggle swImageQualityApplyToAllReferencedPartDoc, True
    swDoc.SetUserPreferenceDoubleValue swImageQualityShadedDeviation, MinVal
    swDoc.SetUserPreferenceIntegerValue swImageQualityWireframeValue, 100
    message = "ВЫСОКОГО"
 Else
    swDoc.SetUserPreferenceToggle swImageQualityApplyToAllReferencedPartDoc, True
    swDoc.SetUserPreferenceDoubleValue swImageQualityShadedDeviation, MaxVal
    swDoc.SetUserPreferenceIntegerValue swImageQualityWireframeValue, 1
    message = "НИЗКОГО"
 End If
 If MsgBox("Переключиться на отображение без кромок?" & vbCrLf & vbCrLf & _
        "Режим без кромок увеличивает производительность, особенно в больших сборках.", vbYesNo, _
        "Включен режим " & message & " качества отображения.") = vbYes Then
    swDoc.ViewDisplayShaded
 End If
 
End Sub

 

Оригинал взят отсюда, там побольше настроек 

https://forum.solidworks.com/thread/235630

 

Изменено 9 ноября 2019 пользователем Kir95

[Wolfi 3]

Уважаемые подскажите может у кого есть макрос по именованию видов в чертеже? Всп. и мест. видов с разрезами перевалило за 20 лихом штук и добавится еще. Эта обезьянья работа постоянно переименовывать их в ручную начиная все с начала при каждом добавлении нового вида уже выбешивает.

[tulibay 74]

1 час назад, Wolfi сказал:

макрос по именованию видов в чертеже

 

[DuS 328]

16 минут назад, tulibay сказал:

 

не получается повесить его на кнопку - ругается что не выбрана процедура...

зы цепляю replacelabelview.dll

[Kelny 1 333]

2 часа назад, Wolfi сказал:

Эта обезьянья работа постоянно переименовывать их в ручную начиная все с начала при каждом добавлении нового вида уже выбешивает.

Делайте новые виды под следующей буквой, не придётся всё перелапачивать с нуля.

 

2 часа назад, Wolfi сказал:

есть макрос по именованию видов в чертеже? Всп. и мест. видов с разрезами перевалило за 20 лихом штук и добавится еще.

Поаккуратнее с переименованием, делайте резервную копию перед переименованием. Как-то после переименования множества видов, правда вручную, после сохранения чертёж перестал открываться вовсе в текущей версии (причём проблема была повторяемой, поднимаешь рабочую резервную копию, переименовываешь виды и снова получаешь мёртвый файл). Путём экспериментов испорченный файл удалось открыть лишь в будущей версии программы.

Изменено 13 ноября 2019 пользователем Kelny

[tulibay 74]

@DuS автор @Shvg может выкладывал другую версию. У меня работает.LabelView.zip

[Kelny 1 333]

30 минут назад, DuS сказал:

не получается повесить его на кнопку - ругается что не выбрана процедура...

зы цепляю replacelabelview.dll

Если напрямую не получается, то можно попробовать по аналогии с запуском сторонних приложений через макрос, только в качестве стороннего приложения выбирать нужную вам DLL с макросом.

Пример, имя макроса запуска должно совпадать с файлом DLL (или EXE, то в коде надо заменить dll на exe):

Цитата

Dim Sourrce As String
Dim swApp As Object
Sub main()
Set swApp = Application.SldWorks
' Run the custom property application
Source = swApp.GetCurrentMacroPathName             ' Get macro path+filename
Source = Left$(Source, Len(Source) - 3) + "dll"    ' Set source filename
MyAppID = Shell(Source, 1)
End Sub

Или просто вписывается путь до нужного файла. Пример запуска блокнота:

Цитата

Dim Sourrce As String
Dim swApp As Object
Sub main()
Set swApp = Application.SldWorks
' Run the custom property application
Source = "C:\Windows\notepad.exe"             ' path+filename
MyAppID = Shell(Source, 1)
End Sub

 

Изменено 13 ноября 2019 пользователем Kelny

[Wolfi 3]

В 13.11.2019 в 14:06, tulibay сказал:

У меня работает.LabelView.zip

Можешь подсказать как именно работает LabelView в плане порядка именования видов. По мне какая-то дичь в наименованиях происходит.

У меня на чертеже есть два вспомогательных вида, куча разрезов и местных видов. Я так понял вспомогательные виды он пропускает и их надо вручную, т.е. первые две буквы А и Б он оставляет для этих видов и начинает именовать остальные с буквы "В" раскидывая их как то по листам.

 

Изменено 18 ноября 2019 пользователем Wolfi

[tulibay 74]

@Wolfi Спросите у автора @Shvg. Меня и так устраивает, прога что-то делает, остальные вручную.

[Kir95 951]

Макрос показывает общую длину сегментов эскиза в мм и метрах, копирует значение в мм в буфер обмена

Скрытый текст

'----------------------------------------------------
'http://help.solidworks.com/2018/english/api/sldworksapi/Find_Total_Length_of_Sketch_Segments_in_Sketch_Example_VB.htm?verRedirect=1
 Option Explicit
Public Enum swSketchSegments_e
    swSketchLINE = 0
    swSketchARC = 1
    swSketchELLIPSE = 2
    swSketchSPLINE = 3
    swSketchTEXT = 4
    swSketchPARABOLA = 5
End Enum
Sub main()
    Dim swApp As SldWorks.SldWorks
    Dim swModel As SldWorks.ModelDoc2
    Dim swSelMgr As SldWorks.SelectionMgr
    Dim swFeat As SldWorks.Feature
    Dim swSketch As SldWorks.Sketch
    Dim i As Long
    Dim bRet As Boolean
    Dim vSketchSeg As Variant
    Dim swSketchSeg As SldWorks.SketchSegment
    Dim nLength As Double
    
    Dim obj As New DataObject
    Dim txt As String
    Dim txt2 As String

    Set swApp = CreateObject("SldWorks.Application")
    Set swModel = swApp.ActiveDoc
    Set swSelMgr = swModel.SelectionManager
    On Error GoTo Line

    Set swFeat = swSelMgr.GetSelectedObject6(1, -1)
    
    If swFeat Is Nothing Then
Line:
    MsgBox "Нужно выбрать эскиз в дереве проектирования."
    Exit Sub
    End If
    
    Set swSketch = swFeat.GetSpecificFeature2
    vSketchSeg = swSketch.GetSketchSegments
    For i = 0 To UBound(vSketchSeg)
        Set swSketchSeg = vSketchSeg(i)
        ' Ignore construction lines
        If swSketchSeg.ConstructionGeometry = False Then
            ' Ignore text
            If swSketchTEXT <> swSketchSeg.GetType Then
                nLength = nLength + swSketchSeg.GetLength
            End If
        End If
    Next i
    Debug.Print "File = " & swModel.GetPathName
    Debug.Print "  Sketch = " & swFeat.Name
    MsgBox "Наименование эскиза:" & vbCrLf & _
    "< " & swFeat.Name & " >" + vbCrLf + "Total length in mm = " & Format(nLength * 1000#, "00") & " mm" & vbCrLf & _
    "Total length in meters = " & Format(nLength, "0.000") & " m"
    
    'Put some text inside a string variable
  txt = Format(nLength * 1000#, "00") 'ResCount '"This was copied to the clipboard using VBA!"

'Make object's text equal above string variable
  obj.SetText txt

'Place DataObject's text into the Clipboard
  obj.PutInClipboard
  obj.GetFromClipboard
  txt2 = obj.GetText
  Debug.Print txt2 & " mm"

End Sub

 

 

Нужно добавить библиотеку, чтобы копировать значение можно было

Скрытый текст

 

 

Если добавить форму (Insert - UserForm), нужная библиотека добавится вместе с формой, форму потом удалить можно.

 

 

[Maik812 309]

Интересует макрос или программа которая пршерстит папку и в файлах свойствах поставит размеры основные. так сказать образмерит содержимое и запишет в свойствах детали.. потом можно будит искать нужную деталь по этому свойству или разгребать . Поиск по геометрии вопщем.

[Alex8007 27]

Добрый день, умные головы.

Подскажите, как макросом в чертеж вписать сегодняшнюю дату так, чтобы при следующем открытии она не изменялась.

Пробовал через $PRP:"SW-Short Date", к сожалению не подходит. Есть ли подходящая функция или может можно отвязать полученный текст от самой функции. Как бы сделать работу Short Date одноразовой.

 

[Kelny 1 333]

15 минут назад, Alex8007 сказал:

Подскажите, как макросом в чертеж вписать сегодняшнюю дату так, чтобы при следующем открытии она не изменялась.

Пробовал через $PRP:"SW-Short Date"

В этом случае не надо ни каких тегов, надо просто вписать текущую дату.

 

Например, в VBA:

Dim MyDate
MyDate = Date    ' MyDate contains the current system date.

 

 

 

[Alex8007 27]

5 часов назад, Kelny сказал:

В этом случае не надо ни каких тегов, надо просто вписать текущую дату.

Спасибо, получается, но не совсем: пишет 14-м шрифтом, хотя вроде назначил 7.

подскажите, как уменьшить шрифт и изменить цвет? ( в программировании я 1/∞)

Скрытый текст

 

Изменено 28 ноября 2019 пользователем Alex8007

[Kelny 1 333]

1 час назад, Alex8007 сказал:

подскажите, как уменьшить шрифт и изменить цвет?

 

Как-то так:

   Dim TextFormat As Object
   ' Now get the text formating
   Set TextFormat = myNote.GetTextFormat()

   ' Put the values into the TextFormat
   Debug.Print TextFormat.Bold
   Debug.Print TextFormat.Italic
   Debug.Print TextFormat.Underline
   Debug.Print TextFormat.Strikeout
   Debug.Print TextFormat.TypeFaceName

   If TextFormat.IsHeightSpecifiedInPts() Then 'Если задан размер в точках, вероятно можно не проверять и сразу задавать размер в точках или метрах
    TextFormat.CharHeightInPts = 7 'Размер в точках
   Else
    TextFormat.CharHeight = 0.007 'Размер в метрах, спрака говорит что в единицах документа
   End If

  ' Set the note formatting
   myNote.SetTextFormat 0, TextFormat
   Set Annotation = Note.GetAnnotation
   Annotation.Color = vbRed
'или внутри заметки:
'Note.PropertyLinkedText = "<FONT color=0x000000ff><FONT style=B>This is a test of formatting a note via the API"

http://help.solidworks.com/2010/english/api/sldworksapi/Get_Note_Text_Formatting_Properties_Example_VB.htm

 

[Alex8007 27]

15 часов назад, Kelny сказал:

Как-то так:

Спасибо, все получилось.

Может кому сгодиться текст макроса:

Вписать дату в чертеж

Скрытый текст

Dim swApp As Object

Dim Part As Object
Dim boolstatus As Boolean
Dim longstatus As Long, longwarnings As Long

Sub main()

Set swApp = _
Application.SldWorks

Set Part = swApp.ActiveDoc

Dim MyDate
Dim myNote As Object
Dim Annotation As Object
MyDate = Date
Set myNote = Part.InsertNote(MyDate)
'меняем формат и цвет:
  Dim TextFormat As Object
   ' Now get the text formating (Теперь получите форматирование текста)
    Set TextFormat = myNote.GetTextFormat()
    ' Put the values into the TextFormat (Поместите значения в TextFormat)
      Debug.Print TextFormat.Bold
      Debug.Print TextFormat.Italic
      Debug.Print TextFormat.Underline
      Debug.Print TextFormat.Strikeout
      Debug.Print TextFormat.TypeFaceName
      'If TextFormat.IsHeightSpecifiedInPts() Then 'Если задан размер в точках, вероятно можно не проверять и сразу задавать размер в точках или метрах
       TextFormat.CharHeightInPts = 7 'Размер в точках
      'Else
      'TextFormat.CharHeight = 0.007 'Размер в метрах, спрака говорит что в единицах документа
      'End If
   
   ' Set the note formatting (Установите форматирование заметки)
   myNote.SetTextFormat 0, TextFormat 'устанавливаем новый размер шрифта
   Set Annotation = myNote.GetAnnotation
   Annotation.Color = vbRed ' устанавливаем цвет
   'установка цвета внутри заметки:
    'Note.PropertyLinkedText = "<FONT color=0x000000ff><FONT style=B>This is a test of formatting a note via the API"

End Sub

 

 

Изменено 29 ноября 2019 пользователем Alex8007

[VOleg 228]

@Alex8007 А зачем первые 4 строчки перед "Sub main()"?

Dim swApp As Object

Dim Part As Object
Dim boolstatus As Boolean
Dim longstatus As Long, longwarnings As Long

Sub main()

Set swApp = _
Application.SldWorks

.......

А для черного цвета какие буквы поставить?

[malvi.dp 293]

1 час назад, Alex8007 сказал:

Вписать дату в чертеж

@Alex8007 , подскажите как можно регулировать место вставки заметки с датой?