Lage 3D

[danfredr]

Hei. Hvordan lager men 3D bilder i en textbox (hvis det er Textboxen man bryker det til) og slik at men kan sette in .BMP filer som teksturer ?

[aadnk]

Teksturer i tekstbokser er ikke enkle greier og du må bruke såkalt "subclassing" for å få det til. Legg denne koden inn i en modul (svære greier):

 

' This code was downloaded from www.elitevb.com. I have only fixed it to not make transparent textbox, but textured.

Private Const GWL_WNDPROC = (-4)
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function DefWindowProc Lib "user32" Alias "DefWindowProcA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long

Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function CreatePatternBrush Lib "gdi32" (ByVal hBitmap As Long) As Long
Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long

Private Const WM_COMMAND        As Long = &H111
Private Const WM_CTLCOLOREDIT   As Long = &H133
Private Const WM_DESTROY        As Long = &H2
Private Const WM_ERASEBKGND     As Long = &H14
Private Const WM_HSCROLL        As Long = &H114
Private Const WM_VSCROLL        As Long = &H115

Private Type RECT
Left    As Long
Top     As Long
Right   As Long
Bottom  As Long
End Type

Private Declare Function GetProp Lib "user32" Alias "GetPropA" (ByVal hwnd As Long, ByVal lpString As String) As Long
Private Declare Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hwnd As Long, ByVal lpString As String) As Long
Private Declare Function SetProp Lib "user32" Alias "SetPropA" (ByVal hwnd As Long, ByVal lpString As String, ByVal hData As Long) As Long

Private Declare Function FillRect Lib "user32" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long
Private Declare Function GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Private Declare Function GetParent Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function InvalidateRect Lib "user32" (ByVal hwnd As Long, ByVal lpRect As Long, ByVal bErase As Long) As Long
Private Declare Function LockWindowUpdate Lib "user32" (ByVal hwndLock As Long) As Long
Private Declare Function SetBkMode Lib "gdi32" (ByVal hdc As Long, ByVal nBkMode As Long) As Long
Private Declare Function UpdateWindow Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function WindowFromDC Lib "user32" (ByVal hdc As Long) As Long

Public Function CreateBackground(aTxt As TextBox, ByVal Handle As Long)
   
NewWindowProc 0, 0, 0, 0
NewTxtBoxProc 0, 0, 0, 0
CreateBGBrush aTxt, Handle

If GetProp(GetParent(aTxt.hwnd), "OrigProcAddr") = 0 Then
SetProp GetParent(aTxt.hwnd), "OrigProcAddr", SetWindowLong(GetParent(aTxt.hwnd), GWL_WNDPROC, AddressOf NewWindowProc)
End If

If GetProp(aTxt.hwnd, "OrigProcAddr") = 0 Then
SetProp aTxt.hwnd, "OrigProcAddr", SetWindowLong(aTxt.hwnd, GWL_WNDPROC, AddressOf NewTxtBoxProc)
End If

End Function

Private Sub CreateBGBrush(aTxtBox As TextBox, ByVal Handle As Long)

   Dim screenDC    As Long
   Dim imgLeft     As Long
   Dim imgTop      As Long
   Dim picDC       As Long
   Dim picBmp      As Long
   Dim aTempBmp    As Long
   Dim aTempDC     As Long
   Dim txtWid      As Long
   Dim txtHgt      As Long
   Dim solidBrush  As Long
   Dim aRect       As RECT
   
   txtWid = aTxtBox.Width / Screen.TwipsPerPixelX
   txtHgt = aTxtBox.Height / Screen.TwipsPerPixelY
   imgLeft = aTxtBox.Left / Screen.TwipsPerPixelX
   imgTop = aTxtBox.Top / Screen.TwipsPerPixelY
   
   screenDC = GetDC(0)
   picDC = CreateCompatibleDC(screenDC)
   picBmp = SelectObject(picDC, Handle)
   aTempDC = CreateCompatibleDC(screenDC)
   aTempBmp = CreateCompatibleBitmap(screenDC, txtWid, txtHgt)
   DeleteObject SelectObject(aTempDC, aTempBmp)
   solidBrush = CreateSolidBrush(GetSysColor(15))
   aRect.Right = txtWid
   aRect.Bottom = txtHgt
   FillRect aTempDC, aRect, solidBrush
   DeleteObject solidBrush
   BitBlt aTempDC, 0, 0, txtWid, txtHgt, picDC, imgLeft, imgTop, vbSrcCopy

   If GetProp(aTxtBox.hwnd, "CustomBGBrush") <> 0 Then
       DeleteObject GetProp(aTxtBox.hwnd, "CustomBGBrush")
   End If
   SetProp aTxtBox.hwnd, "CustomBGBrush", CreatePatternBrush(aTempBmp)
   ' Clean up our temporary DC and bitmap resources
   DeleteDC aTempDC
   DeleteObject aTempBmp
   SelectObject picDC, picBmp
   DeleteDC picDC
   DeleteObject picBmp
   
   ' Release the screen's DC back to the system... forgetting to do this
   '  causes a nasty memory leak.
   ReleaseDC 0, screenDC
   
End Sub

Private Function NewWindowProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
   
   Dim origProc        As Long         ' The original process address for the window.
   Dim isSubclassed    As Long         ' Whether a certain textbox is subclassed or not.
   
   ' I've gotten in the habit of passing 0 values to the subclassing functions before
   '  actually installing them, just to make sure that I don't have any typos or other
   '  problems which can be easily detected. As such, if there is a hwnd of 0, its not
   '  a "valid" message, so we'll just exit right away.
   If hwnd = 0 Then Exit Function
   
   ' Get the original process address which we stored earlier.
   origProc = GetProp(hwnd, "OrigProcAddr")
   
   If origProc <> 0 Then
       If (uMsg = WM_CTLCOLOREDIT) Then
           ' Check to see if our window has a stored value for the original
           '  process address. If so, we're subclassing this one.
           isSubclassed = (GetProp(WindowFromDC(wParam), "OrigProcAddr") <> 0)
           If isSubclassed Then
               ' Invoke the default process... This will set the font, font color
               '  and other stuff we don't really want to fool with.
               CallWindowProc origProc, hwnd, uMsg, wParam, lParam
               ' Make the words print transparently
               SetBkMode wParam, 1
               ' Return the handle to our custom brush rather than that which
               '  the default process would have returned.
               NewWindowProc = GetProp(WindowFromDC(wParam), "CustomBGBrush")
           Else
               ' The textbox in question isn't subclassed, so we aren't going
               '  to do anything out of the ordinary. Just invoke the default proc.
               NewWindowProc = CallWindowProc(origProc, hwnd, uMsg, wParam, lParam)
           End If
       ElseIf uMsg = WM_COMMAND Then
           ' Check to see if our window has a stored value for the original
           '  process address. If so, we're subclassing this one.
           isSubclassed = (GetProp(lParam, "OrigProcAddr") <> 0)
           If isSubclassed Then
               ' We are going lock the window from updating while we invalidate
               '  and redraw it. This prevents flickering.
               LockWindowUpdate GetParent(lParam)
               ' Force windows to redraw the window.
               InvalidateRect lParam, 0&, 1&
               UpdateWindow lParam
           End If
           ' Invoke the default process
           NewWindowProc = CallWindowProc(origProc, hwnd, uMsg, wParam, lParam)
           If isSubclassed Then LockWindowUpdate 0&
       ElseIf uMsg = WM_DESTROY Then
           
           ' The window is being destroyed... time to unhook our process so we
           '  don't cause a big fat error which crashes the application.
           
           ' Install the default process address again
           SetWindowLong hwnd, GWL_WNDPROC, origProc
           ' Invoke the default process
           NewWindowProc = CallWindowProc(origProc, hwnd, uMsg, wParam, lParam)
           ' Remove our stored value since we don't need it anymore
           RemoveProp hwnd, "OrigProcAddr"
       Else
           ' We're not concerned about this particular message, so we'll just
           '  let it go on its merry way.
           NewWindowProc = CallWindowProc(origProc, hwnd, uMsg, wParam, lParam)
       End If
   Else
       ' A catch-all in case something freaky happens with the process addresses.
       NewWindowProc = DefWindowProc(hwnd, uMsg, wParam, lParam)
   End If
       
End Function

Private Function NewTxtBoxProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
   
   ' *********************************************
   '  SUBCLASSING ROUTINE FOR THE >>>>TEXTBOX<<<<
   ' *********************************************
   
   Dim aRect           As RECT
   Dim origProc        As Long
   Dim aBrush          As Long
   
   If hwnd = 0 Then Exit Function
   ' Get the original process address which we stored earlier.
   origProc = GetProp(hwnd, "OrigProcAddr")
   
   If origProc <> 0 Then
       ' We're subclassing! Which is silly, 'cause otherwise we wouldn't be in
       '  this function, however we double check the process address just in case.
       If uMsg = WM_ERASEBKGND Then
           ' We're going to get our custom brush for this textbox and fill the
           '  textbox's background area with it...
           aBrush = GetProp(hwnd, "CustomBGBrush")
           If aBrush <> 0 Then
               ' Get the area dimensions to fill
               GetClientRect hwnd, aRect
               ' Fill it with our custom brush
               FillRect wParam, aRect, aBrush
               ' Tell windows that we took care of the "erasing"
               NewTxtBoxProc = 1
           Else
               ' Something happened to our custom brush :-\ We'll just invoke
               '  the default process
               NewTxtBoxProc = CallWindowProc(origProc, hwnd, uMsg, wParam, lParam)
           End If
       ElseIf uMsg = WM_HSCROLL Or uMsg = WM_VSCROLL Then
           ' We are scrolling, either horizontally or vertically. This requires
           '  us to totally repaint the background area... so we'll lock the
           '  window updates so we don't see any of the freaky flickering
           LockWindowUpdate GetParent(hwnd)
           ' Invoke the default process so the user actually get's the scroll
           '  they want
           NewTxtBoxProc = CallWindowProc(origProc, hwnd, uMsg, wParam, lParam)
           ' Force window to repaint itself
           InvalidateRect hwnd, 0&, 1&
           UpdateWindow hwnd
           ' Release the update lock
           LockWindowUpdate 0&
       ElseIf uMsg = WM_DESTROY Then
           
           ' The textbox's parent is closing / destroying, so we need to
           '  unhook our subclassing routine ... or bad things happen
           
           ' Clean up our brush object... muy importante!!!
           aBrush = GetProp(hwnd, "CustomBGBrush")
           ' Delete the brush object, freeing its resource.
           DeleteObject aBrush
           ' Remove our values we stored against the textbox's handle
           RemoveProp hwnd, "OrigProcAddr"
           RemoveProp hwnd, "CustomBGBrush"
           ' Replace the original process address
           SetWindowLong hwnd, GWL_WNDPROC, origProc
           ' Invoke the default "destroy" process
           NewTxtBoxProc = CallWindowProc(origProc, hwnd, uMsg, wParam, lParam)
       Else
           ' We're not interested in this message, so we'll just let it truck
           '  right on thru... invoke the default process
           NewTxtBoxProc = CallWindowProc(origProc, hwnd, uMsg, wParam, lParam)
       End If
   Else
       ' A catch-all in case something freaky happens with the process addresses.
       NewTxtBoxProc = DefWindowProc(hwnd, uMsg, wParam, lParam)
   End If
   
End Function

 

Du bruker CreateBackground for å legge inn en backgrunn i Textboxer.

Den brukes slik:

 

CreateBackground Text1, Image1.Picture.Handle

 

Du trenger ikke bruke en image, alt annet med en Picture property går også ([OBJECT].Picture.Handle).

 

Husk at du må kalle CreateBackground også når tekstboksen resizes.

[danfredr]

JA Tusen takk.

[bamsefar]

Håper for din del at du ikke skrev hele koden aadnk.

Sinnsykt lang code.

Har letet en stund etter dette. Takk

[Jonas]

' This code was downloaded from www.elitevb.com. I have only fixed it to not make transparent textbox, but textured.

Tror ikke det, men det høres ut som han kan alt i den! Hvordan husker dere alle kodene?Hver gang jeg skal lage en msgbox må jeg gå inn i en tråd her for å finne koden for icon i den

[aadnk]

Nei, jeg kan subclassing, men jeg gadd vel ikke lage noe på nytt hvis det allerede kunne lastes ned. Men jeg måtte endre på en del for at det skulle være en textured tekstboks istedenfor en transparent. Og du lærer deg kodene etter en stund.

[GeirGrusom]

Da tror jeg det ville vært lettere å lage en ny tekstboks kontroll selv...

TextOut

GetCharacterMetrics

 

Det blir vel litt enklere.