|
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 20 Setze Kamera Position |
|
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.
Für die Darstellung eines Modells wird die Lage und die Ausrichtung des Modells gedreht. Anders in der realen Welt: wenn man dort ein Bild von einem Modell machen will sitzt dieses üblicherweise still und man positioniert die Kamera, dreht diese, wählt Brennweiten und Blendenöffnung und fokisiert den Punkt, den man in der Mitte des Bildes haben möchte.
Um diese Vorgehensweise auch in SolidWorks anwenden zu können bedarf es einiger schwieriger mathematischen Transformationen, deren Berechnung Ihnen dieses Makro abnehmen soll.
|
' ****************************************************************** |
mehrsprachiges Dialogfeld (wird automatisch erkannt und
|
In der Userform ist alles untergebracht, was für die Funktionen benötigt wird. Der Parameter vbModeless hinter dem Aufruf sorgt dafür, dass Sie mit SolidWorks weiterarbeiten können, auch wenn das Dialogformular auf dem Bildschirm bleibt. Tipp: dadurch können Sie das Makro auch bei Modellen verwenden, die Sie nur zur Ansicht geöffnet haben.
Hier der Codeteil:
Option Explicit
' predeclare 11 strings for User interface
Dim msgtext(10) As String
Dim conv As Double
Const Pi As Double = 3.14159265358979
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
Private Sub cmbUnits_Change()
Select Case cmbUnits.List(cmbUnits.ListIndex)
Case "mm"
conv = 1000
Case "cm"
conv = 100
Case "m"
conv = 1
Case "inch"
conv = 1 / 0.0254
Case "ft"
conv = 1 / 0.3048
'Case ""
' conv = 1 / 0.3048
End Select
End Sub
Private Sub cmdExit_Click()
End
End Sub
Private Sub cmdGetCamera_Click()
' hole Koordinaten des aktuellen Punktes
Dim swApp As Object
Dim SelectionMgr As Object
Dim ModelDoc As Object
Dim vSelPt As Variant
Dim SelectedObj As Object
Set swApp = CreateObject("SldWorks.Application")
Set ModelDoc = swApp.ActiveDoc
' um an den gewählten Punkt zu kommen brauchen wir den Selektionmanager
Set SelectionMgr = ModelDoc.SelectionManager
If (SelectionMgr.GetSelectedObjectCount <> 0) Then
vSelPt = SelectionMgr.GetSelectionPoint(1)
txtCameraX = vSelPt(0) * conv
txtCameraY = vSelPt(1) * conv
txtCameraZ = vSelPt(2) * conv
End If
End Sub
Public Sub cmdGetXForm_Click()
frmXForm.Show
End Sub
Private Sub cmdSetCamera_Click()
' Jetzt werden die eingesetzten Koordinaten umgerechnet und auf die
' Ansicht angewandt
Dim swApp As Object
Dim ModelDoc As Object
Dim ModelView As Object
Dim MathUtility As Object
Dim dblCamera(2) As Double
Dim dblDir(2) As Double
Dim dblSky(2) As Double
Dim dblTranslation(2) As Double
Dim dblMatrix(15) As Double
Dim varVisLine As Variant
Dim dblVisLineLength As Double
Dim varSkyRot As Variant
Dim varNormalVisSky As Variant
Dim varMatrix As Variant
Dim varTranslation As Variant
Dim dblAngle As Double
Dim dblScale As Double
Dim temp As Double
Dim mvCamera As Object
Dim mpCamera As Object
Dim mvDir As Object
Dim mvVisLine As Object
Dim mvSky As Object
Dim mvSkytVis As Object
Dim mvSkyRot As Object
Dim mvNormalVisSky As Object
Dim mvTemp As Object
Dim mvTranslation As Object
Set swApp = CreateObject("SldWorks.Application")
Set ModelDoc = swApp.ActiveDoc
Set ModelView = ModelDoc.ActiveView
Set MathUtility = swApp.GetMathUtility
' Koordinaten des Kamerapunktes (POVRAY: camera)
dblCamera(0) = txtCameraX
dblCamera(1) = txtCameraY
dblCamera(2) = txtCameraZ
' Koordinaten des Sichtlinienzielpunktes (POVRAY: look at)
dblDir(0) = txtDirX
dblDir(1) = txtDirY
dblDir(2) = txtDirZ
' erst mal alles vorher auf Nulls
setzen
dblTranslation(0) = 0
dblTranslation(1) = 0
dblTranslation(2) = 0
varTranslation = dblTranslation
ModelView.Translation2 = (varTranslation)
' Richtung des Sichtlinienvektors = Camera - Direction
' erzeuge Vektoren von den Punktkoordinaten
Set mvCamera = MathUtility.CreateVector((dblCamera))
'Set mpCamera = mvCamera.ConvertToPoint
Set mvDir = MathUtility.CreateVector((dblDir))
' und daraus die Richtung der Sichtlinie ermitteln
Set mvVisLine = mvCamera.subtract(mvDir)
' einen Einheitsvektor draus machen, vorher die Länge merken
dblVisLineLength = mvVisLine.GetLength
Set mvVisLine = mvVisLine.Normalise
' die Kameraausrichtung entsprechend auf diese Sichtlinie rotieren
' die Kamera zeigt in der "Grundausrichtung" ja immer in Richtung -Z
' und ist um die Z-Achse entsprechend der Koordinaten gedreht
'
' dafür gilt Sky - Sky
' tVisline
' und
-> 0 ->
'
-> -> 0
Vis * Sky
' Sky
= Vis * ----------------------------
' tVis
| Vis 0 | ^2 (= 1, da Einheitsvektor)
'
dblSky(0) = txtSkyX
dblSky(1) = txtSkyY
dblSky(2) = 0 ' immer 0
Set mvSky = MathUtility.CreateVector((dblSky))
' dann Vis0 * Sky Skalarprodukt
temp = mvVisLine.dot(mvSky)
Set mvSkytVis = mvVisLine.Scale(temp)
Set mvSkyRot = mvSky.subtract(mvSkytVis)
Set mvSkyRot = mvSkyRot.Normalise
' dann noch den Normalvektor für ein sauberes karthesisches
' Koordinatensystem auf diesen beiden ermitteln, dafür das
' Kreuzprodukt bilden
Set mvNormalVisSky = mvSkyRot.Cross(mvVisLine)
' aus diesen jetzt die Rotationsmatrix für die Funktion
' Orientation2 bilden, dabei darauf achten, dass die in
' Spaltenschreibweise angeordnet ist (siehe API Hilfe)
varVisLine = mvVisLine.ArrayData
varSkyRot = mvSkyRot.ArrayData
varNormalVisSky = mvNormalVisSky.ArrayData
dblMatrix(0) = varNormalVisSky(0)
dblMatrix(4) = varNormalVisSky(1)
dblMatrix(8) = varNormalVisSky(2)
dblMatrix(1) = varSkyRot(0)
dblMatrix(5) = varSkyRot(1)
dblMatrix(9) = varSkyRot(2)
dblMatrix(2) = varVisLine(0)
dblMatrix(6) = varVisLine(1)
dblMatrix(10) = varVisLine(2)
dblMatrix(15) = 1 'Scale einfach mal mit 1 vorgeben
varMatrix = dblMatrix
ModelView.Orientation2 = (varMatrix)
' durch die Rotation ist das Modell jetzt so orientiert, wie wir es haben
' wollten aber wir schauen immer noch genau auf den Nullpunkt (durch die
' vorgegebenen Nullen in der Orientierungsmatrix).
' Laut API Hilfe soll nach der Orientierung die Größe (Scale)
' und zum Schluß die Verschiebung (Translation) auf den ModelView
' gerechnet werden ...
' ... also zuerst den Größenfaktor anwenden
Select Case cmbUnits.List(cmbUnits.ListIndex)
Case "mm"
conv = 1000
Case "cm"
conv = 100
Case "m"
conv = 1
Case "inch"
conv = 1 / 0.0254
Case "ft"
conv = 1 / 0.3048
'Case ""
' conv = 1 / 0.3048
End Select
dblAngle = CDbl(txtCameraAngle.Text)
dblScale = conv / (2 * dblVisLineLength * Tan(dblAngle * Pi / 360))
ModelView.Scale2 = dblScale
' jetzt noch den Spurpunkt des Look-At-Points auf die neue View-Ebene
' errechnen (die normal auf der Sichtlinie Camera-LookAt steht)
dblTranslation(0) = -mvDir.dot(mvNormalVisSky) * dblScale / conv
dblTranslation(1) = -mvDir.dot(mvSkyRot) * dblScale / conv
dblTranslation(2) = -mvDir.dot(mvVisLine) * dblScale / conv
varTranslation = dblTranslation
ModelView.Translation2 = (varTranslation)
' und ganz zum Schluss noch die Grafik neu aufbauen
ModelDoc.GraphicsRedraw2
End Sub
Private Sub getDirPoint_Click()
' hole Koordinaten des aktuellen Punktes
Dim swApp As Object
Dim SelectionMgr As Object
Dim ModelDoc As Object
Dim vSelPt As Variant
Dim SelectedObj As Object
Set swApp = CreateObject("SldWorks.Application")
Set ModelDoc = swApp.ActiveDoc
' um an den gewählten Punkt zu kommen brauchen wir den Selektionmanager
Set SelectionMgr = ModelDoc.SelectionManager
If (SelectionMgr.GetSelectedObjectCount <> 0) Then
vSelPt = SelectionMgr.GetSelectionPoint(1)
txtDirX = vSelPt(0) * conv
txtDirY = vSelPt(1) * conv
txtDirZ = vSelPt(2) * conv
End If
End Sub
Private Sub scrollCameraAngle_Change()
txtCameraAngle.Text = scrollCameraAngle.Value
If chkAutoUpdate.Value = True Then cmdSetCamera_Click
End Sub
Private Sub scrollCameraAngle_Scroll()
txtCameraAngle.Text = scrollCameraAngle.Value
If chkAutoUpdate.Value = True Then cmdSetCamera_Click
End Sub
Private Sub txtCameraAngle_Change()
scrollCameraAngle.Value = txtCameraAngle.Text
End Sub
Private Sub txtCameraX_Change()
With txtCameraX
If .Text = "" Then
.Text = "0"
.SelStart = 0
.SelLength = Len(.Text)
End If
End With
If chkAutoUpdate.Value = True Then cmdSetCamera_Click
End Sub
Private Sub txtCameraY_Change()
With txtCameraY
If .Text = "" Then
.Text = "0"
.SelStart = 0
.SelLength = Len(.Text)
End If
End With
If chkAutoUpdate.Value = True Then cmdSetCamera_Click
End Sub
Private Sub txtCameraZ_Change()
With txtCameraZ
If .Text = "" Then
.Text = "0"
.SelStart = 0
.SelLength = Len(.Text)
End If
End With
If chkAutoUpdate.Value = True Then cmdSetCamera_Click
End Sub
Private Sub txtDirX_Change()
With txtDirX
If .Text = "" Then
.Text = "0"
.SelStart = 0
.SelLength = Len(.Text)
End If
End With
If chkAutoUpdate.Value = True Then cmdSetCamera_Click
End Sub
Private Sub txtDirY_Change()
With txtDirY
If .Text = "" Then
.Text = "0"
.SelStart = 0
.SelLength = Len(.Text)
End If
End With
If chkAutoUpdate.Value = True Then cmdSetCamera_Click
End Sub
Private Sub txtDirZ_Change()
With txtDirZ
If .Text = "" Then
.Text = "0"
.SelStart = 0
.SelLength = Len(.Text)
End If
End With
If chkAutoUpdate.Value = True Then cmdSetCamera_Click
End Sub
Private Sub txtSkyX_Change()
With txtSkyX
If .Text = "" Then
.Text = "0"
.SelStart = 0
.SelLength = Len(.Text)
End If
End With
If chkAutoUpdate.Value = True Then cmdSetCamera_Click
End Sub
Private Sub txtSkyY_Change()
With txtSkyY
If .Text = "" Then
.Text = "0"
.SelStart = 0
.SelLength = Len(.Text)
End If
End With
If chkAutoUpdate.Value = True Then cmdSetCamera_Click
End Sub
Private Sub UserForm_Initialize()
' check which language to apply. To make another language
' copy one of Subs called XyzString and make your changes
'
' Hier ausgucken welche Sprache benutzt wird. Um weitere
' Sprachen zu unterstützen unten einer der Subs kopieren
' Anpassungen machen und aufrufen
Dim swApp As Object
Dim ModelDoc As Object
Set swApp = CreateObject("SldWorks.Application")
Set ModelDoc = swApp.ActiveDoc
Select Case swApp.GetCurrentLanguage
Case "german"
GermanString
Case "english"
EnglishString
' Case "spanish"
' Case "french"
' Case "italian"
' Case "japanese"
Case Else
EnglishString
End Select
' ein paar Standardeinstellungen
txtCameraX = 300
txtCameraY = 200
txtCameraZ = 100
txtDirX = 100
txtDirY = 80
txtDirZ = 30
txtSkyX = 0
txtSkyY = 1
txtCameraAngle = 60 ' Degree
' einheiten
cmbUnits.AddItem "mm"
cmbUnits.AddItem "cm"
cmbUnits.AddItem "m"
cmbUnits.AddItem "inch"
cmbUnits.AddItem "ft"
Select Case ModelDoc.LengthUnit
Case swMM
cmbUnits.ListIndex = 0
Case swCM
cmbUnits.ListIndex = 1
Case swMETER
cmbUnits.ListIndex = 2
Case swINCHES
cmbUnits.ListIndex = 3
Case swFEET
cmbUnits.ListIndex = 4
Case swFEETINCHES
cmbUnits.ListIndex = 4
'Case swANGSTROM
'Case swNANOMETER
'Case swMICRON
'Case swMIL
'Case swUIN
End Select
End Sub
Private Sub GermanString()
' used Strings in German
' benutzte Zeichenketten in Deutsch
cmdSetCamera.Caption = "Setze Kameraposition"
cmdGetXForm.Caption = "XForm"
frmSetCamera.Caption = "Setze Kameraposition"
lblXKoor.Caption = "X - Koordinate"
lblYKoor.Caption = "Y - Koordinate"
lblZKoor.Caption = "Z - Koordinate"
lblCamera.Caption = "Kamera"
lblDir.Caption = "Richtung"
lblSky.Caption = "Orientierung"
lblAngle.Caption = "Öffnungswinkel"
cmdGetCamera.Caption = "Holen"
getDirPoint.Caption = "Holen"
chkAutoUpdate.Caption = "Automatisches Aktualisieren der Grafikansicht"
cmdExit.Caption = "Schliessen"
End Sub
Private Sub EnglishString()
' used Strings in english
cmdSetCamera.Caption = "Set camera position"
cmdGetXForm.Caption = "XForm"
frmSetCamera.Caption = "Set camera position"
lblXKoor.Caption = "X - Coordinate"
lblYKoor.Caption = "Y - Coordinate"
lblZKoor.Caption = "Z - Coordinate"
lblCamera.Caption = "Camera"
lblDir.Caption = "Direction"
lblSky.Caption = "Orientation"
lblAngle.Caption = "aperture angle"
cmdGetCamera.Caption = "Get"
getDirPoint.Caption = "Get"
chkAutoUpdate.Caption = "Automatically update grafic view"
cmdExit.Caption = "Close"
End Sub
| Kritik und Anregungen bitte an Stefan Berlitz. Letzte Änderung dieser Seite am Donnerstag, 01. Februar 2007 17:40 |