|
SolidWorks MakroMania ist eine Beispielsammlung einiger Makros, die Ihnen eine Vorstellung davon geben soll, was man auch schon mit Makros in SolidWorks alles anstellen kann. Der Code des Makros sollte so gut dokumentiert sein, dass Sie damit ohne weitere Anleitung verstehen, was gemacht wird. |
< voriges |
MakroMania Übersicht |
Nummer 34 Bemaßungswert in Zwischenablage |
|
Diese Makro wurde als Antwort auf eine Anfrage im SolidWorks-Brett auf CAD.de erstellt, dort gibt es auch noch andere Lösungen und Diskussionen dazu. Also einfach mal auf http://ww3.cad.de/foren/ubb/Forum2/HTML/010841.shtml schauen
Ich übernehme keine Haftung für die korrekte Funktion der Routinen oder irgendwelcher Schäden bei der Anwendung dieser Beispiele. Das gesamte Risiko trägt der Benutzer selbst. - Sorry, muss sein.
' **********************************************************************
' * Makro holt vom selektierten Maß den Wert und kopiert ihn mit
' * allen 8 Nachkommastellen in die Zwischenablage.
' *
' * Macro get the "real" value from a selected dimension and
' * copies the value to clipboard
' *
' * 27.07.2006 Stefan Berlitz (stefan.berlitz@solidworks.cad.de)
' * http://solidworks.cad.de
' * http://swtools.cad.de
' **********************************************************************
Dim swApp As Object
Dim ModelDoc As Object
Dim SelectionMgr As Object
Dim DispDim As Object
Dim Dimension As Object
Dim DimValue As Double
Dim convertunits As Double
Const swSelDIMENSIONS = 14
Public Enum swLengthUnit_e
swMM = 0
swCM = 1
swMETER = 2
swINCHES = 3
swFEET = 4
swFEETINCHES = 5
swANGSTROM = 6
swNANOMETER = 7
swMICRON = 8
swMIL = 9
swUIN = 10
End Enum
' ----------------------------------------------------------------------
' Tricksereien um von VBA aus ins Clipboard zu setzen
' it is not easy to copy text from VBA to the clipboard
Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) _
As Long
Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) _
As Long
Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, _
ByVal dwBytes As Long) As Long
Declare Function CloseClipboard Lib "User32" () As Long
Declare Function OpenClipboard Lib "User32" (ByVal hwnd As Long) _
As Long
Declare Function EmptyClipboard Lib "User32" () As Long
Declare Function lstrcpy Lib "kernel32" (ByVal lpString1 As Any, _
ByVal lpString2 As Any) As Long
Declare Function SetClipboardData Lib "User32" (ByVal wFormat _
As Long, ByVal hMem As Long) As Long
Public Const GHND = &H42
Public Const CF_TEXT = 1
Public Const MAXSIZE = 4096
' ----------------------------------------------------------------------
Sub main()
' an SolidWorks anklinken, aktives Dokument holen, davon
' den Selektionsmanager und dann das selektierte Maß auslesen
' attach to SolidWorks, get active ModelDoc and Selectionmanager
' and then get the selected Dimension
Set swApp = CreateObject("SldWorks.Application")
Set ModelDoc = swApp.ActiveDoc
Set SelectionMgr = ModelDoc.SelectionManager
' nur ein Objekt selektiert?
' single object selected?
If SelectionMgr.GetSelectedObjectCount <> 1 Then
' Warnmeldung / warning message
MsgBox "Bitte nur eine einzelne Bemaßung selektieren" & vbCrLf & _
"Please select a single dimension only"
Else
' wenn es eine Bemaßung ist
' check for DIMENSION type object
If SelectionMgr.GetSelectedObjectType(1) = swSelDIMENSIONS Then
' an die Bemaßung anklinken, auf dem Schirm ist ja eine DisplayDimension
' also erst mal den zugrunde liegenden Parameter holen
' what we got is a display dimension, we need the underlaying parameter
Set DispDim = SelectionMgr.GetSelectedObject3(1)
Set Dimension = DispDim.GetDimension
' den Wert auslesen, API typisch ist der in Metern, also umrechnen
' Umrechnung quick&dirty auf Millimeter
' get the value, which is in Meters (like all values obtained with API)
' so we have to convert it to ModelDoc units
Select Case ModelDoc.LengthUnit
Case swMM
convertunits = 1000
Case swCM
convertunits = 100
Case swMETER
convertunits = 1
Case swINCHES
convertunits = 25.4
Case swFEET
convertunits = 30.48
Case swFEETINCHES
cmbUnits.ListIndex = 30.48
'Case swANGSTROM
'Case swNANOMETER
'Case swMICRON
'Case swMIL
'Case swUIN
End Select
DimValue = Dimension.GetSystemValue2("") * convertunits
' Wert in einer Messagebox anzeigen
' Show value in a messagebox
MsgBox "Wert/Value: " & DimValue
' und noch in die Zwischenablage kopieren
' and copy the value as text to clipboard
ClipBoard_SetData CStr(DimValue)
Else
' Warnmeldung / warning message
MsgBox "Bitte nur eine einzelne Bemaßung selektieren" & vbCrLf & _
"Please select a single dimension only"
End If
End If
End Sub
Function ClipBoard_SetData(MyString As String)
' von http://p2p.wrox.com/topic.asp?TOPIC_ID=15747
Dim hGlobalMemory As Long, lpGlobalMemory As Long
Dim hClipMemory As Long, X As Long
' Allocate movable global memory.
'-------------------------------------------
hGlobalMemory = GlobalAlloc(GHND, Len(MyString) + 1)
' Lock the block to get a far pointer
' to this memory.
lpGlobalMemory = GlobalLock(hGlobalMemory)
' Copy the string to this global memory.
lpGlobalMemory = lstrcpy(lpGlobalMemory, MyString)
' Unlock the memory.
If GlobalUnlock(hGlobalMemory) <> 0 Then
MsgBox "Could not unlock memory location. Copy aborted."
GoTo ExitHere
End If
' Open the Clipboard to copy data to.
If OpenClipboard(0&) = 0 Then
MsgBox "Could not open the Clipboard. Copy aborted."
Exit Function
End If
' Clear the Clipboard.
X = EmptyClipboard()
' Copy the data to the Clipboard.
hClipMemory = SetClipboardData(CF_TEXT, hGlobalMemory)
ExitHere:
If CloseClipboard() = 0 Then
MsgBox "Fehler beim Schließen des Clipboards"
End If
End Function
| Kritik und Anregungen bitte an Stefan Berlitz. Letzte Änderung dieser Seite am Mittwoch, 11. Juli 2007 17:52 |