'СОРС ЗА ФОРМАТА

'Декларация на променливи

Private Type xForm

  eM11 As Single

  eM12 As Single

  eM21 As Single

  eM22 As Single

  eDx As Single

  eDy As Single

End Type

'Декларация на константа

Private Const GM_ADVANCED As Long = &H2

'Декларация на Апи функции

Private Declare Function SetWorldTransform Lib "gdi32" (ByVal hdc As Long, ByRef lpXform As xForm) As Long

Private Declare Function SetGraphicsMode Lib "gdi32" (ByVal hdc As Long, ByVal iMode As Long) As Long

Private Declare Function GetWorldTransform Lib "gdi32" (ByVal hdc As Long, ByRef lpXform As xForm) 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 Sub Command1_Click()

If Command1.Caption = "Непрекъснато въртене" Then 'Ако надписа на бутона е Непрекъснато въртене

Command1.Caption = "Спиране на въртенето" ' Сменяме надписа на Спиране на въртенето

Command1.BackColor = vbRed 'Сменяме цвета на бутона на червен

Timer1.Enabled = True ' Пускаме таймера реализиращ непрекъснатото въртене

Else

Timer1.Enabled = False ' Спираме таймера

Command1.Caption = "Непрекъснато въртене" ' Сменяме надписа на бутона на Непрекъснато въртене

Command1.BackColor = vbGreen 'Сменяме цвета на бутона на зелен

End If

End Sub

 

'Бутон за прозрачна форма

Private Sub Command2_Click()

NapraviProzrachna Form1.hWnd, vbBlack ' Процедура правеща прозрачно всичко, което е с черен цвят

'Правим невидими плъзгача и бутоните за по-голям ефект на демонстрацията

HScroll1.Visible = False

Command1.Visible = False

Command2.Visible = False

Command3.Visible = False

End Sub

 

'Бутонче за затваряне на програмата

Private Sub Command3_Click()

Unload Me 'Извежда формата, тоест затваря програмата

End Sub

 

'При въвеждане на формата

Private Sub Form_Load()

Picture1.ScaleMode = vbPixels ' Прави скалата на Picture1 да бъде в пиксели

Picture2.ScaleMode = vbPixels ' Прави скалата на Picture2 да бъде в пиксели

Picture1.AutoSize = True 'Указва размера на Picture1  да стане равен на размера на картинката в него

Picture2.Height = Picture1.Height 'Прави височината на Picture2 равна на височината на Picture1

Picture2.Width = Picture1.Width 'Прави ширината на Picture2 равна на ширината на Picture1

Picture1.AutoRedraw = True 'Разрешава пречертаване на Picture1

Picture1.Visible = False ' Прави Picture1 невидима

HScroll1_Change 'Задейства първоначално процедурата за смяна стойността в плъзгача - първоначално изрисуване

End Sub

 

'Процедура сработваща при събитието промяна на плъзгача, където реално се извършва завъртането

Private Sub HScroll1_Change()

Dim OldMode As Long, oldmatrix As xForm

Dim x As Single, NewMatrix As xForm

x = CSng(HScroll1) * (8 * Atn(1)) / 32767 - Atn(1) * 4

With NewMatrix

    .eM11 = Cos(x)

    .eM12 = Sin(x)

    .eM21 = -Sin(x)

    .eM22 = Cos(x)

    .eDx = Picture2.ScaleWidth / 2 - Cos(x) * Picture2.ScaleWidth / 2 + Sin(x) * Picture2.ScaleHeight / 2

    .eDy = Picture2.ScaleHeight / 2 - Cos(x) * Picture2.ScaleHeight / 2 - Sin(x) * Picture2.ScaleWidth / 2

End With

  OldMode = SetGraphicsMode(Picture2.hdc, GM_ADVANCED)

  BitBlt Picture2.hdc, 0, 0, Picture2.ScaleWidth, Picture2.ScaleHeight, Picture1.hdc, 0, 0, vbBlackness

  Call GetWorldTransform(Picture2.hdc, oldmatrix)

  Call SetWorldTransform(Picture2.hdc, NewMatrix)

  BitBlt Picture2.hdc, Picture2.ScaleWidth / 2 - Picture1.ScaleWidth / 2, Picture2.ScaleHeight / 2 - Picture1.ScaleHeight / 2, Picture1.ScaleWidth, Picture1.ScaleHeight, Picture1.hdc, 0, 0, vbSrcCopy

Call SetWorldTransform(Picture2.hdc, oldmatrix)

Call SetGraphicsMode(Picture2.hdc, OldMode)

Picture2.Refresh

End Sub

 

Private Sub HScroll1_Scroll()

HScroll1_Change 'При промяна на стойността на плъзгача, задейства горната процедура за въртене

End Sub

 

 

Private Sub Picture2_Click()

Unload Me ' При кликане върху въртящата се картинка затваря програмата

End Sub

 

'Таймер, който през 50 милисекунди увеличива стойността на плъзгача, което предизвиква завъртане на картинката

Private Sub Timer1_Timer()

If HScroll1 < 32267 Then ' Ако стойността стане по-голяма от 32267 я прави отново 0

HScroll1 = HScroll1 + 500

Else

HScroll1 = 0

End If

End Sub

 

                                                                                              'СОРС ЗА МОДУЛА ПРАВЕЩ ФОРМАТА ПРОЗРАЧНА

 

'Деклариране на АПИ функции

Private Declare Function GetWindowLong Lib "user32.dll" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long

Private Declare Function SetWindowLong Lib "user32.dll" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long

Private Declare Function SetLayeredWindowAttributes Lib "user32.dll" (ByVal hWnd As Long, ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long

'Деклариране на константи

Private Const WS_EX_LAYERED = &H80000

Private Const GWL_EXSTYLE As Long = -20

Private Const LWA_COLORKEY As Long = &H1

 

'Процедурата която прави формата прозрачна

Public Sub NapraviProzrachna(HwForm As Long, Cvet As Long)

Dim CurExtendedStyle As Long

    CurExtendedStyle = GetWindowLong(HwForm, GWL_EXSTYLE)

    Call SetWindowLong(HwForm, GWL_EXSTYLE, CurExtendedStyle Or WS_EX_LAYERED)

    Call SetLayeredWindowAttributes(HwForm, Cvet, &H0, LWA_COLORKEY)

End Sub