VB对图像进行纹理处理和灯光滤镜效果(纯代码)

Option Explicit

Option Base 0

Private Declare Function SetDIBits Lib "gdi32" (ByV al aHDC As Long, ByV al hBitmap As Long, ByV al nStartScan As Long, ByV al nNumScans As Long, lpBits As Any, lpBI As BITMAPINFOHEADER, ByV al wUsage As Long) As Long

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 ARGB

B As Byte

G As Byte

R As Byte

A As Byte

End Type

Private Type XYZ

Z As Single

Y As Single

X As Single

End Type

Private Source() As ARGB

Private Normal() As XYZ

Private Target() As ARGB

Private tDesc As BITMAPINFOHEADER

Private lFrom As XYZ

Private bLoaded As Boolean

Private Sub V ec3Subtract(dest As XYZ, A As XYZ, B As XYZ)

dest.X = A.X - B.X

dest.Y = A.Y - B.Y

dest.Z = A.Z - B.Z

End Sub

Private Sub V ec3Cross(dest As XYZ, A As XYZ, B As XYZ)

dest.X = A.Y * B.Z - A.Z * B.Y

dest.Y = A.Z * B.X - A.X * B.Z

dest.Z = A.X * B.Y - A.Y * B.X

End Sub

Private Function V ec3Length(src As XYZ) As Single

V ec3Length = Sqr((src.X * src.X) + (src.Y * src.Y) + (src.Z * src.Z))

End Function

Private Sub V ec3Normalize(dest As XYZ, src As XYZ)

Static vLength As Single

vLength = V ec3Length(src)

If vLength > 0 Then

dest.X = src.X / vLength

dest.Y = src.Y / vLength

dest.Z = src.Z / vLength

Else

dest = src

End If

End Sub

Private Function V ecAngle(A As XYZ, B As XYZ) As Single

Static lA As Single

Static lB As Single

lA = A.X ^ 2 + A.Y ^ 2 + A.Z ^ 2

lB = B.X ^ 2 + B.Y ^ 2 + B.Z ^ 2

If lA = 0 Or lB = 0 Then

V ecAngle = 0

Else

V ecAngle = ArcCos((A.X * B.X + A.Y * B.Y + A.Z * B.Z) / (Sqr(lA) * Sqr(lB))) End If

End Function

Private Function ArcCos(V alue As Single) As Single

If Abs(V alue) < 1 Then

ArcCos = Atn(-V alue / Sqr(-V alue * V alue + 1)) + 1.5707963267949

ElseIf V alue = 1 Then

ArcCos = 0

ElseIf V alue = -1 Then

ArcCos = 3.14159265358979

End If

End Function

Private Sub btnApply_Click()

infStatus.Caption = "正在生成地图..." Static X As Long

Static Y As Long

Static P0 As XYZ

Static P1 As XYZ

Static P2 As XYZ

Static V0 As XYZ

Static V1 As XYZ

Static V2 As XYZ

Static Factor As Single

Factor = V al(datFactor.Text)

If Factor > 254 Then Factor = 254

If Factor < 1 Then Factor = 1

For Y = 0 To 255 Step 1

infFore.Width = infBack.Width / 255 * Y

For X = 0 To 255 Step 1

P0.X = X

P0.Y = Y

P0.Z = Source(X, Y).A / Factor

If (X + 1) <= 255 Then

P1.X = X + 1

P1.Y = Y

P1.Z = Source(X + 1, Y).A / Factor

Else

P1.X = X + 1

P1.Y = Y

P1.Z = 0

End If

If (Y + 1) <= 255 Then

P2.X = X

P2.Y = Y + 1

P2.Z = Source(X, Y + 1).A / Factor

Else

P2.X = X

P2.Y = Y + 1

P2.Z = 0

End If

V ec3Subtract V0, P1, P0

V ec3Subtract V1, P2, P0

V ec3Cross V2, V0, V1

V ec3Normalize V2, V2

Normal(X, Y) = V2

Next X

Next Y

imgOutput_MouseMove 1, 0, lFrom.X, 255 - lFrom.Y

End Sub

Private Sub chkRange_Click()

btnApply_Click

End Sub

Private Sub Form_Load()

Show

DoEvents

bLoaded = False

optMode.ListIndex = 5

With tDesc

.biSize = Len(tDesc)

.biWidth = 256

.biHeight = 256

.biPlanes = 1

.biBitCount = 32

.biCompression = 0

.biSizeImage = 65536

.biXPelsPerMeter = 0

.biYPelsPerMeter = 0

.biClrUsed = 0

.biClrImportant = 0

End With

ReDim Source(0 To 255, 0 To 255) As ARGB

ReDim Normal(0 To 255, 0 To 255) As XYZ

ReDim Target(0 To 255, 0 To 255) As ARGB

With lFrom

.X = 127

.Y = 127

.Z = V al(datDistance.Text)

End With

optTexture_Click 0

bLoaded = True

End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer) Erase Source()

Erase Normal()

Erase Target()

End

End Sub

Private Sub imgOutput_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)

imgOutput_MouseMove Button, Shift, X, Y

End Sub

Private Sub imgOutput_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)

If Button = vbLeftButton Then

If X < 0 Then X = 0

If Y < 0 Then Y = 0

If X > 255 Then X = 255

If Y > 255 Then Y = 255

infStatus.Caption = "正在处理材质..."

Static lColor As XYZ

With lColor

.X = V al(datR.Text)

If .X < 0 Then .X = 0

If .X > 1 Then .X = 1

.Y = V al(datG.Text)

If .Y < 0 Then .Y = 0

If .Y > 1 Then .Y = 1

.Z = V al(datB.Text)

If .Z < 0 Then .Z = 0

If .Z > 1 Then .Z = 1

End With

Static vRange As Single

Static fX As Long

Static fY As Long

Static lTo As XYZ

Static lV ec As XYZ

Static vAngle As Single

Static vMul As Single

With lFrom

.X = X

.Y = 255 - Y

.Z = V al(datDistance.Text)

End With

For fY = 0 To 255 Step 1

infFore.Width = infBack.Width / 255 * fY

For fX = 0 To 255 Step 1

Select Case optMode.ListIndex

Case 0

Target(fX, fY) = Source(fX, fY)

Case 1

With Target(fX, fY)

.R = Source(fX, fY).A

.G = Source(fX, fY).A

.B = Source(fX, fY).A

End With

Case 2

With Target(fX, fY)

.R = 128 + Normal(fX, fY).X * 127

.G = 128 + Normal(fX, fY).Y * 127

.B = 128 + Normal(fX, fY).Z * 127

End With

Case 3

With lTo

.X = fX

.Y = fY

.Z = 0

End With

V ec3Subtract lV ec, lTo, lFrom

V ec3Normalize lV ec, lV ec

With Target(fX, fY)

.R = 128 + lV ec.X * 127

.G = 128 + lV ec.Y * 127

.B = 128 + lV ec.Z * 127

End With

Case 4

With lTo

.X = fX

.Y = fY

.Z = 0

End With

V ec3Subtract lV ec, lTo, lFrom

V ec3Normalize lV ec, lV ec

vAngle = V ecAngle(Normal(fX, fY), lV ec) / 3.14159265358979 * 255 With Target(fX, fY)

.R = vAngle

.G = vAngle

.B = vAngle

End With

Case 5

With lTo

.X = fX

.Y = fY

.Z = 0

End With

V ec3Subtract lV ec, lTo, lFrom

V ec3Normalize lV ec, lV ec

vAngle = V ecAngle(Normal(fX, fY), lV ec) / 3.14159265358979

If chkRange.V alue = 1 Then

vRange = 1 - Sqr((fX - lFrom.X) ^ 2 + (fY - lFrom.Y) ^ 2) / 365

If vRange = 0 Then vRange = 1

vMul = vAngle * vRange

Else

vMul = vAngle

End If

With Source(fX, fY)

Target(fX, fY).R = .R * lColor.X * vMul

Target(fX, fY).G = .G * lColor.Y * vMul

Target(fX, fY).B = .B * lColor.Z * vMul

End With

End Select

Next fX

Next fY

SetDIBits imgOutput.hDC, imgOutput.Image.Handle, 0, 256, Target(0, 0), tDesc, 0 imgOutput.Line (X, Y - 5)-(X, Y + 6), RGB(255, 255, 0)

imgOutput.Line (X - 5, Y)-(X + 6, Y), RGB(255, 255, 0)

infStatus.Caption = "Done."

End If

End Sub

Private Sub optMode_Click()

If bLoaded Then btnApply_Click

End Sub

Private Sub optTexture_Click(Index As Integer)

Static hFile As Long

hFile = FreeFile

Open App.Path & "\" & optTexture(Index).Caption For Binary Access Read As #hFile Get #hFile, , Source()

Close #hFile

btnApply_Click

End Sub