Перейти к публикации

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


Рекомендованные сообщения

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

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

 

 

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

SW2019.png

 

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

 

Ссылка на сообщение
Поделиться на других сайтах


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

5dc1720669bdb_.png.81873d16748be5ce499aae1ef6412652.png

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

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

 

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

Ссылка на сообщение
Поделиться на других сайтах

Ещё один макрос для производительности, меняет в свойствах документа качество изображения попеременно на низкое или высокое (но не максимальное). Экономит 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

 

Изменено пользователем Kir95
Ссылка на сообщение
Поделиться на других сайтах

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

Ссылка на сообщение
Поделиться на других сайтах
16 минут назад, tulibay сказал:

 

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

зы цепляю replacelabelview.dll

Ссылка на сообщение
Поделиться на других сайтах
2 часа назад, Wolfi сказал:

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

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

 

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

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

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

Изменено пользователем Kelny
Ссылка на сообщение
Поделиться на других сайтах
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

 

Изменено пользователем Kelny
Ссылка на сообщение
Поделиться на других сайтах
В 13.11.2019 в 14:06, tulibay сказал:

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

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

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

 

Изменено пользователем Wolfi
Ссылка на сообщение
Поделиться на других сайтах

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

Ссылка на сообщение
Поделиться на других сайтах
  • 2 недели спустя...

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

5ddea770b7c7e_.png.2361b22c272abe9fbb9eb464003c932b.png

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

'----------------------------------------------------
'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

 

 

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

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

5ddea56eecbf2_formlibraryreferences.png.9dc846ecdcb451cd57068358c4f7889c.png

 

5ddea569c4f4c_formlibrary.png.20cb7b2de78ab326e19fa1e0200ef790.png

 

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

 

 

Ссылка на сообщение
Поделиться на других сайтах

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

Ссылка на сообщение
Поделиться на других сайтах

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

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

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

 

Ссылка на сообщение
Поделиться на других сайтах
15 минут назад, Alex8007 сказал:

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

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

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

 

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

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

 

 

 

Ссылка на сообщение
Поделиться на других сайтах
5 часов назад, Kelny сказал:

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

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

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

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

5ddfb2a7c632c_.jpg.7879d4bee38a985b3f9bd5da5daddcfd.jpg

 

Изменено пользователем Alex8007
Ссылка на сообщение
Поделиться на других сайтах
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

 

Ссылка на сообщение
Поделиться на других сайтах
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

 

 

Изменено пользователем Alex8007
Ссылка на сообщение
Поделиться на других сайтах

@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

.......

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

Ссылка на сообщение
Поделиться на других сайтах
1 час назад, Alex8007 сказал:

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

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

Ссылка на сообщение
Поделиться на других сайтах

Присоединяйтесь к обсуждению

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

Гость
Ответить в тему...

×   Вставлено в виде отформатированного текста.   Вставить в виде обычного текста

  Разрешено не более 75 эмодзи.

×   Ваша ссылка была автоматически встроена.   Отобразить как ссылку

×   Ваш предыдущий контент был восстановлен.   Очистить редактор

×   Вы не можете вставить изображения напрямую. Загрузите или вставьте изображения по ссылке.

  • Сейчас на странице   0 пользователей

    Нет пользователей, просматривающих эту страницу.




×
×
  • Создать...