Hallo,
Hallo 
Ich programmiere hobbymäßig in Visual Basic und arbeite grad
an einem Programm, das Grafiken anzeigen, bearbeiten und
sortieren kann. Da habe ich mehrere Probleme:
1.: Ich hab schon mehrere Algorithmen für Kontrasterhöhung,
Alphablending und solche Effekte ausprobiert (über GDI, API
und Co), aber keiner hat mich so richtig überzeugt. Einige
waren instabil und sind dauernd abgestürzt, andere haben die
Bildqualität dermaßen ruiniert, dass sie unpraktikabel waren,
wieder andere funktionieren nur unter Win 2000/XP. Manche
brauchen auch für ein Bild mit 2000x1500 Pixel ca. 30 sek. Was
ich suche, ist also ein stabiler, qualitativ hochwertiger,
schneller und bewährter Algorithmus, der unter Win 95/98 auch
funktioniert. Kennt da einer was? Wenn ja, bitte antwortet
mir, schickt mir ein Modul, eine Funktion, eine DLL oder gebt
mir eine Internetadresse, ich bin für alles dankbar.
'Alphablending Variante1
'Der nachfolgende Tipp zeigt das Software-Alphablending zum Überlagern 'zweier Bitmaps, wobei eines eine gewisse Transparenz (Alpha-Value) 'besitzt. Der Alphawert kann variabel im Bereich 0.01 und 0.99 'eingestellt werden. Dieser Wert bestimmt die Intensität des 'Hauptbildes.
'zunächst die benötigten API-Deklarationen
Private Declare Function StretchBlt Lib "gdi32" \_
(ByVal hdc 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 nSrcWidth As Long, ByVal nSrcHeight As Long, \_
ByVal dwRop As Long) As Long
Private Declare Function GetPixel Lib "gdi32" \_
(ByVal hdc As Long, ByVal x As Long, \_
ByVal y As Long) As Long
Private Declare Function SetPixel Lib "gdi32" \_
(ByVal hdc As Long, ByVal x As Long, \_
ByVal y As Long, ByVal crColor As Long) As Long
'(DWORD) dest = source
Private Const SRCCOPY = &HCC0020
Private Type RGBCol
Red As Long
Green As Long
Blue As Long
End Type
'Hauptroutine
'Als Parameter werden die beiden Quell-Bildfelder, das Ziel-Bildfeld, 'der Alpha-Wert und ein Label-Steuerelement erwartet. Der Alpha-Wert 'muß im Bereich 0.01 und 0.99 liegen. Das Label-Steuerelement zeigt 'den Fortschritt des AlphaBlendings in Prozent an.
Public Function AlphaBlend(ByRef Src1Pic As PictureBox, \_
ByRef Src2Pic As PictureBox, \_
ByRef DestPic As PictureBox, \_
ByVal AlphaValue As Currency, ByRef Progress As Label)
Dim j As Long, k As Long
Dim BackCol As Long, BackRGB As RGBCol
Dim ForeCol As Long, ForeRGB As RGBCol
Dim NewCol As Long, NewRGB As RGBCol
Dim RBitMask As Long, GBitMask As Long
Dim BBitMask As Long
'Labelfeld auf 0% setzen und Ziel-Pictureobjekt leeren
Progress.Caption = "0%"
DestPic.Cls
'Die Hauptschleife für jedes Pixel
For j = 0 To DestPic.ScaleWidth
For k = 0 To DestPic.ScaleHeight
'Hintergrund-Farbwerte ermitteln
BackCol = GetPixel(Src1Pic.hdc, j, k)
With BackRGB
'Enthält die Alphafarbe für den Hintergrund
.Red = (BackCol And &HFF&:wink: \* (1 - AlphaValue)
.Green = (BackCol \ &H100& And &HFF&:wink: \* \_
(1 - AlphaValue)
.Blue = (BackCol \ &H10000 And &HFF&:wink: \* \_
(1 - AlphaValue)
End With
'Fordergrund Farbwerte bekommen
ForeCol = GetPixel(Src2Pic.hdc, j, k)
With ForeRGB
'Enthält die Alphafarbe für den Vordergrund
.Red = (ForeCol And &HFF&:wink: \* AlphaValue
.Green = (ForeCol \ &H100& And &HFF&:wink: \* \_
AlphaValue
.Blue = (ForeCol \ &H10000 And &HFF&:wink: \* \_
AlphaValue
End With
'Farbwerte addieren
With NewRGB
.Red = ForeRGB.Red + BackRGB.Red
.Green = ForeRGB.Green + BackRGB.Green
.Blue = ForeRGB.Blue + BackRGB.Blue
End With
'Setzt das Ziel-Pixel
SetPixel DestPic.hdc, j, k, \_
RGB(NewRGB.Red, NewRGB.Green, NewRGB.Blue)
'Labelfeld aktualisieren
Progress.Caption = CStr(CInt(Round((100 / \_
DestPic.ScaleWidth) \* j))) & "%"
DoEvents
Next k
Next j
'Ziel-Pictureobjekt "refreshen"
DestPic.Refresh
End Function
'Stretcht ein Bitmap mit Hilfe
'eines temporären Picture-Objektes
Public Function StretchPicture(ByRef SrcPic As \_
PictureBox, ByRef TmpPic As PictureBox)
Set TmpPic.Picture = SrcPic.Picture
StretchBlt SrcPic.hdc, 0, 0, SrcPic.ScaleWidth, \_
SrcPic.ScaleHeight, TmpPic.hdc, 0, 0, \_
TmpPic.ScaleWidth, TmpPic.ScaleHeight, SRCCOPY
End Function
'Variante 2
Option Explicit
' zunächst alle benötigten API-Deklarationen
Private Declare Function GetDIBits Lib "gdi32" \_
(ByVal hdc As Long, ByVal hbmp As Long, \_
ByVal uStartScan As Long, \_
ByVal cScanLines As Long, \_
lpvBits As Any, lpbm As BITMAPINFO, \_
ByVal fuColorUse As Long) As Long
Private Declare Function SetDIBits Lib "gdi32" \_
(ByVal hdc As Long, ByVal hbmp As Long, \_
ByVal nStartScan As Long, \_
ByVal cScanLines As Long, lpvBits As Any, \_
lpbm As BITMAPINFO, \_
ByVal fuColorUse As Long) As Long
Private Declare Function GetObject Lib "gdi32" \_
Alias "GetObjectA" (ByVal hObject As Long, \_
ByVal nCount As Long, lpObject As Any) As Long
Private Declare Function CreateCompatibleDC \_
Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function CreateDIBSection \_
Lib "gdi32" (ByVal hdc As Long, \_
pBitmapInfo As BITMAPINFO, ByVal un As Long, \_
ByVal lplpVoid As Long, ByVal handle As Long, \_
ByVal dw As Long) As Long
Private Declare Function LoadImage Lib "user32" \_
Alias "LoadImageA" (ByVal hInst As Long, \_
ByVal lpsz As String, \_
ByVal dwImageType As Long, \_
ByVal dwDesiredWidth As Long, \_
ByVal dwDesiredHeight As Long, \_
ByVal dwFlags As Long) As Long
Private Declare Function SelectObject Lib "gdi32" \_
(ByVal hdc As Long, ByVal hObject 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 AlphaBlend Lib "msimg32.dll" \_
(ByVal hDcDest As Long, ByVal xDest As Long, \_
ByVal yDest As Long, ByVal WidthDest As Long, \_
ByVal HeightDest As Long, ByVal hDcSrc As Long, \_
ByVal xSrc As Long, ByVal ySrc As Long, \_
ByVal WidthSrc As Long, ByVal HeightSrc As Long, \_
ByVal Blendfunc As Long) As Long
Private Declare Function StretchBlt Lib "gdi32" \_
(ByVal hdc 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 nSrcWidth As Long, \_
ByVal nSrcHeight As Long, \_
ByVal dwRop As Long) As Long
Private Declare Sub MoveMemory Lib "kernel32.dll" \_
Alias "RtlMoveMemory" (Destination As Any, \_
Source As Any, ByVal Length As Long)
Private Type BLENDFUNCTION
BlendOp As Byte
BlendFlags As Byte
SourceConstantAlpha As Byte
AlphaFormat As Byte
End Type
Private Type BITMAP
bmType As Long
bmWidth As Long
bmHeight As Long
bmWidthBytes As Long
bmPlanes As Integer
bmBitsPixel As Integer
bmBits As Long
End Type
Private Type BITMAPINFOHEADER
biSize As Long
biWidth As Long
biHeight As Long
biPlanes As Integer
biBitCount As Integer
biCompression As Long
biSizeImage As Long
biXPelsPerMeter As Long
biYPelsPerMeter As Long
biClrUsed As Long
biClrImportant As Long
End Type
Private Type RGBQUAD
rgbBlue As Byte
rgbGreen As Byte
rgbRed As Byte
rgbReserved As Byte
End Type
Private Type BITMAPINFO
bmiHeader As BITMAPINFOHEADER
bmiColors As RGBQUAD
End Type
' BITMAPINFOHEADER: biCompression-Konstanten
' ==========================================
' Bitmap ist nicht komprimiert
Private Const BI\_RGB = 0&
' Bitmap ist komprimiert (für 8-Bit Bitmaps)
Private Const BI\_RLE8 = 1&
' Bitmap ist komprimiert (für 4-Bit Bitmaps)
Private Const BI\_RLE4 = 2&
' Bitmap ist nicht komprimiert. Die Farbtabelle
' enthält eine Farbmaske (für 16-Bit/32-Bit Bitmaps)
Private Const BI\_BITFIELDS = 3&
' BLENDFUNCTION AlphaFormat-Konstante
Private Const AC\_SRC\_ALPHA = &H1
' BLENDFUNCTION BlendOp-Konstante
Private Const AC\_SRC\_OVER = &H0
' Get-/ SetDiBits fuColorUse-Konstanten
' =====================================
' RGB-Farb Tabelle
Private Const DIB\_RGB\_COLORS = 0
' Farbpaletten-Einträge
Private Const DIB\_PAL\_COLORS = 1
' Eine der StretchBlt dwRop-Konstanten
Private Const SRCCOPY = &HCC0020
' Eine der LoadImage dwImageType-Konstanten
Private Const IMAGE\_BITMAP = 0
' Eine der LoadImage dwFlags-Konstanten
Private Const LR\_LOADFROMFILE = &H10
' Projekt-Variablen
Dim hSprite As Long
Dim pBF As Long
' Erstellen eines Alpha-Bitmaps anhand einer Maske
Private Function Add\_AlphaMask(ByVal hDcDest As Long, \_
ByVal SrcFile As String, \_
ByVal MaskFile As String) As Long
Dim hSrc As Long
Dim hMask As Long
Dim DibSrc As Long
Dim DibMask As Long
Dim hDcSrc As Long
Dim hDcMask As Long
Dim SrcSize As BITMAP
Dim MaskSize As BITMAP
Dim SrcBits() As RGBQUAD
Dim MaskBits() As RGBQUAD
Dim BMI As BITMAPINFO
Dim BitmapSize As Long
Dim i As Long
' Bimaps laden
hSrc = LoadImage(App.hInstance, SrcFile, \_
IMAGE\_BITMAP, 0&, 0&, LR\_LOADFROMFILE)
hMask = LoadImage(App.hInstance, MaskFile, \_
IMAGE\_BITMAP, 0&, 0&, LR\_LOADFROMFILE)
' Bitmaps miteinander vergleichen
Call GetObject(hSrc, Len(SrcSize), SrcSize)
Call GetObject(hMask, Len(MaskSize), MaskSize)
If (SrcSize.bmHeight MaskSize.bmHeight) Or \_
(SrcSize.bmWidth MaskSize.bmWidth) Then
Call DeleteObject(hSrc)
Call DeleteObject(hMask)
Exit Function
End If
' Kompatible Devicekontexte erstellen und
' Quellen zuweisen
hDcSrc = CreateCompatibleDC(hDcDest)
hDcMask = CreateCompatibleDC(hDcDest)
' DIB-Bitmaps erstellen (geräteunabhängige Bitmaps)
With BMI.bmiHeader
.biSize = Len(BMI.bmiHeader)
.biWidth = SrcSize.bmWidth
.biHeight = SrcSize.bmHeight
.biPlanes = 1
.biBitCount = 32 '(Alpha / Rot / Grün / Blau)
.biCompression = BI\_RGB
.biSizeImage = SrcSize.bmWidth \* \_
SrcSize.bmHeight \* 4
BitmapSize = .biSizeImage
End With
DibSrc = CreateDIBSection(hDcSrc, BMI, \_
DIB\_RGB\_COLORS, 0&, 0&, 0&:wink:
DibMask = CreateDIBSection(hDcMask, BMI, \_
DIB\_RGB\_COLORS, 0&, 0&, 0&:wink:
' Bitmaps den Devicekontexten zuweisen
SelectObject hDcSrc, hSrc
SelectObject hDcMask, hMask
' Farben der Bitmaps ermitteln
ReDim SrcBits(BitmapSize / 4)
ReDim MaskBits(BitmapSize / 4)
GetDIBits hDcSrc, hSrc, 0, SrcSize.bmHeight, \_
SrcBits(0), BMI, DIB\_RGB\_COLORS
GetDIBits hDcMask, hMask, 0, SrcSize.bmHeight, \_
MaskBits(0), BMI, DIB\_RGB\_COLORS
' Alphawert (Transparenz) für jeden Pixel
' anhand der Maske bestimmen
For i = 0 To BitmapSize / 4
With MaskBits(i)
SrcBits(i).rgbReserved = CInt(((.rgbRed) + \_
CInt(.rgbGreen) + CInt(.rgbBlue)) / 3)
End With
Next i
' modifizierte Farben (Alpha) zuweisen
SetDIBits hDcSrc, hSrc, 0, SrcSize.bmHeight, \_
SrcBits(0), BMI, DIB\_RGB\_COLORS
' Nicht mehr benötigte Ressourcen entfernen
Call DeleteObject(hMask)
Call DeleteObject(hSrc)
Call DeleteObject(DibMask)
Call DeleteObject(DibSrc)
Call DeleteObject(hDcMask)
' Handle zu dem modifiziertem Bitmap zurückgeben
Add\_AlphaMask = hDcSrc
End Function
' Bitmap laden und BLENDFUNCTION-Struktur
' erstellen
Private Sub Form\_Load()
Dim BF As BLENDFUNCTION
Picture1.AutoRedraw = True
Picture1.ScaleMode = vbPixels
Me.AutoRedraw = True
Me.ScaleMode = vbPixels
' 2 Bitmaps (Bitmap & Alphamaske)
' miteinander kombinieren
hSprite = Add\_AlphaMask(Me.hdc, \_
App.Path & "\Fill.bmp", App.Path & "\Mask.bmp")
' Pointer zu einer BLENDFUNCTION-Struktur erstellen
With BF
.BlendOp = AC\_SRC\_OVER
.BlendFlags = 0
.SourceConstantAlpha = &HFF
.AlphaFormat = AC\_SRC\_ALPHA
End With
MoveMemory pBF, BF, Len(BF)
End Sub
' Bitmaps anzeigen (Hintergrund & Sprite)
Private Sub Form\_MouseMove(Button As Integer, \_
Shift As Integer, x As Single, y As Single)
Dim Zoom As Long
' Zoomfaktor des Sprit bestimmen
Zoom = Me.ScaleWidth / 5 + 2
' Erst Hintergrund und dann das Sprite zeichnen
With Picture1
Call StretchBlt(Me.hdc, 0, 0, Me.ScaleWidth, \_
Me.ScaleHeight, .hdc, 0, 0, .ScaleWidth, \_
.ScaleHeight, SRCCOPY)
End With
Call AlphaBlend(Me.hdc, x - (Zoom + 2) / 2, \_
y - Zoom / 2, Zoom + 2, Zoom, hSprite, \_
0, 0, 214, 216, pBF)
' Fensterinhalt neu ueichnen
Me.Refresh
End Sub
' Bitmap entladen
Private Sub Form\_QueryUnload(Cancel As Integer, \_
UnloadMode As Integer)
Call DeleteDC(hSprite)
End Sub
Variante 3:
ption Explicit
' Benötigte API-Deklarationen
Private Declare Function GetObject Lib "gdi32" Alias \_
"GetObjectA" ( \_
ByVal hObject As Long, \_
ByVal nCount As Long, \_
lpObject As Any) As Long
Private Declare Function VarPtrArray Lib "msvbvm50.dll" Alias \_
"VarPtr" (Ptr() As Any) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias \_
"RtlMoveMemory" ( \_
pDst As Any, \_
pSrc As Any, \_
ByVal ByteLen As Long)
Private Type SAFEARRAYBOUND
cElements As Long
lLbound As Long
End Type
Private Type SAFEARRAY2D
cDims As Integer
fFeatures As Integer
cbElements As Long
cLocks As Long
pvData As Long
Bounds(0 To 1) As SAFEARRAYBOUND
End Type
Private Type BITMAP
bmType As Long
bmWidth As Long
bmHeight As Long
bmWidthBytes As Long
bmPlanes As Integer
bmBitsPixel As Integer
bmBits As Long
End Type
' ----------ALPHABLEND-------------
' Source Quellbild
' Destination Zielbild
' X1 X-Verschiebung
' Y1 Y-Verschiebung
Private Sub Alphablend(Source As PictureBox, \_
Destination As PictureBox, \_
Optional ByVal X1 As Long = 0, \_
Optional ByVal Y1 As Long = 0, Optional Part As Byte = 50)
Dim Pic() As Byte
Dim PicBuff() As Byte
Dim SafeArray As SAFEARRAY2D
Dim SafeArrayBuffer As SAFEARRAY2D
Dim Bmp As BITMAP
Dim BmpBuffer As BITMAP
Dim x As Long
Dim y As Long
Dim Temp As Long
Call GetObject(Destination.Picture, Len(Bmp), Bmp)
Call GetObject(Source.Picture, Len(BmpBuffer), BmpBuffer)
If Bmp.bmBitsPixel 24 Then
MsgBox "Bild ist kein 24-Bit Bitmap!"
Exit Sub
End If
' Deskriptor des Bytearrays dem die sichtbare
' PictureBox (Picture1) zugeordnet wird.
With SafeArray
.cDims = 2
.fFeatures = 0
.cbElements = 1
.cLocks = 0
.pvData = Bmp.bmBits
.Bounds(0).lLbound = 0
.Bounds(0).cElements = Bmp.bmHeight
.Bounds(1).lLbound = 0
.Bounds(1).cElements = Bmp.bmWidthBytes
End With
' Deskriptor des Bytearrays dem die unsichtbare
' PictureBox (Picture2) zwecks Pufferung zugeordnet wird
With SafeArrayBuffer
.cDims = 2
.fFeatures = 0
.cbElements = 1
.cLocks = 0
.pvData = BmpBuffer.bmBits
.Bounds(0).lLbound = 0
.Bounds(0).cElements = BmpBuffer.bmHeight
.Bounds(1).lLbound = 0
.Bounds(1).cElements = BmpBuffer.bmWidthBytes
End With
' Zuweisung der beiden neuen Deskriptoren
Call CopyMemory(ByVal VarPtrArray(Pic), \_
VarPtr(SafeArray), 4&:wink:
Call CopyMemory(ByVal VarPtrArray(PicBuff), \_
VarPtr(SafeArrayBuffer), 4&:wink:
On Error Resume Next
' Hier kann man die Transperenz RGB Werte einstellen
Dim tR As Byte
Dim tG As Byte
Dim tB As Byte
tR = 0
tG = 255
tB = 0
' Hier beginnt der eigentliche Effekt
Y1 = -Y1 + UBound(Pic, 2) - UBound(PicBuff, 2)
For x = 0 To UBound(PicBuff, 1) + 3 \* (X1 - 1) Step 3
For y = 0 To UBound(PicBuff, 2) + Y1
If PicBuff(x - 3 \* X1, (y - Y1)) tR Or \_
PicBuff(x + 1 - 3 \* X1, (y - Y1)) tG Or \_
PicBuff(x + 2 - 3 \* X1, (y - Y1)) tB Then
Pic(x, y) = Int((Pic(x, y) \* \_
(1 - (Part / 100)) + \_
PicBuff(x - 3 \* X1, (y - Y1)) \* (Part / 100)))
Pic(x + 1, y) = Int((Pic(x + 1, y) \* \_
(1 - (Part / 100)) + \_
PicBuff(x + 1 - 3 \* X1, (y - Y1)) \* (Part / 100)))
Pic(x + 2, y) = Int((Pic(x + 2, y) \* \_
(1 - (Part / 100)) + \_
PicBuff(x + 2 - 3 \* X1, (y - Y1)) \* (Part / 100)))
End If
Next y
Next x
' Zurücksetzen der verbogenen Deskriptoren.
Call CopyMemory(ByVal VarPtrArray(Pic), 0&, 4&:wink:
Call CopyMemory(ByVal VarPtrArray(PicBuff), 0&, 4&:wink:
' Array aus dem Image in das Picture holen
Destination.Refresh
End Sub
'Start des Alphablendings über Command1
Private Sub Command1\_Click()
Alphablend Picture1, Picture2, 0, 0, 50
End Sub
'Kontrast ändern:
' Steuerelement: Horizontale Scrollbar "HScroll2"
' Steuerelement: Horizontale Scrollbar "HScroll1"
' Steuerelement: Bildfeld-Steuerelement "Picture1"
' Steuerelement: Bildfeld-Steuerelement "Picture2"
' Steuerelement: Beschriftungsfeld "Label2"
' Steuerelement: Beschriftungsfeld "Label1"
Option Explicit
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 GetObject Lib "gdi32" Alias \_
"GetObjectA" (ByVal hObject As Long, ByVal nCount As \_
Long, lpObject As Any) As Long
Private Declare Function VarPtrArray Lib "msvbvm50.dll" Alias \_
"VarPtr" (Ptr() As Any) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias \_
"RtlMoveMemory" (pDst As Any, pSrc As Any, ByVal \_
ByteLen As Long)
Private Type SAFEARRAYBOUND
cElements As Long
lLbound As Long
End Type
Private Type SAFEARRAY1D
cDims As Integer
fFeatures As Integer
cbElements As Long
cLocks As Long
pvData As Long
Bounds(0 To 0) As SAFEARRAYBOUND
End Type
Private Type SAFEARRAY2D
cDims As Integer
fFeatures As Integer
cbElements As Long
cLocks As Long
pvData As Long
Bounds(0 To 1) As SAFEARRAYBOUND
End Type
Private Type BITMAP
bmType As Long
bmWidth As Long
bmHeight As Long
bmWidthBytes As Long
bmPlanes As Integer
bmBitsPixel As Integer
bmBits As Long
End Type
Private Const SRCCOPY = &HCC0020
Dim Brightness!, Contrast!
Dim TableBright(255) As Byte
Private Sub Form\_Load()
Picture1.Picture = LoadPicture(App.Path & "\Bild.jpg")
Picture2.Picture = LoadPicture(App.Path & "\Bild.jpg")
End Sub
Private Sub HScroll1\_Change()
Dim x%, Temp!
Brightness = Exp(HScroll1.Value / 50) / 5 - 0.2
For x = 0 To 255
Temp = x \* Brightness
If Temp \> 255 Then Temp = 255
TableBright(x) = Temp
Next
Call MakeBitmap
Picture1.Refresh
End Sub
Private Sub HScroll2\_Change()
Dim x%, Temp!
Contrast = Exp(HScroll2.Value / 30) / 20 - 0.05
For x = 0 To 255
Temp = ((x - 127) \* Contrast) + 127
If Temp \> 255 Then Temp = 255
If Temp 24 Then
MsgBox "Es werden nur 24-Bit Bitmaps unterstützt!"
Exit Sub
End If
With SA
.cbElements = 1
.cDims = 2
.Bounds(0).lLbound = 0
.Bounds(0).cElements = Bmp.bmHeight
.Bounds(1).lLbound = 0
.Bounds(1).cElements = Bmp.bmWidthBytes
.pvData = Bmp.bmBits
End With
Call CopyMemory(ByVal VarPtrArray(Pic), VarPtr(SA), 4)
With SABuff
.cbElements = 1
.cDims = 2
.Bounds(0).lLbound = 0
.Bounds(0).cElements = BmpBuff.bmHeight
.Bounds(1).lLbound = 0
.Bounds(1).cElements = BmpBuff.bmWidthBytes
.pvData = BmpBuff.bmBits
End With
Call CopyMemory(ByVal VarPtrArray(PicBuff), VarPtr(SABuff), 4)
For x = 0 To UBound(Pic, 1)
For y = 0 To UBound(Pic, 2)
Pic(x, y) = TableBright(PicBuff(x, y))
Next y
Next x
Call CopyMemory(ByVal VarPtrArray(Pic), 0&, 4)
Call CopyMemory(ByVal VarPtrArray(PicBuff), 0&, 4)
End Sub
2.: Bei einer Diashow muss ja das digitale Bild genau
bildschirmfüllend angezeigt werden, nicht größer und nicht
kleiner. Dazu benutze ich die „Stretch“-Eigenschaft des
Anzeigefelds. Dieses verfügt aber nicht über die Methoden
„Line“, „Circle“ und „Print“ und hat außerdem nicht die
Eigenschaft „Hwnd“, die für viele Grafikeffekte notwendig ist.
Ich kann natürlich schon jedesmal das Bild in eine PictureBox
reinkopieren, dort bearbeiten lassen und anschließend wieder
zurückkopieren, das ist aber auf die Dauer unbefriedigend,
schon wegen des Geschwindigkeitsverlustes. Ich bräuchte also
so eine Art PictureBox, die auch Bilder „Stretchen“ kann.
Kennt da einer was? Gibts da (möglichst kostenlose)
Alternativen?
Auf die schnelle folgendes gefunden
' Aktuelles Bild an die Größe der PictureBox anpassen
With Picture1
.AutoRedraw = True
.Cls
.PaintPicture .Picture, 0, 0, .ScaleWidth, .ScaleHeight
.AutoRedraw = False
End With
'Natürlich lässt sich das Bild auch sofort beim Laden aus einer Datei "stretchen":
Public Sub picShowPicture(oPictureBox As Object, \_
ByVal sFile As String, \_
Optional ByVal bStretch As Boolean = True)
With oPictureBox
If bStretch Then
' Bild an Größe der PictureBox anpassen
.AutoRedraw = True
Set .Picture = Nothing
.PaintPicture LoadPicture(sFile), 0, 0, .ScaleWidth, .ScaleHeight
.AutoRedraw = False
Else
' PictureBox an Bildgröße anpassen
Set .Picture = Nothing
.Picture = LoadPicture(sFile)
.AutoSize = True
End If
End With
End Sub
'Beispiel für den Aufruf:
' Bild an Größe der PictureBox anpassen
picShowPicture Picture1, "c:\bild.jpg"
' PictureBox an Bildgröße anpassen
picShowPicture Picture1, "c:\bild.jpg", False
Ich danke schon mal im Voraus für eure Antworten,
Jonathan
So ich hoffe du kannst mit den Codeschnippseln etwas anfangen.
Diesen deinen Beduerfnissen anzupassen ist net allzuschwer
Was die Sache mit den Kontrasten / Helligkeiten noch angeht. Schaue dir mal beide Adressen an. Da sind auch noch unterschiedliche Varianten dargestellt Aber diese hier zu posten würde den rahmen sprengen
http://www.activevb.de/tipps/vb6tipps/tipp0626.html
http://www.activevb.de/tipps/vb6tipps/tipp0632.html
Nichts zu danken. Ich hoffe dir ein wenig geholfen zu haben
MFG Alex
