|
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 24 3D Punktwolke einlesen |
|
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.
Manchmal ist es notwendig, 3D-Punktwolke in SolidWorks einzulesen. Dies ist mit SolidWorks Bordmitteln nicht zu lösen, deswegen hier ein Makro, dass das erledigen kann.
|
' **********************************************************************
Sub main() |
mehrsprachiges Dialogfeld (wird automatisch erkannt und
|
In der Userform ist alles untergebracht, was für die Funktionen benötigt wird. Selbst große Datenmenge werden recht flott verarbeitet, die Punktwolke des alten Pharaos ( von http://www.pelleas.org/Download/download_rightframe.htm geladen) wurde unter SolidWorks 2003 in knapp 1 Minute mit diesem Makro eingelesen und als 3D Skizze erzeugt.
British_Museum_ASCII.zip |
 |
Hier der Codeteil:
Option Explicit
' declarations, used windows API calls and constants
' Deklarationen, benötigte Windows API-Calls und Konstanten
Const swDocNONE = 0 ' Used to be TYPE_NONE
Const swDocPart = 1 ' Used to be TYPE_PART
Const swDocASSEMBLY = 2 ' Used to be TYPE_ASSEMBLY
Const swDocDRAWING = 3 ' Used to be TYPE_DRAWING
Const swDocSDM = 4 ' Solid data manager.
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
' ab SW2013 wird VBA7 genutzt, dass erfordert wegen der 64 Bit Möglichkeiten
' sichere Deklarationen. Siehe API Hilfe "VBA and SolidWorks x64"
' und http://msdn.microsoft.com/en-us/library/ff700513(v=office.11).aspx
' und http://www.jkp-ads.com/articles/apideclarations.asp
'
#If VBA7 Then
' Windows API for the SaveAs Filebox
Private Declare PtrSafe Function GetSaveFileName Lib "comdlg32.dll" Alias _
"GetSaveFileNameA" (pOpenfilename As OPENFILENAME) As Long
' structure needed by Windows API
Private Type OPENFILENAME
lStructSize As Long
hwndOwner As LongPtr
hInstance As LongPtr
lpstrFilter As String
lpstrCustomFilter As String
nMaxCustFilter As Long
nFilterIndex As Long
lpstrFile As String
nMaxFile As Long
lpstrFileTitle As String
nMaxFileTitle As Long
lpstrInitialDir As String
lpstrTitle As String
flags As Long
nFileOffset As Integer
nFileExtension As Integer
lpstrDefExt As String
lCustData As Long
lpfnHook As LongPtr
lpTemplateName As String
End Type
#Else
' Windows API for the SaveAs Filebox
Private Declare Function GetSaveFileName Lib "comdlg32.dll" Alias _
"GetSaveFileNameA" (pOpenfilename As OPENFILENAME) As Long
' structure needed by Windows API
Private Type OPENFILENAME
lStructSize As Long
hwndOwner As Long
hInstance As Long
lpstrFilter As String
lpstrCustomFilter As String
nMaxCustFilter As Long
nFilterIndex As Long
lpstrFile As String
nMaxFile As Long
lpstrFileTitle As String
nMaxFileTitle As Long
lpstrInitialDir As String
lpstrTitle As String
flags As Long
nFileOffset As Integer
nFileExtension As Integer
lpstrDefExt As String
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type
#End If
' for more information on Open- or SaveAs dialogs look at
' http://www.mvps.org/vbnet/index.html?code/comdlg/filedlgsoverview.htm
' SolidWorks related declarations
Dim swApp As Object ' SolidWorks session
Dim ModelDoc2 As Object ' active document
Dim filenameIn As String ' desired filename for saved bitmap
Dim msgtext(10) As String ' some texts for multi-language support
Private Sub cmdDesiredFileName_Click()
' common dialog for browse for desired filename
' Auswahl des Dateinamens für Bitmap
Dim OFName As OPENFILENAME
Dim tmp As String
'Set the filet
OFName.lpstrFilter = "3D Data file (*.txt)" + Chr$(0) + "*.txt" + Chr$(0) + "All Files (*.*)" + Chr$(0) + "*.*" + Chr$(0)
'Create a buffer
OFName.lpstrFile = String(257, 0)
#If VBA7 Then
'Set the maximum number of chars
OFName.nMaxFile = LenB(OFName.lpstrFile) - 1
'Set the structure size
OFName.lStructSize = LenB(OFName)
#Else
'Set the maximum number of chars
OFName.nMaxFile = Len(OFName.lpstrFile) - 1
'Set the structure size
OFName.lStructSize = Len(OFName)
#End If
'Create a buffer
OFName.lpstrFileTitle = Space$(255)
'Set the maximum number of chars
OFName.nMaxFileTitle = 255
'Set the initial directory
OFName.lpstrInitialDir = GetPathPart(swApp.GetCurrentMacroPathName)
'Set the dialog title
OFName.lpstrTitle = UserForm1.Caption
'no extra flags
OFName.flags = 0
'default extension
OFName.lpstrDefExt = "bmp" + Chr$(0)
'Show the 'Save File'-dialog
If GetSaveFileName(OFName) Then
txtDesiredFileName.Text = Trim$(OFName.lpstrFile)
Else
txtDesiredFileName.Text = ""
End If
End Sub
Private Sub cmdExit_Click()
End
End Sub
Private Sub cmdGen3DPointCloud_Click()
' Procedure opens file, reads in line by line, seperates the X,Y,Z
' values (should be delimited with TAB and generates a 3D point
' for that coordinate
Dim point As Object
Dim file As String
Dim anzahl As Long
Dim conv As Double
Dim zeile As String
Dim ErrorInLine As Boolean
Dim ErrorDescription As String
Dim xs, ys, zs As String
Dim x, y, z As Double
Dim limiter As String
' path to file, each line contains XYZ for one point, delimited
' with TAB or BLANK, decimal stop is , (!)
file = txtDesiredFileName.Text
If Not FileExists(file) Then
MsgBox (msgtext(0) & file)
Exit Sub
End If
' get delimiter from textfield, left character, if no input use TAB
If Len(txtLimiter.Text) = 0 Then txtLimiter.Text = Chr$(9)
limiter = Left(txtLimiter.Text, 1)
' conversion factor (here mm); SolidWorks always uses Meters
Select Case cmbUnits.List(cmbUnits.ListIndex)
Case "mm"
conv = 0.001
Case "cm"
conv = 0.01
Case "m"
conv = 1
Case "inch"
conv = 0.0254
Case "ft"
conv = 0.3048
End Select
' open a new 3D sketch, SetAddToDB prevents snapping
Call ModelDoc2.Insert3DSketch2(True)
Call ModelDoc2.SetAddToDB(True)
' open file and read line by line
Open file For Input As #1
While Not (EOF(1))
Line Input #1, zeile
anzahl = anzahl + 1
' reset error flag
ErrorInLine = False
ErrorDescription = "File: " & file & vbCrLf
Debug.Print anzahl & ": " & zeile
lblInput.Caption = anzahl & ": " & zeile
' convert coordinates to values, some error checking. Havn't tested
' the converiosn with CDbl for german separator ",", don't know exactly
' if in english system "." for decimals will work
' dann das umwandeln der Zeile in die koordinaten mit einer rudimentären
' Fehlerprüfung, ob Werte okay sein können. Trenner kann eingestellt werden
If CountDelimitedWords(zeile, limiter) = 3 Then
xs = GetDelimitedWord(zeile, 1, limiter)
ys = GetDelimitedWord(zeile, 2, limiter)
zs = GetDelimitedWord(zeile, 3, limiter)
If IsNumeric(xs) Then
x = CDbl(xs) * conv
Else
ErrorInLine = True
ErrorDescription = ErrorDescription & vbCrLf & msgtext(4)
End If
If IsNumeric(ys) Then
y = CDbl(ys) * conv
Else
ErrorInLine = True
ErrorDescription = ErrorDescription & vbCrLf & msgtext(5)
End If
If IsNumeric(zs) Then
z = CDbl(zs) * conv
Else
ErrorInLine = True
ErrorDescription = ErrorDescription & vbCrLf & msgtext(6)
End If
Else
ErrorInLine = True
ErrorDescription = msgtext(3)
End If
' und dann entweder den Punkt setzen oder eine Meldung
' wegen fehlerhaften Inputdaten ausgeben.
If ErrorInLine Then
MsgBox msgtext(2) & anzahl & vbCrLf & ErrorDescription & vbCrLf
Else
Set point = ModelDoc2.CreatePoint2(x, y, z)
End If
Debug.Print "Koord.:" & xs & "#" & x & "#" & ys & "#" & y & "#" & zs & "#" & z
lblData.Caption = "Koord.:" & xs & "#" & x & "#" & ys & "#" & y & "#" & zs & "#" & z
Wend
Close #1
' done, keep 3D sketch open if user wants to stay in edit mode
' fertig, die Skizze offenhalten, falls noch dran gearbeitet werden muss
Call ModelDoc2.SetAddToDB(False)
MsgBox (anzahl & msgtext(1))
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
Set swApp = Application.SldWorks ' CreateObject("SldWorks.Application")
Select Case swApp.GetCurrentLanguage
Case "german"
GermanString
Case "english"
EnglishString
' Case "spanish"
' Case "french"
' Case "italian"
' Case "japanese"
Case Else
EnglishString
End Select
' on first initialisation get pointer to active dicument
' beim ersten Aufruf Pointer auf aktives Dokument holen
Set ModelDoc2 = swApp.ActiveDoc
If ModelDoc2 Is Nothing Then
MsgBox msgtext(8)
End
End If
' only for parts
' nur für Teile
If ModelDoc2.GetType <> swDocPart Then
MsgBox msgtext(9)
End
End If
' default values
' Vorgabewerte
' einheiten
cmbUnits.AddItem "mm"
cmbUnits.AddItem "cm"
cmbUnits.AddItem "m"
cmbUnits.AddItem "inch"
cmbUnits.AddItem "ft"
Select Case ModelDoc2.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
' default delimiter is TAB
txtLimiter.Text = Chr$(9)
' standard path for filename is same directory and file data.txt
' standard Vorgabe für Namen Verzeichnis des Dokumentes plus data.txt
txtDesiredFileName.Text = GetPathPart(swApp.GetCurrentMacroPathName) & "data.txt"
End Sub
Private Sub GermanString()
' used Strings in German
' benutzte Zeichenketten in Deutsch
UserForm1.Caption = "Erzeuge 3D Punktwolke von Datei"
lblDesiredFileName.Caption = "Bitte geben Sie den Dateinamen der 3D-Daten (TAB separiert) inklusive Pfad ein (sollte Endung *.csv haben)"
lblUnits.Caption = "Einheit"
lblLimiter.Caption = "Trenner"
cmdGen3DPointCloud.Caption = "Erzeuge Punktwolke"
cmdExit.Caption = "Beenden"
' ein paar Texte, üblicherweise Warnungen und Fehler
msgtext(0) = "Datei nicht gefunden" & vbCrLf
msgtext(1) = " Punkte verarbeitet"
msgtext(2) = "Fehler Zeile "
msgtext(3) = "Keine drei getrennten Koordinaten"
msgtext(4) = "X-Wert nicht numerisch"
msgtext(5) = "Y-Wert nicht numerisch"
msgtext(6) = "Z-Wert nicht numerisch"
msgtext(7) = ""
msgtext(8) = "Kein aktives Dokument"
msgtext(9) = "Kein Einzelteil aktiv"
msgtext(10) = ""
End Sub
Private Sub EnglishString()
' used Strings in english
UserForm1.Caption = "Generate 3D point clud from file"
lblDesiredFileName.Caption = "Please enter the filename of the 3D data (TAB seperated) with complete path (extension should be *.csv)"
lblUnits.Caption = "Units"
lblUnits.Caption = "Delimiter"
cmdGen3DPointCloud.Caption = "Make 3D point cloud"
cmdExit.Caption = "Exit"
' some text, usually warning or error messages
msgtext(0) = "File not found" & vbCrLf
msgtext(1) = " points processed"
msgtext(2) = "Error line "
msgtext(3) = "Not three separated values"
msgtext(4) = "X-value not numeric"
msgtext(5) = "Y-value not numeric"
msgtext(6) = "Z-value not numeric"
msgtext(7) = ""
msgtext(8) = "No active document"
msgtext(9) = "No part active"
msgtext(10) = ""
End Sub
Private Function FileExists(strDest As String) As Boolean
' checks if file strDest exists
Dim intLen As Integer
If strDest <> vbNullString Then
On Error Resume Next
intLen = Len(Dir$(strDest))
On Error GoTo 0
FileExists = (Not Err And intLen > 0)
Else
FileExists = False
End If
End Function
Private Function GetPathPart(strPath As String) As String
'
Dim intCounter As Integer
' Parse the string backwards
For intCounter = Len(strPath) To 1 Step -1
' Short-circuit when we reach the slash
If Mid$(strPath, intCounter, 1) = "\" Then
Exit For
End If
Next intCounter
' Return the value
GetPathPart = Left$(strPath, intCounter)
End Function
Public Function GetDelimitedWord( _
strIn As String, _
ByVal lngIndex As Long, _
chrDelimit As String) _
As String
' Comments : Returns word intIndex in delimited string strIn
' Parameters: strIn - String to search
' lngIndex - Word position to find
' chrDelimit - Character used as the delimter
' Returns : nth word
'
Dim lngCounter As Long
Dim lngStartPos As Long
Dim lngEndPos As Long
Dim strDelimit As String
' Set initial values
lngCounter = 1
lngStartPos = 1
strDelimit = Left$(chrDelimit, 1)
' Count to the specified index
For lngCounter = 2 To lngIndex
' Get the new starting position
lngStartPos = InStr(lngStartPos, strIn, strDelimit) + 1
Next lngCounter
' Determine the ending position
lngEndPos = InStr(lngStartPos, strIn, strDelimit) - 1
' Ending position can't be less than 1
If lngEndPos <= 0 Then
lngEndPos = Len(strIn)
End If
' Pull the word out and return it
GetDelimitedWord = Mid$(strIn, lngStartPos, lngEndPos - lngStartPos + 1)
End Function
Public Function CountDelimitedWords( _
strIn As String, _
chrDelimit As String) _
As Long
' Comments : Returns the number of words in a delimited string
' Parameters: strIn - String to count words in
' chrDelimit - Character that delimits words in strIn
' Returns : Number of occurrences
'
Dim lngWordCount As Long
Dim lngPos As Long
lngWordCount = 1
' Find the first occurence
lngPos = InStr(strIn, chrDelimit)
Do While lngPos > 0
' Increment the hit counter
lngWordCount = lngWordCount + 1
' Loop until no more occurrences
lngPos = InStr(lngPos + 1, strIn, chrDelimit)
Loop
' Return the value
CountDelimitedWords = lngWordCount
End Function
| Kritik und Anregungen bitte an Stefan Berlitz. Letzte Änderung dieser Seite am Dienstag, 25. Juni 2013 11:24 |