Salve,
tempo fa ho trovato su PSC un bel programma di "beveling" ( http://www.Planet-Source-Code.com/vb/scripts/ShowCode.asp?txtCodeId=51640&lngWId=1 )
Il programma ha sempre funzionato su un PC con Windows XP. Quando ho provato a lanciarlo su un PC con Windows 8 è successo un fatto strano: apparentemente tutto funziona bene ma, al termine della elaborazione grafica, il programma si chiude spontaneamente e con esso Visual Basic. Ho cercato di capire il perchè ed ho la sensazione che il problema sia nella riga con l'espressione "Copymemory ... ".
Questa è la routine incriminata:
------------------------------------
Private Sub Bevel()
Dim dibSrc As cDIBSection
Set dibSrc = New cDIBSection
dibSrc.CreateFromPicture picIn.Picture
Dim arrSrcBytes() As Byte
Dim tSASrc As SAFEARRAY2D
Dim arrHeight() As Byte, arrWork1() As Byte, arrWork2() As Byte, arrWork3() As Byte
Dim arrHilite() As Byte
Dim arrShadow() As Byte
Dim i As Long, j As Long, k As Long
Dim w As Long, h As Long
w = dibSrc.Width
h = dibSrc.Height
ReDim arrHeight(0 To w - 1, 0 To h - 1)
ReDim arrWork1(0 To w - 1, 0 To h - 1)
ReDim arrWork2(0 To w - 1, 0 To h - 1)
ReDim arrWork3(0 To w - 1, 0 To h - 1)
ReDim arrHilite(0 To w - 1, 0 To h - 1)
ReDim arrShadow(0 To w - 1, 0 To h - 1)
' Setup parameters
BevelHeight = txtBevelSize.Text
LightAngle = DegreesToRadians(txtLightAngle.Text)
LightElevation = DegreesToRadians(txtLightElevation.Text)
InitLight
'
MileStone "1 - Started", True
' Get all the bits to work on:
With tSASrc
.cbElements = 1
.cDims = 2
.Bounds(0).lLbound = 0
.Bounds(0).cElements = dibSrc.Height
.Bounds(1).lLbound = 0
.Bounds(1).cElements = dibSrc.BytesPerScanLine
.pvData = dibSrc.DIBSectionBitsPtr
End With
CopyMemory ByVal VarPtrArray(arrSrcBytes()), VarPtr(tSASrc), 4
' Setup work mask
For j = 0 To h - 1
k = 0
For i = 0 To w - 1
'
If arrSrcBytes(k + 1, h - j - 1) = 0 Then
' Use black as the transparent colour
arrHeight(i, j) = 0
arrWork1(i, j) = 0
Else
arrHeight(i, j) = 1
arrWork1(i, j) = 1
End If
'
k = k + 3
Next
Next
' Shrink work mask and build height field
MileStone "2 - Building height field"
For k = 1 To BevelHeight ' Depth
For j = 1 To h - 2
For i = 1 To w - 2
If arrWork1(i, j) = 0 Then GoTo SET_ZERO
' Adjacent pixels:
If arrWork1(i, j - 1) = 0 Then GoTo SET_ZERO
If arrWork1(i - 1, j) = 0 Then GoTo SET_ZERO
If arrWork1(i + 1, j) = 0 Then GoTo SET_ZERO
If arrWork1(i, j + 1) = 0 Then GoTo SET_ZERO
arrWork2(i, j) = 1
arrHeight(i, j) = arrHeight(i, j) + 1
GoTo RESUME_LOOP
SET_ZERO:
arrWork2(i, j) = 0
RESUME_LOOP:
Next
Next
'SwapArrayDataPtrs VarPtrArray(arrWork1()), VarPtrArray(arrWork2())
arrWork1 = arrWork2
Next
' At this point, the height field values range from
' 0 to (BevelHeight+1)
' Normalize them to (0...255)
MileStone "3 - Normalizing height field"
NormalizeArray arrHeight, 0, BevelHeight + 1
' Blur Height field
MileStone "4 - Blurring height"
BlurArray arrHeight
Dim vx As Triplet, vy As Triplet, vN As Triplet
Dim vLight As Triplet
Dim IncidentLight As Double
MileStone "5 - Calculating light"
' Calculate incident light
For j = 1 To h - 2
For i = 1 To w - 2
If arrHeight(i, j) = 0 Or arrHeight(i, j) = 255 Then
' Do nothing
Else
With vN
.X = CDbl(arrHeight(i, j)) - 0.25 * (2# * arrHeight(i + 1, j) + arrHeight(i + 1, j - 1) + arrHeight(i + 1, j + 1))
.Y = CDbl(arrHeight(i, j)) - 0.25 * (2# * arrHeight(i, j + 1) + arrHeight(i - 1, j + 1) + arrHeight(i + 1, j + 1))
'.X = CDbl(arrHeight(i, j)) - arrHeight(i + 1, j)
'.Y = CDbl(arrHeight(i, j)) - arrHeight(i, j + 1)
.Z = 1
End With
IncidentLight = DotTriplet(vN, LightPos) / NormTriplet(vN)
If IncidentLight > 0 Then
arrHilite(i, j) = CByte(255 * IncidentLight)
Else
arrShadow(i, j) = CByte(-255 * IncidentLight)
End If
End If
Next
Next
MileStone "6 - Blurring lights"
For k = 1 To 3
BlurArray arrHilite
BlurArray arrShadow
Next
MileStone "7 - Merging height/light"
For j = 0 To h - 1
For i = 0 To w - 1
arrHilite(i, j) = MulDiv(arrHilite(i, j), 255 - arrHeight(i, j), 255)
Next
Next
For j = 0 To h - 1
For i = 0 To w - 1
arrShadow(i, j) = MulDiv(arrShadow(i, j), 255 - arrHeight(i, j), 255)
Next
Next
MileStone "8 - Rendering"
' Render effect
For j = 0 To h - 1
k = 0
For i = 0 To w - 1
If arrSrcBytes(k + 1, h - j - 1) = 0 Then
' Do nothing
ElseIf arrHeight(i, j) = 0 Or arrHeight(i, j) = 255 Then
' Do nothing
Else
If arrShadow(i, j) > 0 Then
Darken arrShadow(i, j), arrSrcBytes(k + 2, h - 1 - j), arrSrcBytes(k + 1, h - 1 - j), arrSrcBytes(k, h - 1 - j)
End If
If arrHilite(i, j) > 0 Then
Lighten arrHilite(i, j), arrSrcBytes(k + 2, h - 1 - j), arrSrcBytes(k + 1, h - 1 - j), arrSrcBytes(k, h - 1 - j)
End If
End If
'
k = k + 3
Next
Next
MileStone "9 - All done"
dibSrc.PaintPicture picOut.hDC
End Sub
----------------------------
Qualcuno può aiutarmi a risolvere il problema.
Grazie infinite a tutti.
Dario