ammara ücretli bir activex ancak aşağıda linkini verdiğim sitedeki kodlar accesse alındığında gayet güzel çalışıyor ben sadece birini aldım çok güzel çalışıyor
http://www.vbccelerator.com/home/VB/Code.../index.asp
benim aldığım kod tüm renkleri silen bir koddu
ancak siz diğer kodları accesse alırsanız o kodlarında çalışacağına eminim ancak alırken dikkat edin özellikle sizden msvbvm50.dll yi isteyecek gerçi bunu msvbvm60.dll şeklinde değiştirirseniz kod çalışıyor ve birde modül isimlerinin birebir alın yoksa kodlar yine çalışmıyor
benim aldığım kod
modül
Option Compare Database
Type SAFEARRAYBOUND
cElements As Long
lLbound As Long
End Type
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
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
Type SAFEARRAY60D
cDims As Integer
fFeatures As Integer
cbElements As Long
cLocks As Long
pvData As Long
Bounds(0 To 59) As SAFEARRAYBOUND
End Type
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
Declare Function GetObjectAPI Lib _
"gdi32" Alias "GetObjectA" (ByVal _
hObject As Long, ByVal nCount As _
Long, lpObject As Any) As Long
Declare Function VarPtrArray Lib "msvbvm60.dll" _
Alias "VarPtr" (Ptr() As Any) As Long
Declare Sub CopyMemory Lib "kernel32" Alias _
"RtlMoveMemory" (pDst As Any, pSrc As Any, _
ByVal ByteLen As Long)
form
Sub SwapColors(pictbox As IPictureDisp, ByVal color1 _
As Integer, ByVal color2 As Integer)
' these are used to address the pixel using matrices
Dim pict() As Byte
Dim sa As SAFEARRAY2D, bmp As BITMAP
Dim r As Integer, C As Integer, value As Byte
' get bitmap info
GetObjectAPI pictbox, Len(bmp), bmp
' exit if not a supported bitmap
' have the local matrix point to bitmap pixels
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
CopyMemory ByVal VarPtrArray(pict), VarPtr(sa), 4
' swap colors - note that col/row order is inverted
' because VB arrays are stored in column-wise order
For C = 0 To UBound(pict, 1) - 3 Step 3
For r = 0 To UBound(pict, 2) - 1 Step 2
If pict(C, r) > pict(C, r + 1) + 5 And pict(C + 1, r) > pict(C + 1, r + 1) + 5 And pict(C + 2, r) > pict(C + 2, r + 1) + 5 Then
pict(C, r) = 0
pict(C, r + 1) = 0
pict(C + 1, r) = 0
pict(C + 1, r + 1) = 0
pict(C + 2, r) = 0
pict(C + 2, r + 1) = 0
Else
pict(C, r) = 255
pict(C, r + 1) = 255
pict(C + 1, r) = 255
pict(C + 1, r + 1) = 255
pict(C + 2, r) = 255
pict(C + 2, r + 1) = 255
End If
'If value = color1 Then
' pict(c, r) = color2
'ElseIf value = color2 Then
' pict(c, r) = color1
'End If
Next
Next
' clear the temporary array descriptor
' without destroying the local temporary array
CopyMemory ByVal VarPtrArray(pict), 0&, 4
' inform VB that something has changed
'pictbox.Refresh
End Sub
Private Sub Command1_Click()
End Sub
Private Sub Form_Load()
Picture1.Picture = LoadPicture("C:\Users\eigit\Pictures\imagesCAY8VCWN.jpg")
End Sub
Private Sub Komut1_Click()
SwapColors Picture1.Picture, 255, 0
Picture1.Requery
End Sub
meşhur çin atasözü "ACCESS İLE YAPABİLECEKLERİNİZ HAYAL EDEBİLECEKLERİNİZ İLE SINIRLIDIR" siz ne kadar hayal edebiliyorsunuz
#7
