|
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 18 Hochauflösendes Bitmap speichern |
|
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.
Neu mit der Version 2001Plus ist die Möglichkeit eine Bitmap vom aktuellen Dokument in beliebiger Auflösung abzuspeichern. Für Zeichnungen war das schon immer möglich (per TIFF-Export), Baugruppen und Teile wurden jedoch nur mit der teilweise viel zu schlechten Bildschirmauflösung abgespeichert. Aber es gibt eine neue API-Funktion, die diesen Trick auch mit Modellen erlaubt (aber nur als unkomprimiertes Bitmap, Umwandeln in ein weniger speicherintensives Format kann dann mit einem Freewareprogramm wie IrfanView oder XNView durchgeführt werden.
|
' ********************************************************************** |
mehrsprachiges Dialogfeld (wird automatisch erkannt und umgeschaltet, deutsch und englisch bereits vorhanden)
|
In der Userform ist alles untergebracht, was für die Funktionen benötigt wird. Es werden einige Windows-API-Funktionen benutzt, die etwas kompliziert anmuten, also nicht erschrecken. Die haben auch nichts mit der eigentlichen Funktionsweise zu tun, sondern bringen einen Dateiauswahldialog auf den Bildschirm.
Hier der Codeteil:
Option Explicit
' declarations, used windows API calls and constants
' Deklarationen, benötigte Windows API-Calls und Konstanten
' Windows API to get the free discspace
Private Declare Function GetDiskFreeSpaceEx Lib "kernel32" Alias "GetDiskFreeSpaceExA" ( _
ByVal lpRootPathName As String, _
lpFreeBytesAvailableToCaller As Currency, _
lpTotalNumberOfBytes As Currency, _
lpTotalNumberOfFreeBytes As Currency) As Long
' 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
' 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 widthIn As Long ' width of resulting bitmap
Dim heightIn As Long ' height of desired bitmap
Dim msgtext(10) As String ' some texts for multi-language support
Dim myPixWidth As Long ' width and height in pixel for internal calculation
Dim myPixHeight As Long
Dim mySpinFactor As Double ' factor for spinbutton
Dim myDontUpdate As Boolean ' Flag for SetPixelValue
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 structure size
OFName.lStructSize = Len(OFName)
'Set the filet
OFName.lpstrFilter = "Bitmap (*.bmp)" + Chr$(0) + "*.bmp" + Chr$(0) + "All Files (*.*)" + Chr$(0) + "*.*" + Chr$(0)
'Create a buffer
OFName.lpstrFile = Space$(254)
'Set the maximum number of chars
OFName.nMaxFile = 255
'Create a buffer
OFName.lpstrFileTitle = Space$(254)
'Set the maximum number of chars
OFName.nMaxFileTitle = 255
'Set the initial directory
OFName.lpstrInitialDir = GetPathPart(ModelDoc2.GetPathName)
'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 cmdGenBitmap_Click()
' get the desired filename from textbox, and do some simple checks
' erstmal den Namen inklusive Pfad, muss gültig sein, deswegen einige Tests
filenameIn = txtDesiredFileName.Text
Dim ret As Long
' check if file exists
' existiert die gewünschte Datei schon
If FileExists(filenameIn) > 0 Then
' file with the desired name exists, ask user if he wants to continue
' Datei existiert bereits, fragen, ob weitergemacht werden soll
If MsgBox(msgtext(0), vbOKCancel) = vbCancel Then
' user has canceled
Exit Sub
End If
End If
' filenameIn has proper file extension *,bmp
' hat die Datei die Endung *.bmp
If (LCase(Right(filenameIn, 3)) <> "bmp") Then
If MsgBox(msgtext(1), vbOKCancel) = vbCancel Then
' user has canceled
Exit Sub
End If
End If
' could check of desired directory exists and is writable, but I'm lazy
' dann gewünschte Breite und Höhe der Bitmap
widthIn = myPixWidth
heightIn = myPixHeight
' determine the needed disk space, SolidWorks saves uncompressed BMP!
' dann vor dem Abspeichern die Dategröße überprüfen, da SolidWorks
' umkomprimiertes BMP abspeichert, und die werden riesig
Dim destfilesize As Double
destfilesize = widthIn * heightIn * 3 ' 24 bit color depth = 3 bytes per pixel
' is there enough space left on device, That's important!
' ist genügend freier Speicher auf dem Laufwerk
Dim rootpath As String
rootpath = Left(filenameIn, InStr(1, filenameIn, "\"))
'Retrieve information
If FreeSpace(rootpath) < destfilesize Then
Dim msg As String
msg = msgtext(2) & vbCrLf
msg = msg & msgtext(3) & vbCrLf & Format$(destfilesize, "###,###,###,##0") & vbCrLf
msg = msg & msgtext(4) & vbCrLf & Format$(FreeSpace(rootpath), "###,###,###,##0") & vbCrLf
msg = msg & msgtext(5) & vbCrLf
MsgBox msg, vbOKOnly
Exit Sub
End If
' ausführen und Rückgabewert überprüfen oder
' einfach ignorieren
If ModelDoc2.SaveBMP(filenameIn, widthIn, heightIn) Then
' successfully saved file
' erfolgreich gespeichert
MsgBox filenameIn & msgtext(6)
Else
' give error message
' Fehler, also Meldung ausgeben
MsgBox msgtext(7)
End If
End Sub
Private Sub optUnitInch_Click()
' if Pixel is activated deactivate DPI textbox and spin
' wenn Pixel als Einheit gewählt ist die DPI textbox und Spin deaktivieren
spinDPI.Enabled = True
txtDPI.Enabled = True
lblDPI.Enabled = True
mySpinFactor = 0.01
Dim oldh, oldw As Double ' bye changing the textfield the pixelvalues are updated
oldh = myPixHeight
oldw = myPixWidth
' avoid overrun
myDontUpdate = True
txtHeight.Value = CStr(Round(oldh / txtDPI.Value, 2))
txtWidth.Value = CStr(Round(oldw / txtDPI.Value, 2))
' reactivate
myDontUpdate = False
Call SetPixelValue
End Sub
Private Sub optUnitPixel_Click()
' if Pixel is activated deactivate DPI textbox and spin
' wenn Pixel als Einheit gewählt ist die DPI textbox und Spin deaktivieren
spinDPI.Enabled = False
txtDPI.Enabled = False
lblDPI.Enabled = False
mySpinFactor = 1
'
Dim oldh, oldw As Long ' bye changing the textfield the pixelvalues are updated
oldh = myPixHeight
oldw = myPixWidth
' avoid overrun
myDontUpdate = True
txtHeight.Value = oldh
txtWidth.Value = oldw
myDontUpdate = False
Call SetPixelValue
End Sub
Private Sub optUnitZM_Click()
' if Pixel is activated deactivate DPI textbox and spin
' wenn Pixel als Einheit gewählt ist die DPI textbox und Spin deaktivieren
spinDPI.Enabled = True
txtDPI.Enabled = True
lblDPI.Enabled = True
mySpinFactor = 0.1
Dim oldh, oldw As Double ' bye changing the textfield the pixelvalues are updated
oldh = myPixHeight
oldw = myPixWidth
' avoid overrun
myDontUpdate = True
txtHeight.Value = CStr(Round(oldh * 2.54 / txtDPI.Value, 2))
txtWidth.Value = CStr(Round(oldw * 2.54 / txtDPI.Value, 2))
myDontUpdate = False
Call SetPixelValue
End Sub
Private Sub spinDPI_Change()
' DPI has change, update textfield
' DPI wurde geändert, textfeld aktualisieren
txtDPI.Text = spinDPI.Value
End Sub
Private Sub spinHeight_Change()
' height has changed, update textfield
' Höhe wurde geändert, Textfeld aktualisieren
'txtHeight.Text = spinHeight.Value
Static lastheight As Long
txtHeight.Text = txtHeight.Text + (spinHeight.Value - lastheight) * mySpinFactor
lastheight = spinHeight.Value
End Sub
Private Sub spinWidth_Change()
' width has changed, update textfield
' Breite wurde geändert, Textfeld aktualisieren
'txtWidth.Text = spinWidth.Value
Static lastwidth As Long
txtWidth.Text = txtWidth.Text + (spinWidth.Value - lastwidth) * mySpinFactor
lastwidth = spinWidth.Value
End Sub
Private Sub txtDPI_Change()
' DPI has changed, update spin value
' DPI wurde geändert, Spinbuttonwert aktualisieren
spinDPI.Value = txtDPI.Text
Call SetPixelValue
End Sub
Private Sub txtHeight_Change()
' height has changed, update spin value
' Höhe wurde geändert, Spinbuttonwert aktualisieren
Call SetPixelValue
Call ApproxFileSize
End Sub
Private Sub txtWidth_Change()
' height has changed, update spin value
' Höhe wurde geändert, Spinbuttonwert aktualisieren
'spinWidth.Value = Val(txtWidth.Text)
Call SetPixelValue
Call ApproxFileSize
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 = 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
' default values in pixel
' Vorgabewerte in Pixel
myPixHeight = 480
myPixWidth = 640
optUnitPixel.Value = True
txtDPI.Text = "100"
' 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
'
' standard path for filename BMP file is same directory, same name, extension bmp
' standard Vorgabe für Namen der BMP Datei: Verzeichnis und Name des Dokumentes
Dim strtemp As String
strtemp = LCase(ModelDoc2.GetTitle)
' und die Endung mit dem .slddrw abschneiden, wenn vorhanden
If (InStr(strtemp, ".sld") > 0) Then
strtemp = Left(strtemp, InStr(strtemp, ".sld") - 1)
End If
txtDesiredFileName.Text = GetPathPart(ModelDoc2.GetPathName) & strtemp & ".bmp"
End Sub
Private Sub GermanString()
' used Strings in German
' benutzte Zeichenketten in Deutsch
UserForm1.Caption = "Speichern als hochauflösendes Bitmap"
lblDesiredFileName.Caption = "Bitte geben Sie den gewünschten Dateinamen inklusive Pfad ein (sollte Endung *.bmp haben)"
cmdGenBitmap.Caption = "Bitmap speichern"
cmdExit.Caption = "Beenden"
lblWidth.Caption = "Breite"
lblHeight.Caption = "Höhe"
optUnitPixel.Caption = "Pixel"
optUnitZM.Caption = "Zentimeter"
optUnitInch.Caption = "Zoll"
lblDPI.Caption = "DPI (zm,Zoll)"
' ein paar Texte, üblicherweise Warnungen und Fehler
msgtext(0) = "Datei existiert bereits. Trotzdem fortfahren?"
msgtext(1) = "Dateiname hat nicht die Endung BMP. Trotzdem fortfahren?"
' Warnung, wenn zu wenig Speicher auf Platte ist
msgtext(2) = "Nicht genügend freier Speicher auf Laufwerk vorhanden."
msgtext(3) = "BMP mit diesen Einstellungen benötigt mindestens "
msgtext(4) = "Bytes freien Speicherplatz. Auf dem Datenträger sind aber nur"
msgtext(5) = "Bytes frei. Bitte wählen Sie anderen Speicherort"
'
msgtext(6) = " erfolgreich gesichert"
msgtext(7) = "Fehler beim Speichern (kein Schreibzugriff, Verzeichnis existiert nicht?)"
msgtext(8) = "Kein aktives Dokument"
'
msgtext(9) = "Ungefähre Dateigröße" & vbCrLf
msgtext(10) = "Bitmap in Pixel" & vbCrLf
End Sub
Private Sub EnglishString()
' used Strings in english
UserForm1.Caption = "Save as quality bitmap"
lblDesiredFileName.Caption = "Please enter your desired filename with complete path (extension should be *.bmp)"
cmdGenBitmap.Caption = "Save as bitmap"
cmdExit.Caption = "Exit"
lblWidth.Caption = "Width"
lblHeight.Caption = "Height"
optUnitPixel.Caption = "pixel"
optUnitZM.Caption = "centimeter"
optUnitInch.Caption = "inch"
lblDPI.Caption = "DPI (zm, inch)"
' some text, usually warning or error messages
msgtext(0) = "File exists. Continue anyway?"
msgtext(1) = "Filename extension is not BMP. Continue anyway?"
' warning message if not enough free space on device
msgtext(2) = "Not enough free space left on device."
msgtext(3) = "BMP with this settings needs at least "
msgtext(4) = "Bytes free diskspace. The destination drive has only"
msgtext(5) = "free bytes left. Please choose another drive to save."
'
msgtext(6) = " successfully saved"
msgtext(7) = "Error saving file (no write access, target directory exists?"
msgtext(8) = "No active document"
'
msgtext(9) = "approximately filesize" & vbCrLf
msgtext(10) = "Bitmap in pixel" & vbCrLf
End Sub
Private Sub SetPixelValue()
' procedure sets the global values for desired bitmapsize in
' pixel regardless of choosen units and DPI
' Die Prozedur rechnet die eingegebenen Werte immer in Pixel um
' abhängig von der gewählten Einheit und DPI
If myDontUpdate = True Then Exit Sub
If optUnitPixel.Value = True Then
' easy: pixel are pixel
myPixHeight = CLng(txtHeight.Value)
myPixWidth = CLng(txtWidth.Value)
ElseIf optUnitZM.Value = True Then
' 2.54 centimeter per inch * DPI
myPixHeight = CDbl(txtHeight.Value) * CDbl(txtDPI.Value) / 2.54
myPixWidth = CDbl(txtWidth.Value) * CDbl(txtDPI.Value) / 2.54
ElseIf optUnitInch.Value = True Then
' * DPI
myPixHeight = CDbl(txtHeight.Value) * CDbl(txtDPI.Value)
myPixWidth = CDbl(txtWidth.Value) * CDbl(txtDPI.Value)
End If
lblMyPixValues.Caption = msgtext(10) & myPixWidth & " x " & myPixHeight
End Sub
Private Sub ApproxFileSize()
' determine approximately file size and write it to label
' ungefähre Dateigröße ermitteln und in das Label schreiben
Dim kb
kb = CLng(myPixHeight * myPixWidth * 3 / 1024)
lblApproxFileSize.Caption = msgtext(9) & Format(kb, "#,###,###,##0") & " KB"
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 FreeSpace(RootPathName) As Double
Dim r As Long, BytesFreeToCalller As Currency, TotalBytes As Currency
Dim TotalFreeBytes As Currency, TotalBytesUsed As Currency
' get the drive's disk parameters
' die Parameter des Laufwerkes holen
Call GetDiskFreeSpaceEx(RootPathName, BytesFreeToCalller, TotalBytes, TotalFreeBytes)
' show the results, multiplying the returned value by 10000 to adjust
' for the 4 decimal places that the currency data type returns.
' und den Wert des verfügbaren, freien Speicherplatz zurückgeben, den Wert * 10000
' nehmen, um die 4 Nachkommastellen des
Currency-Datentyps richtig umzuwandeln
FreeSpace = BytesFreeToCalller * 10000
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
| Kritik und Anregungen bitte an Stefan Berlitz. Letzte Änderung dieser Seite am Donnerstag, 01. Februar 2007 17:40 |