The following dialog is a small part of one of many DLLs recompiled by PB9 for my project.
With PB8 the results were always OK. With PB9, this is the only one code which is compilable with success but is running into a windows crash whenever a call is done by clicking on one of the buttons defined in the 'Control Add' area. All other parts of the dialog are functioning well, however.
Have for example a look at the last button added: "Control Add ImgButton, ...."
It's definition also ends with a simple call: "Call CloseDialog()"
When it is clicked by mouse click, the sub is in fact executed but at it's end the whole DLL crashes with one of those common windows messages without sense.
It seems that the sub cannot return to the control of the DLL, but only if compiled with PB9 - not with PB8. (My OS here is XP SP3)
This is the first time I publish some meore code here in the forum, and evidently it is not easy to read. But nevertheless, it is necessary not to abreviate it because every step might give You a hint.
As far as necessary, I translated all my code comments to English. I hope someone of You might be able to see the bug at 'first sight'.
With PB8 the results were always OK. With PB9, this is the only one code which is compilable with success but is running into a windows crash whenever a call is done by clicking on one of the buttons defined in the 'Control Add' area. All other parts of the dialog are functioning well, however.
Have for example a look at the last button added: "Control Add ImgButton, ...."
It's definition also ends with a simple call: "Call CloseDialog()"
When it is clicked by mouse click, the sub is in fact executed but at it's end the whole DLL crashes with one of those common windows messages without sense.
It seems that the sub cannot return to the control of the DLL, but only if compiled with PB9 - not with PB8. (My OS here is XP SP3)
This is the first time I publish some meore code here in the forum, and evidently it is not easy to read. But nevertheless, it is necessary not to abreviate it because every step might give You a hint.
As far as necessary, I translated all my code comments to English. I hope someone of You might be able to see the bug at 'first sight'.
Code:
'================================================================================== ' MechaniCAD - SelFilter-Dialog ' Ingenieurbüro Dörre '================================================================================== '---------------------------------------------------------------------------------- ' INCLUDE FILES '---------------------------------------------------------------------------------- #RESOURCE "SelFilter.pbr" #IF NOT %DEF(%WINAPI) #INCLUDE "WIN32API.INC" #EndIf #INCLUDE "PBForms.INC" #include "..\mcToolTips.inc" #Include "..\mcApiType.inc" #Include "..\mcApiMain.inc" #Include "..\mcApiDlg.inc" #Include "..\mcInitOK.inc" #Include "..\DebugWin.inc" '---------------------------------------------------------------------------------- ' EQUATES '---------------------------------------------------------------------------------- 'ComboBox Control IDs %ID_imgMatch = 1001 %ID_imgByLayer = 1002 %ID_imgClose = 1003 %ID_imgFilter = 1004 %ID_cboEntity = 1041 %ID_cboLayer = 1042 %ID_cboColor = 1043 %ID_cboLtype = 1044 %ID_cboLwidth = 1045 %ID_btnFilter = 1046 %ID_btnHelp = 1047 %ID_btnMatch = 1048 %ID_txtRwidth = 1049 %ID_btnByLayer = 1050 %ID_btnClear = 1051 %ID_btnClose = 1052 '---------------------------------------------------------------------------------- ' global DIALOG VARIABLES '---------------------------------------------------------------------------------- 'Farb-Datensatz Type COLOR_TRIPEL Red As word Green As word Blue As word End Type Type ColorTableRecord szRecName As ASCIIZ * 32 ColTrip(1 to 256) As Color_Tripel 'Basis = 1 ! Separator as asciiz * 16 'Wird von Chamaeleon als Datensatztrenner angehängt, wenn ein weiterer Datensatz folgt. End Type global ColorTripels() as COLOR_TRIPEL global ColTabRec As ColorTableRecord global hDlg AS LONG 'Handle des Ribalog global xDlg AS LONG 'Rectangle des Ribalog global yDlg AS LONG ' global xxDlg AS LONG ' global yyDlg AS LONG ' global lDlgStyle AS LONG 'Stil des Ribalog global lDlgExStyle AS LONG 'Ex-Stil des Ribalog global ToolBarUsed AS LONG 'Werzeugleiste links Status global SpeedBarUsed AS LONG 'Werzeugleiste rechts Status global mcClientRect AS RECT 'WinTYPE nTop& nLeft& nRight& nBottom& global mcFrameRect AS RECT 'WinTYPE nTop& nLeft& nRight& nBottom& global hToolBarWnd AS LONG 'Handle des ToolBar-Fensters global oldCBprocCboColor AS LONG 'for subclassing, to hold original window procedure address global oldCBprocCboLayer AS LONG 'for subclassing, to hold original window procedure address global tfFileRead as integer 'Flag wenn *.pal gelesen ist global hCboEntity AS LONG 'Handle der Elemente-ComboBox global hCboLayer AS LONG 'Handle der Layer-ComboBox global hCboColor AS LONG 'Handle der Farb-ComboBox global hCboLtype AS LONG 'Handle der Linientyp-ComboBox global hCboLwidth AS LONG 'Handle der Linienbreite-ComboBox global hBtnFilter as long 'Handle des Filter-Buttons global hTxtRwidth as long 'Handle zu 'Wahre Linienbreite' global hBtnByLayer as long 'Handle des ByLayer-Buttons global hBtnMatch as long 'Handle des Übernehmen-Buttons global hBtnClear as long 'Handle Zurücksetzen-Buttons global hBtnHelp as long 'Handle des Hilfe-Buttons Global hBtnClose As Long 'Handle des Beenden-Buttons '---------------------------------------------------------------------------------- ' CALLBACK DECLARATIONS '---------------------------------------------------------------------------------- declare callback function CBDlgProc() declare callback function CBDlgHelp() declare CALLBACK function CBDlgSubClassTextbox() as long '---------------------------------------------------------------------------------- ' FUNCTION DECLARATIONS '---------------------------------------------------------------------------------- Declare Sub CloseDialog() Declare Sub SetupRibalog() Declare Sub ResizeRibalog() Declare Sub FillRibalogControls() Declare Sub MatchFilterByEntity() Declare Sub RefillLayerCombo() Declare Sub ShowDlgSelFilter() Declare Sub ControlProgramaticallyChangeFocus(ByVal hDlg As Long, ByVal CtlIdOld As Long, ByVal CtlIdNew As Long) Declare Sub RefreshDialog() Declare Function CBprocCboLayer(ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long Declare Function CBprocCboColor(ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long Declare Function GetQBColor(ByVal c As Long) As Long Declare Function ReadPaletteFromFile(ColorTripels() As COLOR_TRIPEL) As Long Declare Function Combo_SetItemData(ByVal hComboBox As Long, ByVal index As Long, ByVal nData As Long) As Long Declare Function Combo_GetItemData(ByVal hComboBox As Long, ByVal index As Long) As Long '---------------------------------------------------------------------------------- ' DIALOG ENTRY POINT (Dialog muß MODELESS sein.) '---------------------------------------------------------------------------------- Sub ShowDlgSelFilter() 'Zuerst den Dialog erzeugen SetupRibalog() FillRibalogControls() 'if style has DS_ABSALIGN bit set, then we are using 'screen coordinates and need to calculate the appropriate 'dialog units - resize and locate the ribalog as required IF (lDlgStyle AND %DS_ABSALIGN) THEN ResizeRibalog 'turn speedbar and/or toolbar off, if used IF SpeedBarUsed THEN EnableWindow MCGetToolBar(%TBTOP), 0& hToolBarWnd = MCGetToolBar(%TBLEFT) IF ToolBarUsed THEN EnableWindow MCGetToolBar(%TBLEFT), 0& 'display ribalog and wait for a button to be activated Dialog Show Modeless hDlg Call CBDlgProc 'program resumes here when ribalog is destroyed 'turn speedbar and/or toolbar back on, if used IF SpeedBarUsed THEN EnableWindow MCGetToolBar(%TBTOP), 1& IF ToolBarUsed THEN EnableWindow MCGetToolBar(%TBLEFT), 1& End Sub '---------------------------------------------------------------------------------- ' SUB ResizeRibalog (Der Dialog beginnt am linken Rand der MCADD client area) '---------------------------------------------------------------------------------- SUB ResizeRibalog() LOCAL xPix as long local yPix as long local xxPix as long local yyPix as long local mcFrameRectH as long local cyCaption as long local cyMenu as long mcFrameRectH = MCGethWndFrame() 'Handle des MCADD Fensterrahmens GetWindowRect(mcFrameRectH, mcFrameRect) 'MCADD Fensterrahmen GetClientRect(mcFrameRectH, mcClientRect) 'MCADD Fenster Client 'pixel height of window caption cyCaption = GetSystemMetrics(%SM_CYCAPTION) 'pixel height of menu area cyMenu = GetSystemMetrics(%SM_CYMENUSIZE) xPix = 0& 'Ursprung-x des SpeedBar yPix = 0& 'Ursprung-y des SpeedBar 'set Ribalog Width to current client area size xxPix = mcClientRect.nRight - mcClientRect.nLeft yyPix = 30 'entspricht yyDlg = 18 (s.o.) '--- convert PIXELS to DIALOG UNITS DIALOG PIXELS hDlg, xPix, yPix TO UNITS xDlg, yDlg DIALOG PIXELS hDlg, xxPix, yyPix TO UNITS xxDlg, yyDlg '--- set dialog to new location DIALOG SET LOC hDlg, xDlg, yDlg '--- set dialog to new size DIALOG SET SIZE hDlg, xxDlg, yyDlg '--- set dialog topmost SetWindowPos(hDlg, %HWND_TOPMOST, MCGetHwndFrame(), 0&, 0&, 0&, %SWP_SHOWWINDOW Or %SWP_DRAWFRAME Or %SWP_NOSIZE Or %SWP_NOMOVE) end sub '---------------------------------------------------------------------------------- ' SUB SetupRibalog '---------------------------------------------------------------------------------- SUB SetupRibalog local mcFrameRectH as long local hToolTip as long local lRes as long lDlgStyle& = %WS_POPUP Or %DS_SETFONT Or %DS_NOFAILCREATE mcFrameRectH = MCGethWndFrame() 'Handle des MCADD Fensterrahmens GetWindowRect(mcFrameRectH, mcFrameRect) 'MCADD Fensterrahmen-Abmessungen GetClientRect(mcFrameRectH, mcClientRect) 'MCADD Fenster Client-Abmessungen If xxDlg = 0 Or mcFrameRect.nLeft < -4 Or mcFrameRect.nRight > GetSystemMetrics(%SM_CXSCREEN) Then xDlg = mcFrameRect.nLeft yDlg = mcFrameRect.nTop xxDlg = 250 yyDlg = 18 'entspricht yyPix& = 30 (s.u.) lDlgStyle = lDlgStyle OR %DS_ABSALIGN End If ' reset flags and get current speedbar and toolbar status SpeedBarUsed& = 0& ToolBarUsed& = 0& If MCGetToolBar(%TBTOP) Then SpeedBarUsed& = 1& If MCGetToolBar(%TBLEFT) Then ToolBarUsed& = 1& Dialog New MCGethWndFrame(), "", xDlg, yDlg, xxDlg, yyDlg, lDlgStyle, lDlgExStyle To hDlg 'create the static controls (labels) immediately before the 'real control so that the keyboard accelerators (hotkeys) 'switch focus to the real control. CONTROL ADD LABEL, hDlg, -1, "Filter" & $CRLF & _ "Selektion", 2, 1, 32, 16 CONTROL ADD LABEL, hDlg, -1, "", 34, 0, 0, 19, %SS_ETCHEDVERT CONTROL ADD LABEL, hDlg, -1, "Elem.:", 37, 5, 19, 9 CONTROL ADD COMBOBOX, hDlg, %ID_cboEntity,, 57, 3, 70, 120, %CBS_DROPDOWNLIST or %WS_VSCROLL CONTROL ADD LABEL, hDlg, -1, "Layer:", 129, 5, 19, 9 CONTROL ADD COMBOBOX, hDlg, %ID_cboLayer,, 149, 3,105, 120, %CBS_OWNERDRAWFIXED OR %CBS_HASSTRINGS OR %CBS_DROPDOWNLIST OR %WS_TABSTOP OR %CBS_DISABLENOSCROLL OR %WS_VSCROLL CONTROL ADD LABEL, hDlg, -1, "Farbe:", 256, 5, 19, 9 CONTROL ADD COMBOBOX, hDlg, %ID_cboColor,, 276, 3, 45, 120, %CBS_OWNERDRAWFIXED OR %CBS_HASSTRINGS OR %CBS_DROPDOWNLIST OR %WS_TABSTOP OR %CBS_DISABLENOSCROLL OR %WS_VSCROLL CONTROL ADD LABEL, hDlg, -1, "LTyp:", 323, 5, 18, 9 CONTROL ADD COMBOBOX, hDlg, %ID_cboLtype,, 342, 3,110, 120, %CBS_DROPDOWNLIST or %WS_VSCROLL CONTROL ADD LABEL, hDlg, -1, "LBreite:", 454, 5, 23, 9 Control Add ComboBox, hDlg, %ID_cboLwidth,, 478, 3, 30, 120, %CBS_DROPDOWNLIST Or %WS_VSCROLL CONTROL ADD LABEL, hDlg, -1, "Wahre" & $CRLF & "LBreite:",510, 1, 24, 16 CONTROL ADD TEXTBOX, hDlg, %ID_txtRwidth, "0.0", 535, 3, 30, 13, %ES_LEFT or %WS_TABSTOP, %WS_EX_CLIENTEDGE CONTROL ADD IMGBUTTON, hDlg, %ID_btnByLayer,"#" + FORMAT$(%ID_imgByLayer),567, 3, 13, 13, %WS_CHILD OR %WS_VISIBLE OR %WS_TABSTOP OR %BS_BITMAP OR %BS_PUSHLIKE OR %BS_AUTOCHECKBOX OR _ %BS_CENTER Or %BS_MCENTER, %WS_EX_LEFT Or %WS_EX_LTRREADING Call UseByLayerProps() CONTROL ADD IMGBUTTON, hDlg, %ID_btnMatch, "#" + FORMAT$(%ID_imgMatch), 582, 3, 13, 13, %WS_CHILD OR %BS_PUSHBUTTON OR %BS_CENTER,%WS_EX_LEFT OR %WS_EX_LTRREADING call MatchFilterByEntity() CONTROL ADD IMGBUTTON, hDlg, %ID_btnFilter, "#" + FORMAT$(%ID_imgFilter), 597, 3, 13, 13, %WS_CHILD OR %WS_VISIBLE OR %WS_TABSTOP OR %BS_BITMAP OR %BS_PUSHLIKE OR %BS_AUTOCHECKBOX OR _ %BS_CENTER OR %BS_MCENTER, %WS_EX_LEFT OR %WS_EX_LTRREADING Control Add Button, hDlg, %ID_btnClear, "Neu", 612, 3, 20, 13, %BS_PUSHBUTTON Call RefreshDialog() Control Add Button, hDlg, %ID_btnHelp, "?", 634, 3, 13, 13, %BS_PUSHBUTTON Call CBDlgHelp() CONTROL ADD IMGBUTTON, hDlg, %ID_btnClose, "#" + FORMAT$(%ID_ImgClose), 649, 3, 13, 13, %WS_CHILD OR %BS_PUSHBUTTON OR %BS_CENTER,%WS_EX_LEFT OR %WS_EX_LTRREADING call CloseDialog() 'SubClassing der Eingabefelder für Dezimalzahlen. Nur Ziffern und ein Dezimalpunkt sind erlaubt CONTROL SET USER hDlg, %ID_txtRwidth, 1, SetWindowLong(GetDlgItem(hDlg, %ID_txtRwidth), %GWL_WNDPROC, CODEPTR(CBDlgSubClassTextbox)) 'Handles der Controls CONTROL HANDLE hDlg, %ID_cboEntity TO hCboEntity 'Handle der Elemente-ComboBox CONTROL HANDLE hDlg, %ID_cboLayer TO hCboLayer 'Handle der Layer-ComboBox CONTROL HANDLE hDlg, %ID_cboColor TO hCboColor 'Handle der Farb-ComboBox CONTROL HANDLE hDlg, %ID_cboLtype TO hCboLtype 'Handle der Linientyp-ComboBox CONTROL HANDLE hDlg, %ID_cboLwidth TO hCboLwidth 'Handle der Linienbreite-ComboBox CONTROL HANDLE hDlg, %ID_txtRwidth TO hTxtRwidth 'Handle zu 'Wahre Linienbreite' CONTROL HANDLE hDlg, %ID_btnByLayer TO hBtnByLayer 'Handle des ByLayer-Buttons CONTROL HANDLE hDlg, %ID_btnMatch TO hBtnMatch 'Handle des Übernehmen-Buttons CONTROL HANDLE hDlg, %ID_btnFilter TO hBtnFilter 'Handle des Filter-Buttons CONTROL HANDLE hDlg, %ID_btnClear TO hBtnClear 'Handle Zurücksetzen-Buttons CONTROL HANDLE hDlg, %ID_btnHelp TO hBtnHelp 'Handle des Hilfe-Buttons CONTROL HANDLE hDlg, %ID_btnClose TO hBtnClose 'Handle des Beenden-Buttons 'Entity-ComboBox füllen combobox add hDlg, %ID_cboEntity, "*Alle*" combobox add hDlg, %ID_cboEntity, "{0} Null-Element" combobox add hDlg, %ID_cboEntity, "{1} Einzellinie" combobox add hDlg, %ID_cboEntity, "{2} Bogen" combobox add hDlg, %ID_cboEntity, "{3} Kreis" combobox add hDlg, %ID_cboEntity, "{4} Ellipse" combobox add hDlg, %ID_cboEntity, "{5} Bezierbogen" combobox add hDlg, %ID_cboEntity, "{6} Hilfspunkt" combobox add hDlg, %ID_cboEntity, "{7} Block" combobox add hDlg, %ID_cboEntity, "{8} Text" combobox add hDlg, %ID_cboEntity, "{9} LinearBem" combobox add hDlg, %ID_cboEntity, "{10} WinkelBem" combobox add hDlg, %ID_cboEntity, "{11} RadiusBem" combobox add hDlg, %ID_cboEntity, "{12} DurchmBem" combobox add hDlg, %ID_cboEntity, "{13} Füllung" combobox add hDlg, %ID_cboEntity, "{14} Schraffur" combobox add hDlg, %ID_cboEntity, "{15} Attribut" combobox add hDlg, %ID_cboEntity, "{16} SplineBogen" combobox add hDlg, %ID_cboEntity, "{17} PolySpline" combobox add hDlg, %ID_cboEntity, "{18} ElliptBogen" combobox add hDlg, %ID_cboEntity, "{19} PolyLinie" combobox add hDlg, %ID_cboEntity, "{20} PolyBezier" combobox add hDlg, %ID_cboEntity, "{21} Führung" combobox add hDlg, %ID_cboEntity, "{22} Referenz" combobox add hDlg, %ID_cboEntity, "{23} OrdinateBem" 'In der Entity-Box das Item mit Index 0 selektieren CONTROL SEND hDlg, %ID_cboEntity, %CB_SETCURSEL, 0, 0 'ByLayer-Button übernimmt den ByLayer-Wert von MCADD control set check hDlg, %ID_btnByLayer, MCDrawingHasLayerProperties() 'ToolTips anfügen hToolTip = ToolTip_Create(hCboEntity) lRes = ToolTip_SetToolTip(hCboEntity,"Liste der filterbaren Elemente") hToolTip = ToolTip_Create(hCboLayer) lRes = ToolTip_SetToolTip(hCboLayer,"Liste der filterbaren Layer") hToolTip = ToolTip_Create(hCboColor) lRes = ToolTip_SetToolTip(hCboColor,"Liste der filterbaren Farben") hToolTip = ToolTip_Create(hCboLtype) lRes = ToolTip_SetToolTip(hCboLtype,"Liste der filterbaren Linientypen") hToolTip = ToolTip_Create(hCboLwidth) lRes = ToolTip_SetToolTip(hCboLwidth,"Liste der filterbaren Linienbreiten") hToolTip = ToolTip_Create(hTxtRwidth) lRes = ToolTip_SetToolTip(hTxtRwidth,"Eingabe der wahren Linienbreite") hToolTip = ToolTip_Create(hBtnByLayer) lRes = ToolTip_SetToolTip(hBtnByLayer,"Layerparameter verwenden/nicht verwenden") hToolTip = ToolTip_Create(hBtnMatch) lRes = ToolTip_SetToolTip(hBtnMatch,"Parameter von Objekt übernehmen") hToolTip = ToolTip_Create(hBtnFilter) lRes = ToolTip_SetToolTip(hBtnFilter,"Filter aktivieren/deaktivieren") hToolTip = ToolTip_Create(hBtnClear) lRes = ToolTip_SetToolTip(hBtnClear,"Filter zurücksetzen") hToolTip = ToolTip_Create(hBtnHelp) lRes = ToolTip_SetToolTip(hBtnHelp,"Hilfe") hToolTip = ToolTip_Create(hBtnClose) lRes = ToolTip_SetToolTip(hBtnClose,"Filterwerkzeug beenden") end sub '---------------------------------------------------------------------------------- ' SUB FillRibalogControls '---------------------------------------------------------------------------------- sub FillRibalogControls() local iError as integer local sLayerName as string local szName as asciiz * 64 local iRes as integer local sProps as string local sLtName as string local szLtName as asciiz * 64 local ItemIndex as long local i as long 'Layer-ComboBox füllen ItemIndex = 0 'ItemIndex zurücksetzen combobox add hDlg, %ID_cboLayer, "*Alle*" 'für "nichts selektiert" For i = 0 to 1023 'Prüfen, ob Layer Daten enthält if MCGetLayerHasData(iError, i) then 'Layer enthält Elemente? 'Properties anhängen if MCLayerHasProperties(iError, i) then 'Layer hat Layerparameter? fLayerLineWidthValue = -1 if MCGetLayerProperties(iError, i, iLayerColorIndex, iLayerLineTypeIndex, iLayerLineWidthIndex, fLayerLineWidthValue) then if fLayerLineWidthValue <= 0 then fLayerLineWidthValue = -1 'Property-Einträge in Combobox sProps = "{--} " if iLayerLineTypeIndex > -1 then mid$(sProps, 2, 1) = "t" if iLayerLineWidthIndex > -1 then mid$(sProps, 3, 1) = "w" elseif fLayerLineWidthValue > 0.0 then mid$(sProps, 3, 1) = "r" end if end if else 'Layer hat keine Layerparameter sProps = "{--} " end if 'Layernamen abfragen iRes = MCGetLayerNameFromIndex(iError, i, szName) sLayerName = left$(szName, iRes) if len(sLayerName) = 0 then sLayername = trim$(str$(i)) 'Hat der Layer keinen Namen, dann LayerIndex verwenden. 'Item an ComboBox anhängen ItemIndex = ItemIndex + 1 'ItemIndex für neues ComboBox-Item inkrementieren combobox add hDlg, %ID_cboLayer, sProps & sLayerName 'Neue ComboBox anfügen if Combo_SetItemData(hCboLayer, ItemIndex, i) = %CB_ERR then msgbox "%CB_ERR",%MB_SYSTEMMODAL, "SelFilter" 'LayerIndex als Itemdata anfügen end if end if next i 'Layerfarben hinzufügen IF hCboLayer THEN oldCBprocCboLayer = GetWindowLong(hCboLayer, %GWL_WNDPROC) IF oldCBprocCboLayer THEN SetWindowLong hCboLayer, %GWL_WNDPROC, CODEPTR(CBprocCboLayer) 'Item mit Index 0 selektieren ItemIndex = 0 CONTROL SEND hDlg, %ID_cboLayer, %CB_SETCURSEL, ItemIndex, 0 'Linienfarben-ComboBox füllen combobox add hDlg, %ID_cboColor, "*Alle*" 'für "nichts selektiert" For i = 0 to 255 'Es folgen 256 Farbnummern, mit ItemIndex = 1 startend combobox add hDlg, %ID_cboColor, str$(i) next i 'Linienfarben hinzufügen IF hCboColor THEN oldCBprocCboColor = GetWindowLong(hCboColor, %GWL_WNDPROC) IF oldCBprocCboColor THEN SetWindowLong hCboColor, %GWL_WNDPROC, CODEPTR(CBprocCboColor) 'Item mit Index 0 selektieren CONTROL SEND hDlg, %ID_cboColor, %CB_SETCURSEL, 0, 0 'Linientypen-ComboBox füllen (kein Subclassing) combobox add hDlg, %ID_cboLtype, "*Alle*" 'für "nichts selektiert" for i = 0 to 255 'Es folgen 256 Linientypen, mit ItemIndex = 1 startend iRes = MCGetLineTypeNameFromIndex(iError, i, szLtName) sLtName = left$(szLtName, iRes) if len(sLtName) > 0 then combobox add hDlg, %ID_cboLtype, "{" & trim$(str$(i)) & "} " & sLtName end if next i 'Item mit Index 0 selektieren (kein Subclassing) CONTROL SEND hDlg, %ID_cboLtype, %CB_SETCURSEL, 0, 0 'Linienbreiten-ComboBox füllen combobox add hDlg, %ID_cboLwidth, "*Alle*" 'für "nichts selektiert" for i = 0 to 15 ' 'Es folgen 16 Linienbreiten, mit ItemIndex = 1 startend combobox add hDlg, %ID_cboLwidth, str$(i) next i 'Item mit Index 0 selektieren CONTROL SEND hDlg, %ID_cboLwidth, %CB_SETCURSEL, 0, 0 'TextBox für wahre Linienbreite vorbelegen CONTROL SET TEXT hDlg, %ID_txtRwidth, "*Alle*" END SUB '---------------------------------------------------------------------------------- ' SUB ControlChangeFocus '---------------------------------------------------------------------------------- SUB ControlProgramaticallyChangeFocus(BYVAL hDlg AS LONG, BYVAL CtlIdOld AS LONG, Byval CtlIdNew as long) 'Wechsel des Focus von %CtlID_A zu %CtlId_B ' CONTROL SEND hDlg, CtlId_A, %BM_SETSTYLE, %BS_PUSHBUTTON, %TRUE ' CONTROL SET FOCUS hDlg, CtlId_B ' CONTROL SEND hDlg, CtlId_B, %BM_SETSTYLE, %BS_DEFPUSHBUTTON, %TRUE END SUB '---------------------------------------------------------------------------------- ' CALLBACK FUNCTION DlgProc '---------------------------------------------------------------------------------- CallBack Function CBDlgProc() Local sRet As String Local lRes As Long Local iError As Integer Local SelectedItem As Long Local ItemData As Integer Local X As Dword Local ItemIndex As Long 'Dialog Messages auswerten Select Case CbMsg Case %WM_COMMAND Select Case CbCtl Case %ID_btnFilter Control Get Check hDlg, %ID_btnFilter To lRes If lRes = 1 Then 'Entity Control Send CbHndl, %ID_cboEntity, %CB_GETCURSEL, 0, 0 To lRes If lres = 0 Then iFilterEntityKind = -1 Else iFilterEntityKind = CInt(lRes - 1) 'Die Entity-Liste startet mit "*Alle*" bei Index 0 End If 'Layer Control Send CbHndl, %ID_cboLayer, %CB_GETCURSEL, 0, 0 To ItemIndex If ItemIndex = 0 Then iFilterLayerIndex = -1 Else lRes = Combo_GetItemData(hCboLayer, ItemIndex) iFilterLayerIndex = CInt(lRes) End If 'Color Control Send CbHndl, %ID_cboColor, %CB_GETCURSEL, 0, 0 To lRes If lres = 0 Then iFilterColorIndex = -1 ElseIf lRes > 0 Then iFilterColorIndex = CInt(lRes - 1) 'Die Color-Liste startet mit "*Alle*" bei Index 0 End If 'LineType Control Send CbHndl, %ID_cboLtype, %CB_GETCURSEL, 0, 0 To lRes If lres = 0 Then iFilterLineTypeIndex = -1 ElseIf lRes > 0 Then iFilterLineTypeIndex = CInt(lRes - 1) 'Die lineType startet mit "*Alle*" bei Index 0 End If 'LineWidth Control Send CbHndl, %ID_cboLwidth, %CB_GETCURSEL, 0, 0 To lRes If lres = 0 Then iFilterLineWidthIndex = -1 ElseIf lRes > 0 Then iFilterLineWidthIndex = CInt(lRes - 1) End If 'LineWidthValue Control Get Text hDlg, %ID_txtRwidth To sRet If sRet = "*Alle*" Then fFilterLineWidthValue = -1 ElseIf Val(sRet) > 0 Then fFilterLineWidthValue = CSng(Val(sRet)) End If 'Filterkriterien anwenden MCSetHighLight(iError, 1) 'Filter deaktivieren MCSetFilterActive(iError, 0) 'Filter zurücksetzen MCFilterReset(iError) MCSetFilterKind(iError, iFilterEntityKind) MCSetFilterLayer(iError, iFilterLayerIndex) MCSetFilterColor(iError, iFilterColorIndex) MCSetFilterLineType(iError, iFilterLineTypeIndex) MCSetFilterWidth(iError, iFilterLineWidthIndex) 'Filter aktivieren MCSetFilterActive(iError, 1) 'Es muß nach Aktivierung des Filters sofort selektiert werden. 'Ein Klick in die Zeichnung, der nicht zur Selektion führt, setzt das Filter inaktiv. 'Zur Selektion meherer Objekte muß unmittelbar ein Selektionsbefehl eingegeben werden. End If Exit Function Case %ID_btnByLayer Control Get Check hDlg, %ID_btnByLayer To lRes MCSetByLayerStatus(lRes) RefillLayerCombo() Case %ID_cboEntity If HiWrd(CbWParam) = %CBN_SELENDOK Then SelectedItem = SendMessage(CbLParam, %CB_GETCURSEL, 0, 0) iFilterEntityKind = SelectedItem - 1 'In ItemIndex = 0 befindet sich '----'. 'Edit-Liste der Elementparameter öffnen Select Case iFilterEntityKind Case %SYMBOL2D, %DIMLINEAR2D, %DIMANGULAR2D, %DIMRADIAL2D, %DIMDIAMETER2D, %LEADER2D, %ORDDIM2D 'Bemaßung kann Entity-Layer und Entity-Farbe besitzen. iEntityLineTypeIndex = -1 iEntityLineWidthIndex = -1 fEntityLineWidthValue = -1 Control Disable hDlg, %ID_cboLtype Control Disable hDlg, %ID_cboLwidth Control Disable hDlg, %ID_txtRwidth End Select Function = 0 Exit Function End If Case %ID_cboLayer 'Wenn LP verwendet werden, dann ggf. Farbe, LTyp und LBreite als LP anzeigen If HiWrd(CbWParam) = %CBN_SELENDOK Then SelectedItem = SendMessage(CbLParam, %CB_GETCURSEL, 0, 0) 'der gewählte LayerIndex 'Auslesen der Layernummer als ItemData: If SelectedItem > 0 Then ItemData = Combo_GetItemData(hCboLayer, SelectedItem) iFilterLayerIndex = ItemData 'Testen, ob Layerparameter vorhanden fFilterLineWidthValue = -1 'Die wahre Linienbreite wird nicht automatisch zurückgesetzt. 'ItemData enthält den LayerIndex des aktuellen Items. Layerparameter dieses Layerindex ermitteln. If MCLayerHasProperties(iError, iFilterLayerIndex) Then 'Layer hat Layerparameter iLayerColorIndex = -1 iLayerLineTypeIndex = -1 iLayerLineWidthIndex = -1 fLayerLineWidthValue = -1 MCGetLayerProperties(iError, ItemData, iLayerColorIndex, iLayerLineTypeIndex, iLayerLineWidthIndex, fLayerLineWidthValue) If fLayerLineWidthValue <= 0.0 Then fLayerLineWidthValue = -1 End If 'Die ComboBox-Items selektieren, bezogen auf Layerparameter ComboBox Select hDlg, %ID_cboColor, iLayerColorIndex + 2 'Offset = 2 iFilterColorIndex = iLayerColorIndex ComboBox Select hDlg, %ID_cboLtype, iLayerLineTypeIndex + 2 iFilterLineTypeIndex = iLayerLineTypeIndex ComboBox Select hDlg, %ID_cboLwidth, iLayerLineWidthIndex + 2 iFilterLineWidthIndex = iLayerLineWidthIndex 'Wahre Linienbreite If fLayerLineWidthValue > 0.0 Then fFilterLineWidthValue = fLayerLineWidthValue Control Set Text hDlg, %ID_txtRwidth, Str$(fFilterLineWidthValue * dUCF) ElseIf fLayerLineWidthValue = -1 Then fFilterLineWidthValue = -1 If fEntityLineWidthValue > 0.0 Then fFilterLineWidthValue = fEntityLineWidthValue End If End If If fFilterLineWidthValue = -1 Then Control Set Text hDlg, %ID_txtRwidth, "*Alle*" ElseIf fFilterLineWidthValue > 0.0 Then Control Set Text hDlg, %ID_txtRwidth, Str$(fLayerLineWidthValue * dUCF) End If End If End If End If Case %ID_cboColor If HiWrd(CbWParam) = %CBN_SELENDOK Then SelectedItem = SendMessage(CbLParam, %CB_GETCURSEL, 0, 0) iFilterColorIndex = SelectedItem - 1 'In ItemIndex = 0 befindet sich '----'. Function = 0 Exit Function End If Case %ID_cboLtype If HiWrd(CbWParam) = %CBN_SELENDOK Then SelectedItem = SendMessage(CbLParam, %CB_GETCURSEL, 0, 0) iFilterLineTypeIndex = SelectedItem - 1 'In ItemIndex = 0 befindet sich '----'. Function = 0 Exit Function End If Case %ID_cboLwidth If HiWrd(CbWParam) = %CBN_SELENDOK Then SelectedItem = SendMessage(CbLParam, %CB_GETCURSEL, 0, 0) iFilterLineWidthIndex = SelectedItem - 1'In ItemIndex = 0 befindet sich '----'. Function = 0 Exit Function End If End Select Case %WM_DESTROY 'Un-subclass Combobox If oldCBprocCboColor Then SetWindowLong GetDlgItem(CbHndl, %ID_cboColor), %GWL_WNDPROC, oldCBprocCboColor ElseIf oldCBprocCboLayer Then SetWindowLong GetDlgItem(CbHndl, %ID_cboLayer), %GWL_WNDPROC, oldCBprocCboLayer End If Control Get User CbHndl, %ID_txtRwidth, 1 To X 'Unsubclass the control... it is not wise to skip this step! SetWindowLong GetDlgItem(CbHndl, %ID_txtRwidth), %GWL_WNDPROC, X Case %WM_DRAWITEM, %WM_MEASUREITEM 'Pass these on to CBprocCbo ... Select Case CbWParam Case %ID_cboColor 'ComboBox mit Grafik CBprocCboColor GetDlgItem(CbHndl, %ID_cboColor), CbMsg, CbWParam, CbLParam Function = 0 Exit Function Case %ID_cboLayer 'ComboBox mit Grafik CBprocCboLayer GetDlgItem(CbHndl, %ID_cboLayer), CbMsg, CbWParam, CbLParam Function = 0 Exit Function End Select End Select End Function '---------------------------------------------------------------------------------- ' Subclassed Layer Combobox '---------------------------------------------------------------------------------- FUNCTION CBProcCboLayer(BYVAL hWnd AS LONG, BYVAL wMsg AS LONG, BYVAL wParam AS LONG, BYVAL lParam AS LONG) AS LONG SELECT CASE wMsg CASE %WM_MEASUREITEM 'Don't need it here, keep it for ev. future use CASE %WM_DRAWITEM LOCAL hBrush AS LONG local hBrushOld AS LONG local rct AS RECT local szText AS ASCIIZ * 128 LOCAL lpdis AS DRAWITEMSTRUCT PTR local iError as integer local ItemData as long lpdis = lParam IF @lpdis.itemID < 0 THEN EXIT FUNCTION 'Der Item-Index der Layer-ComboBox SELECT CASE @lpdis.itemAction CASE %ODA_DRAWENTIRE, %ODA_SELECT 'CLEAR BACKGROUND hBrush = CreateSolidBrush(GetSysColor(%COLOR_WINDOW)) 'Create a background brush hBrushOld = SelectObject(@lpdis.hDC, hBrush) 'Select brush into device context FillRect(@lpdis.hDC, @lpdis.rcItem, hBrush) 'Paint background color rectangle SelectObject(@lpdis.hDC, hBrushOld) 'Select old brush back DeleteObject(hBrush) 'Delete brush 'DRAW TEXT SetBkColor(@lpdis.hDC, GetSysColor(%COLOR_WINDOW)) 'Set text Background SetTextColor(@lpdis.hDC, GetSysColor(%COLOR_WINDOWTEXT)) 'Set text color SendMessage(hWnd, %CB_GETLBTEXT, @lpdis.itemID, VARPTR(szText)) 'Get text TextOut(@lpdis.hDC, 16, @lpdis.rcItem.ntop + 2, szText, LEN(szText)) 'Draw text 'ITEM SELECTED IF (@lpdis.itemState AND %ODS_SELECTED) THEN 'Item ist selektiert rct.nLeft = 16 'Set cordinates rct.nRight = @lpdis.rcItem.nRight rct.ntop = @lpdis.rcItem.ntop rct.nbottom = @lpdis.rcItem.nbottom '# InvertRect(@lpdis.hDC, rct) 'invert area around text only DrawFocusRect(@lpdis.hDC, @lpdis.rcItem) 'and draw a focus rectangle around all END IF 'PAINT COLOR RECTANGLE (using RoundRect for nicer looks.. :-) 'Here you can customize if you like - like BitBlt bitmaps via a memDC 'instead, or use DrawFrameControl to draw a "fake" checkbox, etc... 'Layerfarben auslesen und in Combo eintragen rct.nLeft = 4 'Set cordinates rct.nRight = 14 rct.ntop = @lpdis.rcItem.ntop + 3 rct.nbottom = @lpdis.rcItem.nbottom - 3 if @lpdis.itemID > 0 then 'Item 0 ist ja mit "*Alle*" belegt ItemData = Combo_GetItemData(hCboLayer, @lpdis.itemID) 'Den LayerIndex aus Itemdata lesen if MCGetLayerProperties(iError, ItemData, iFilterColorIndex, iFilterLineTypeIndex, iFilterLineWidthIndex, fFilterLineWidthValue) then 'Farbe aus LP lesen if iFilterColorIndex > -1 then 'nur wenn Layerfarbe vorhanden hBrush = CreateSolidBrush(GetQBColor(iFilterColorIndex + 1)) 'Pinsel mit Farbe erzeugen. (+ 1, da Combo mit '----' = Index 0 startet.) hBrushOld = SelectObject(@lpdis.hDC, hBrush) 'Select brush into device context RoundRect(@lpdis.hDC, rct.nLeft, rct.ntop, rct.nRight, rct.nbottom, 3, 3) 'Abgerundetes Rechteck zeichnen SelectObject(@lpdis.hDC, hBrushOld) 'Select old brush back DeleteObject(hBrush) 'Delete brush end if end if end if END SELECT FUNCTION = %TRUE EXIT FUNCTION END SELECT FUNCTION = CallWindowProc(oldCBprocCboLayer, hWnd, wMsg, wParam, lParam) 'process other messages END FUNCTION '---------------------------------------------------------------------------------- ' Subclassed Color Combobox CBprocCboColor '---------------------------------------------------------------------------------- Function CBprocCboColor(ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long SELECT CASE wMsg CASE %WM_MEASUREITEM 'Don't need it here, keep it for ev. future use CASE %WM_DRAWITEM LOCAL hBrush AS LONG local hBrushOld AS LONG local rct AS RECT local szText AS ASCIIZ * 128 LOCAL lpdis AS DRAWITEMSTRUCT PTR lpdis = lParam IF @lpdis.itemID = -1 THEN EXIT FUNCTION SELECT CASE @lpdis.itemAction CASE %ODA_DRAWENTIRE, %ODA_SELECT 'CLEAR BACKGROUND hBrush = CreateSolidBrush(GetSysColor(%COLOR_WINDOW)) 'Create a background brush hBrushOld = SelectObject(@lpdis.hDC, hBrush) 'Select brush into device context FillRect(@lpdis.hDC, @lpdis.rcItem, hBrush) 'Paint background color rectangle SelectObject(@lpdis.hDC, hBrushOld) 'Select old brush back DeleteObject(hBrush) 'Delete brush 'DRAW TEXT SetBkColor(@lpdis.hDC, GetSysColor(%COLOR_WINDOW)) 'Set text Background SetTextColor(@lpdis.hDC, GetSysColor(%COLOR_WINDOWTEXT)) 'Set text color SendMessage(hWnd, %CB_GETLBTEXT, @lpdis.itemID, VARPTR(szText)) 'Get text TextOut(@lpdis.hDC, 24, @lpdis.rcItem.ntop + 2, szText, LEN(szText)) 'Draw text 'SELECTED ITEM IF (@lpdis.itemState AND %ODS_SELECTED) THEN 'if selected rct.nLeft = 22 'Set cordinates rct.nRight = @lpdis.rcItem.nRight rct.ntop = @lpdis.rcItem.ntop rct.nbottom = @lpdis.rcItem.nbottom '# InvertRect(@lpdis.hDC, rct) 'invert area around text only DrawFocusRect(@lpdis.hDC, @lpdis.rcItem) 'and draw a focus rectangle around all END IF 'PAINT COLOR RECTANGLE (using RoundRect for nicer looks.. :-) ' Here you can customize if you like - like BitBlt bitmaps via a memDC ' instead, or use DrawFrameControl to draw a "fake" checkbox, etc... if @lpdis.itemID > 0 then 'Wegen "*Alle*" nur durchführen, wenn ListIndex > 0 rct.nLeft = 4 'Set cordinates rct.nRight = 20 rct.ntop = @lpdis.rcItem.ntop + 3 rct.nbottom = @lpdis.rcItem.nbottom - 3 hBrush = CreateSolidBrush(GetQBColor(@lpdis.itemID)) 'Create brush with proper color (-1, weil "*Alle*" zusätzlich ist) hBrushOld = SelectObject(@lpdis.hDC, hBrush) 'Select brush into device context RoundRect(@lpdis.hDC, rct.nLeft, rct.ntop, rct.nRight, rct.nbottom, 3, 3) 'Draw SelectObject(@lpdis.hDC, hBrushOld) 'Select old brush back DeleteObject(hBrush) 'Delete brush end if END SELECT FUNCTION = %TRUE EXIT FUNCTION END SELECT FUNCTION = CallWindowProc(oldCBprocCboColor, hWnd, wMsg, wParam, lParam) 'process other messages END FUNCTION '------------------------------------------------------------------------------------------------------- ' Subclassed Textbox CBDlgSubClassTextbox, nur Eingabe von Ziffern und Dezimalpunkt möglich '------------------------------------------------------------------------------------------------------- CALLBACK function CBDlgSubClassTextbox() as long LOCAL x AS DWORD LOCAL y AS ASCIIZ * %MAX_PATH SELECT CASE CBMSG CASE %WM_CHAR ' Nur Eingabe von Zahlen und Dezimalpunkt möglich IF ISFALSE INSTR("0123456789.-" + $BS + $TAB, CHR$(CBWPARAM)) THEN BEEP EXIT FUNCTION end if ' Allow only one "." in the control, so discard any additional periods IF CHR$(CBWPARAM) = "." THEN GetWindowText CBHNDL, y, SIZEOF(y) IF INSTR(y, ".") THEN BEEP EXIT FUNCTION end if elseif CHR$(CBWPARAM) = "-" THEN control set text hDlg, %ID_txtRwidth, "---" 'drei '-' hinzufügen fFilterLineWidthValue = -1 END IF CASE %WM_PASTE ' We'll simply prevent pasting, but you might like to open the clipboard ' and validate the data before allowing or disallowing the paste BEEP EXIT FUNCTION END SELECT DIALOG GET USER CBHNDL, 1 TO x FUNCTION = CallWindowProc(x, CBHNDL, CBMSG, CBWPARAM, CBLPARAM) END FUNCTION '---------------------------------------------------------------------------------- ' FUNCTION GetQBColor '---------------------------------------------------------------------------------- FUNCTION GetQBColor(BYVAL iIndex AS LONG) AS LONG if tfFileRead = 0 then function = rgb(ColTabRec.ColTrip(iIndex).Red, ColTabRec.ColTrip(iIndex).Green, ColTabRec.ColTrip(iIndex).Blue) end if END FUNCTION '------------------------------------------------------------------------------------------------------- ' FUNCTION ReadPaletteFromFile (Die Mcadd-Farbnummer 0 hat hier den Index 1) '------------------------------------------------------------------------------------------------------- Function ReadPaletteFromFile(ColorTripels() As COLOR_TRIPEL) As Long 'Farbtabelle einlesen als Farbtripel{R, G, B} local iLastPalIndex as long local i as long local FH as long local sMcaddPath as string local sRes as string local szFixed as asciiz * 32 sRes = RegGetVal(%HKEY_CURRENT_USER, "Software\I B D\MechaniCAD\Main\Addon\Chamaeleon", "LastPaletteIndex") if len(sRes) = 0 then iLastPalIndex = 1 else iLastPalIndex = CInt(Val(sRes)) + 1 '1-basierend End if sMcaddPath = RegGetVal(%HKEY_CURRENT_USER, "Software\I B D\MechaniCAD\Main\Paths\", "System") redim ColorTripels(1 to 256) '---> Basis = 1 FH = freefile OPEN sMcaddPath & "COLORS.DEF" For Random As #FH Len = len(ColTabRec) if seek(FH) > 0 then Get #FH, iLastPalIndex, ColTabRec szFixed = ColTabRec.szRecName 'Name des Farbdatensatzes For i = 1 To 256 'nur Indizes 1...256 stammen aus COLORS.DEF, Index 1 ist fest programmiert mit (0,0,0), Index 47 mit (0,0,0 und Index 48 mit (255,255,255) ColorTripels(i).Red = ColTabRec.ColTrip(i).RED '---> Basis = 1 ColorTripels(i).Green = ColTabRec.ColTrip(i).green ColorTripels(i).Blue = ColTabRec.ColTrip(i).blue 'debug left$(szFixed, 32) 'debug str$(i) & " => " & str$(lowrd(ColorTripels(i).red)) & " " & str$(lowrd(ColorTripels(i).green)) & " " & str$(lowrd(ColorTripels(i).blue)) Next i function = 0 else msgbox "Die Datei 'COLORS.DEF' ist leer." & $crlf & _ "Zuerst mit 'Chamaeleon' die Farbpaletten" & $crlf & _ "*.pal einlesen und zu 'COLORS.DEF' sichern.",%MB_SYSTEMMODAL, "SelFilter Fehler" close #FH CloseDialog() end if close #FH end function '---------------------------------------------------------------------------------- ' FUNCTION Combo_SetItemData (wenn ohne #INCLUDE CommCtrl.inc kompiliert) '---------------------------------------------------------------------------------- 'Fügt an die ComboBox mit Handle 'hComboBox' den Wert von ItemData 'nData' an das Item mit Index 'iItemIndex' 'Fehlerrückgabe als %CB_ERR FUNCTION Combo_SetItemData(BYVAL hComboBox AS LONG, BYVAL iItemIndex AS LONG, BYVAL nData AS LONG) AS LONG FUNCTION = SendMessage(hComboBox, %CB_SETITEMDATA, iItemIndex, nData) END FUNCTION '---------------------------------------------------------------------------------- ' FUNCTION Combo_GetItemData (wenn ohne #INCLUDE CommCtrl.inc kompiliert) '---------------------------------------------------------------------------------- 'Liest von der ComboBox mit Handle hComboBox den Funktionswert als ItemData des Items mit Index 'iItemIndex' 'Ein Index von -1 gibt das aktuell selektierte Item zurück. 'Fehlerrückgabe als %CB_ERR FUNCTION Combo_GetItemData(BYVAL hComboBox AS LONG, BYVAL iItemIndex AS LONG) AS LONG IF iItemIndex < 0 THEN iItemIndex = SendMessage(hComboBox, %CB_GETCURSEL, 0, 0) END IF FUNCTION = SendMessage(hComboBox, %CB_GETITEMDATA, iItemIndex, 0) END FUNCTION '---------------------------------------------------------------------------------- ' SUB MatchFilter '---------------------------------------------------------------------------------- Sub MatchFilterByEntity() iFilterEntityKind = -1 iFilterLayerIndex = -1 iFilterColorIndex = -1 iFilterLineTypeIndex = -1 iFilterLineWidthIndex = -1 fFilterLineWidthValue = -1.0 'UserTool und Prompt initialisieren MCSetUserTool(1, "SelFilter", " Filterparameter von Objekt kopieren =>") end sub '---------------------------------------------------------------------------------- ' SUB RefillLayerCombo '---------------------------------------------------------------------------------- sub RefillLayerCombo() 'Layer-ComboBox neu füllen local iError as integer local ItemIndex as integer local sProps as string local szName as asciiz * 64 local sLayerName as string local iRes as integer ItemIndex = 0 'ItemIndex zurücksetzen combobox reset hDlg, %ID_cboLayer combobox add hDlg, %ID_cboLayer, "*Alle*" 'für "nichts selektiert" For iFilterLayerIndex = 0 to 1023 'Es folgen 1024 Layernummern if MCGetLayerHasData(iError, iFilterLayerIndex) then 'Layer enthält Elemente 'Properties anhängen if MCLayerHasProperties(iError, iFilterLayerIndex) then 'Layer hat Layerparameter fLayerLineWidthValue = -1 if MCGetLayerProperties(iError, iFilterLayerIndex, iLayerColorIndex, iLayerLineTypeIndex, iLayerLineWidthIndex, fLayerLineWidthValue) then if fLayerLineWidthValue <= 0 then fLayerLineWidthValue = -1 'Property-Einträge in Combobox sProps = "{--} " if iLayerLineTypeIndex > -1 then mid$(sProps, 2, 1) = "t" if iLayerLineWidthIndex > -1 then mid$(sProps, 3, 1) = "w" elseif fLayerLineWidthValue > 0.0 then mid$(sProps, 3, 1) = "r" end if end if else 'Layer hat keine Layerparameter sProps = "{--} " end if 'Layernamen abfragen iRes = MCGetLayerNameFromIndex(iError, iFilterLayerIndex, szName) sLayerName = left$(szName, iRes) if len(sLayerName) = 0 then sLayername = trim$(str$(iFilterLayerIndex)) 'Hat der Layer keinen Namen, dann LayerIndex verwenden. 'Item an ComboBox anhängen ItemIndex = ItemIndex + 1 'ItemIndex für neues ComboBox-Item inkrementieren combobox add hDlg, %ID_cboLayer, sProps & sLayerName 'Neue ComboBox anfügen if Combo_SetItemData(hCboLayer, ItemIndex, iFilterLayerIndex) = %CB_ERR then msgbox "%CB_ERR", %MB_SYSTEMMODAL, "SelFilter" 'LayerIndex als Itemdata anfügen end if end if next iFilterLayerIndex COMBOBOX SELECT hDlg, %ID_cboLayer, 1 end sub '---------------------------------------------------------------------------------- ' SUB ClearDialog '---------------------------------------------------------------------------------- Sub RefreshDialog() Local iError As Integer Local lRet As Long 'Aktuellen Dialog beenden Dialog End hDlg If UBound(ColorTripels()) = -1 Then lRet = ReadPaletteFromFile(ColorTripels()) end if 'Dialog neu aufrufen ShowDlgSelFilter() 'Indizes der ComboBoxen zurücksetzen ComboBox Select hDlg, %ID_cboEntity, 1 ComboBox Select hDlg, %ID_cboLayer, 1 ComboBox Select hDlg, %ID_cboColor, 1 ComboBox Select hDlg, %ID_cboLtype, 1 ComboBox Select hDlg, %ID_cboLwidth, 1 Control Set Text hDlg, %ID_txtRwidth, "*Alle*" 'Filterparameter zurücksetzen iFilterEntityKind = -1 iFilterLayerIndex = -1 iFilterColorIndex = -1 iFilterLineTypeIndex = -1 iFilterLineWidthIndex = -1 fFilterLineWidthValue = -1 End Sub '---------------------------------------------------------------------------------- ' CALLBACK FUNCTION DlgHelp_CallBack '---------------------------------------------------------------------------------- callback function CBDlgHelp() local sMsg as string local lRet as long sMsg = "Das Werkzeug 'SelFilter' (Selektieren mit Filter) zeigt in seinem Dialog" & $CrLf & _ "die Comboboxen der Kriterien an, mit denen gefiltert werden kann. Die Wahl" & $crlf & _ "von '*Alle*' macht das entsprechende Filterkriterium unwirksam." & $CrLf & $CrLf & _ "1. Die Elemente-Box läßt die Auswahl des zu filternden Elements zu." & $CrLf & _ "2. Die Layer-Box zeigt nur Layer an, die Daten enthalten." & $CrLf & _ "3. Die Farb-Box zeigt die Filterfarben an. Dies geschieht abhängig vom" & $CrLf & _ " gewählten Layer, der ggf. eine Layerfarbe bestimmt." & $CrLf & _ "4. Die Linientyp-Box zeigt die filterbaren Linientypen." & $CrLf & _ "5. Die Linienbreite-Box zeigt die 16 möglichen Linienbreiten." & $CrLf & _ " Hier kann der Filterwert (0-15) auch manuell eingegeben werden." & $CrLf & _ "6. Die Box 'Wahre Linienbreite' übernimmt die aktuelle wahre Linienbreite" & $CrLf & _ " eines Elements oder Layers, kann aber nur manuell editiert werden." & $CrLf & $CrLf & _ "A. Layerparameter haben immer Priorität gegenüber Elementparametern." & $CrLf & _ " Sind Layerparameter aktiv, dann sind die entsprechenden Boxen für die" & $CrLf & _ " Auswahl von Elementparametern gesperrt." & $CrLf & _ "B. Mit 'Filter aktivieren' werden die aktuellen Filterkriterien bestätigt." & $CrLf & _ " Nach Bestätigung der Filterkriterien muß unmittelbar die Selektion mit" & $CrLf & _ " einem Selektionsbefehl erfolgen. Durch einen nichtselektierenden Klick" & $CrLf & _ " in die Zeichnung werden die aktiven Filterkriterien deaktiviert." & $CrLf & _ " Mit den Selektionswerkzeugen können die eingestellten Filterkriterien" & $CrLf & _ " mehrfach hintereinander für eine kumulierende Selektion eingesetzt" & $CrLf & _ " werden." & $CrLf & _ "C. Mit <Neu> werden die aktuellen Filterkriterien zurückgesetzt." & $CrLf & $CrLf & _ "Bemerkung:" & $CrLf & _ "Die Nachricht <Klick auf 'ByLayer <BL> ergibt keine Veränderung> besagt," & $CrLf & _ "daß bereits vorhandene Layerparameter von Objekten mit individuellen" & $CrLf & _ "Elementparametern überschrieben wurden. Layerparameter können für diese" & $CrLf & _ "Elemente dann nicht mehr verwendet werden. Die aktuellen Layerparameter" & $CrLf & _ "können ihnen jedoch mit dem Befehl <EY> wieder neu zugewiesen werden." lRet = MsgBox(sMsg, %MB_OK or %MB_SYSTEMMODAL, "SelFilter Kurzhilfe") End function '------------------------------------------------------------------------------------------------------- ' SUB CloseDialog '------------------------------------------------------------------------------------------------------- Sub CloseDialog() MsgBox "CLOSE" local iError as integer 'Applikation beenden Dialog End hDlg end sub '------------------------------------------------------------------------------------------------------- ' SUB UseByLayerProps '------------------------------------------------------------------------------------------------------- Sub UseByLayerProps() MsgBox "UseByLayerProps benutzen...." End Sub
Comment