Media Player (Kodlar)

Option Explicit

Private Sub CancelButton_Click()
Unload Me
End Sub

Private Sub cmdAdd_Click()
frmmain.Playlist.Refresh
'adds the selected files to the Playlist
    Dim i As Integer
    Dim J As Integer
    For J = 0 To lstFiles.ListCount - 1
        If lstFiles.Selected(J) Then
        frmmain.Playlist.AddItem lstFiles.List(J)
            i = i + 1
        End If
    Next J
Call xListKillDupes(frmmain.Playlist) 'calls sub from module
    Unload Me
End Sub

Private Sub Combo1_Click()

If Combo1.ListIndex = 0 Then File1.Pattern = "*.mp3"
If Combo1.ListIndex = 1 Then File1.Pattern = "*.avi"
If Combo1.ListIndex = 2 Then File1.Pattern = "*.asf"
If Combo1.ListIndex = 3 Then File1.Pattern = "*.mpeg"
If Combo1.ListIndex = 4 Then File1.Pattern = "*.mpg"
If Combo1.ListIndex = 5 Then File1.Pattern = "*.wav"
If Combo1.ListIndex = 6 Then File1.Pattern = "*.wmv"
If Combo1.ListIndex = 7 Then File1.Pattern = "*.wma"
If Combo1.ListIndex = 8 Then File1.Pattern = "*.cda"
If Combo1.ListIndex = 9 Then File1.Pattern = "*.mid"
If Combo1.ListIndex = 10 Then File1.Pattern = "*.midi"
'lstFiles.Clear
Dir1_Change
End Sub

Private Sub Dir1_Change()
lstFiles.Clear
File1.Path = Dir1.Path
Dim tel
If File1.ListCount <> 0 Then
    For tel = 1 To File1.ListCount
        File1.ListIndex = tel - 1
        If Len(Dir1.Path) > 3 Then
lstFiles.AddItem Dir1.Path & "" & File1.FileName
          Else
          'Exit For
            'MsgBox "You can't add a drive, only folders", vbOKOnly, "Error"
          'Exit Sub
        lstFiles.AddItem Dir1.Path & File1.FileName
        End If
    Next tel
Else
'    MsgBox "No files were found in specific folder", vbOKOnly, "Error"
End If
End Sub

Private Sub Dir1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dir1.ToolTipText = Dir1.Path
End Sub

Private Sub Drive1_Change()
On Error Resume Next
Dir1.Path = Drive1.Drive
End Sub

Private Sub Form_Load()
lstFiles.Refresh
End Sub

Private Sub lstFiles_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
lstFiles.ToolTipText = lstFiles.Text
Horizental1
End Sub

Private Sub lstFiles_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
lstFiles.ToolTipText = lstFiles.Text
End Sub

Private Sub lstFiles_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
lstFiles.ToolTipText = lstFiles.Text
End Sub

Function Horizental1()
On Error GoTo b
  Dim c As Long
  Dim rcText As RECT
  Dim newWidth As Long
  Dim itemWidth As Long
  Dim sysScrollWidth As Long
  Me.Font.Name = lstFiles.Font.Name
  Me.Font.Bold = lstFiles.Font.Bold
  Me.Font.Size = lstFiles.Font.Size
  sysScrollWidth = GetSystemMetrics(SM_CXVSCROLL)
  For c = 0 To lstFiles.ListCount - 1
      Call DrawText(frm_Open_Dialog.hDC, (lstFiles.List(c)), -1&, rcText, DT_CALCRECT)
            itemWidth = rcText.Right + sysScrollWidth
      If itemWidth >= newWidth Then
        newWidth = itemWidth
      End If
  Next
      Call SendMessage(lstFiles.hwnd, LB_SETHORIZONTALEXTENT, newWidth, ByVal 0&)
b:
End Function

'Liste açma formu burda bitiyor......
 

Option Explicit
Private iRet As Integer
Private OldX As Integer
Private OldY As Integer
Private DragMode As Boolean
Dim MoveMe As Boolean
Dim Fso As New FileSystemObject
Dim CurRgn, TempRgn As Long  ' Region variables
Private Declare Function ExtCreateRegion Lib "gdi32" (lpXform As Any, ByVal nCount As Long, lpRgnData As Any) As Long
Private Declare Function SetWindowRgn Lib "user32" (ByVal hwnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long

'Fast binary Data
Private Declare Function GetBitmapBits Lib "gdi32" (ByVal hBitmap As Long, ByVal dwCount As Long, lpBits As Any) As Long
Private Declare Function GetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long

Dim PicInfo As BITMAP

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 Sub cmdBack_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
cmdBack.Top = 645 + 15
Label5.Caption = cmdBack.ToolTipText
End Sub

Private Sub cmdClear_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Label5.Caption = cmdClear.ToolTipText
End Sub

Private Sub cmdExit_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
cmdExit.Top = 15
Minimize.Top = 0
tray.Top = 15
Label5.Caption = cmdExit.ToolTipText
End Sub

Private Sub cmdFull_Click()
Media.fullScreen = True
End Sub

Private Sub cmdFull_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
cmdFull.Top = 330 + 15
Label5.Caption = cmdFull.ToolTipText
End Sub

Private Sub cmdLoadList_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
cmdLoadList.Top = 1310 + 15
Label5.Caption = cmdLoadList.ToolTipText
End Sub

Private Sub cmdMoveDown_Click()
On Error GoTo b
iRet = MoveDown_Click(Playlist)
b:
End Sub

Private Sub cmdMoveDown_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Label5.Caption = cmdMoveDown.ToolTipText
End Sub

Private Sub cmdMoveUp1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Label5.Caption = cmdMoveUp1.ToolTipText
End Sub

Private Sub cmdMoveUp1_Click()
On Error GoTo b
iRet = MoveUp_Click(Playlist)
b:
End Sub

Private Sub cmdNext_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
cmdNext.Top = 645 + 15
Label5.Caption = cmdNext.ToolTipText
End Sub

Private Sub cmdOpen_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
cmdOpen.Top = 300 + 15
Label5.Caption = cmdOpen.ToolTipText
End Sub

Private Sub cmdPause_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
cmdPause.Top = 455 + 15
Label5.Caption = cmdPause.ToolTipText
End Sub

Private Sub cmdPlay_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
cmdPlay.Top = 770 + 15
Label5.Caption = cmdPlay.ToolTipText
End Sub

Private Sub cmdRemove_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Label5.Caption = cmdRemove.ToolTipText
End Sub

Private Sub cmdSaveList_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
cmdSaveList.Top = 330 + 15
Label5.Caption = cmdSaveList.ToolTipText
End Sub

Private Sub cmdStop_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
cmdStop.Top = 1200 + 10
cmdStop.Left = 520 + 20
Label5.Caption = cmdStop.ToolTipText
End Sub

Private Sub Form_Load()
Horizental
Dim Region As Long
Dim ByteCtr As Long
Dim ByteData(18559) As Byte

ByteCtr = 18560
'Get the Data
GetObject PicHiddenData.Image, Len(PicInfo), PicInfo
GetBitmapBits PicHiddenData.Image, ByteCtr, ByteData(0)

'Shape The Form
Region = ExtCreateRegion(ByVal 0&, ByteCtr, ByteData(0))
SetWindowRgn Me.hwnd, Region, True

If Timer2.Enabled = True Then
shuff.Visible = True
cont.Visible = False
End If

If Timer4.Enabled = True Then
shuff.Visible = False
cont.Visible = True
End If
VolumeSlider.Value = 100
Dim file As String
file = App.Path & "" & "Registry.dat"
Dim A As String
Dim X As String
On Error GoTo Error
Open file For Input As #1
Do Until EOF(1)
Input #1, A$
Playlist.AddItem A$
Loop
Close 1
Exit Sub
Error:
"---------------------------------------
End Sub

Private Sub cmdBack_Click()
On Error GoTo b:
Playlist.ListIndex = Playlist.ListIndex - 1
Media.URL = SongTitle.Caption
Media.URL = Playlist.Text
On Error Resume Next
Media.Controls.play
SongTitle.Caption = Playlist.Text
b:
End Sub

Private Sub cmdClear_Click()
Playlist.Clear
SongTitle.Caption = ""
End Sub

Private Sub cmdExit_Click()
Unload frmmain
Unload frm_Open_Dialog
End Sub

Private Sub CmdLoadList_Click()
Dim file As String
Dialog.DialogTitle = "Load Bassam PlayList."
Dialog.MaxFileSize = 16384
Dialog.FileName = ""
Dialog.Filter = "Bassam PlayList Files|*.Bassam"
Dialog.ShowOpen    ' = 1
If Dialog.FileName = "" Then Exit Sub
file = Dialog.FileName
Dim A As String
Dim X As String
On Error GoTo Error
Open file For Input As #1
Do Until EOF(1)
Input #1, A$
Playlist.AddItem A$
Loop
Close 1
Exit Sub
Call xListKillDupes(Playlist) 'calls sub from module
Error:
X = MsgBox("File Not Found", vbOKOnly, "Error")
End Sub

Private Sub cmdNext_Click()
On Error GoTo b:
Playlist.ListIndex = Playlist.ListIndex + 1
Media.URL = SongTitle.Caption
Media.URL = Playlist.Text
On Error Resume Next
Media.Controls.play
SongTitle.Caption = Playlist.Text
b:
End Sub

Private Sub cmdOpen_Click()
frm_Open_Dialog.Show vbModal
End Sub

Private Sub CmdPause_Click()
On Error GoTo b
If Playlist.ListCount = 0 Then Exit Sub
If SongTitle.Caption = "" Then Exit Sub
If cmdPause.ToolTipText = "Pause Song" Then
Media.Controls.pause
'cmdPause.ToolTipText = "Resume"
Else
'Media.Controls.play
'cmdPause.ToolTipText = "Pause"
End If
b:
End Sub

Private Sub CmdPlay_Click()
SongTitle.Caption = Playlist.Text
On Error Resume Next
Media.URL = SongTitle.Caption
If SongTitle.Caption <> "" Then
Media.Controls.play
Media.Controls.currentPosition = TimeSlider.Value
cmdPause.ToolTipText = "Pause Song"
Else
MsgBox "No file to play", vbOKOnly, "Error"
End If
End Sub

Private Sub cmdRemove_Click()
If Playlist.ListIndex = -1 Then
MsgBox "No file selected", vbExclamation, "Error"
Else
Playlist.RemoveItem Playlist.ListIndex
SongTitle.Caption = ""
End If
End Sub

Private Sub cmdSaveList_Click()
On Error Resume Next
Dim intRecord As Integer
    Dim strFilePath As String
    Dim ListData As Variant
    With Dialog
        .Flags = cdlOFNOverwritePrompt
      '.InitDir = App.Path
        .DefaultExt = "Bassam"
        .Filter = "Bassam Media PlayList Files|*.Bassam"
        .ShowSave
        strFilePath = .FileName
    End With
    If strFilePath <> "" Then
        Open strFilePath For Output As #1
        For intRecord = 0 To Playlist.ListCount - 1
            Write #1, Playlist.List(intRecord)
        Next intRecord
        Close #1
    End If
End Sub

Private Sub cmdStop_Click()
Media.Controls.pause
TimeSlider.Value = 0
Media.Controls.currentPosition = TimeSlider.Value
SongTitle.Caption = ""
End Sub

Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
MoveMe = True
OldX = X
OldY = Y
End Sub

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
If MoveMe = True Then
  frmmain.Left = frmmain.Left + (X - OldX)
  frmmain.Top = frmmain.Top + (Y - OldY)
End If
Minimize.Top = 0
cmdExit.Top = 0
tray.Top = 15
cmdFull.Top = 330
cmdSaveList.Top = 330
cmdOpen.Top = 300
cmdLoadList.Top = 1310
cmdStop.Top = 1200
cmdStop.Left = 520
cmdNext.Top = 645
cmdPlay.Top = 770
cmdPause.Top = 455
cmdBack.Top = 645
Label5.Caption = ""
End Sub

Private Sub Form_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
frmmain.Left = frmmain.Left + (X - OldX)
frmmain.Top = frmmain.Top + (Y - OldY)
MoveMe = False
End Sub

Private Sub Form_Unload(Cancel As Integer)
Set frmmain = Nothing 'good practice to free resources VB doesn't normally free when you unload a form!

On Error GoTo b
Open (App.Path & "" & "Registry.dat") For Output As #1
      Dim i%
      For i = 0 To Playlist.ListCount - 1
      Print #1, Playlist.List(i)
      Next
      Close #1
b:
End Sub

Private Sub Image1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
MoveMe = True
OldX = X
OldY = Y
End Sub

Private Sub Image1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
If MoveMe = True Then
  frmmain.Left = frmmain.Left + (X - OldX)
  frmmain.Top = frmmain.Top + (Y - OldY)
End If
cmdExit.Top = 0
Minimize.Top = 0
tray.Top = 15
cmdFull.Top = 330
cmdSaveList.Top = 330
Label5.Caption = ""
End Sub

Private Sub Image1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
frmmain.Left = frmmain.Left + (X - OldX)
frmmain.Top = frmmain.Top + (Y - OldY)
MoveMe = False
End Sub

Private Sub Label1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
MoveMe = True
OldX = X
OldY = Y
End Sub

Private Sub Label1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
If MoveMe = True Then
  frmmain.Left = frmmain.Left + (X - OldX)
  frmmain.Top = frmmain.Top + (Y - OldY)
End If
Minimize.Top = 0
cmdExit.Top = 0
tray.Top = 0
cmdFull.Top = 330
cmdSaveList.Top = 330
cmdOpen.Top = 300
cmdLoadList.Top = 1310
cmdStop.Top = 1200
cmdStop.Left = 520
cmdNext.Top = 645
cmdPlay.Top = 770
cmdPause.Top = 455
cmdBack.Top = 645
Label5.Caption = "The Author"
End Sub

Private Sub Label1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
frmmain.Left = frmmain.Left + (X - OldX)
frmmain.Top = frmmain.Top + (Y - OldY)
MoveMe = False
End Sub

Private Sub Label2_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
MoveMe = True
OldX = X
OldY = Y
End Sub

Private Sub Label2_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
If MoveMe = True Then
  frmmain.Left = frmmain.Left + (X - OldX)
  frmmain.Top = frmmain.Top + (Y - OldY)
End If
Minimize.Top = 0
cmdExit.Top = 0
tray.Top = 0
cmdFull.Top = 330
cmdSaveList.Top = 330
cmdOpen.Top = 300
cmdLoadList.Top = 1310
cmdStop.Top = 1200
cmdStop.Left = 520
cmdNext.Top = 645
cmdPlay.Top = 770
cmdPause.Top = 455
cmdBack.Top = 645
End Sub

Private Sub Label2_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
frmmain.Left = frmmain.Left + (X - OldX)
frmmain.Top = frmmain.Top + (Y - OldY)
MoveMe = False
End Sub

Private Sub Label3_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
MoveMe = True
OldX = X
OldY = Y
End Sub

Private Sub Label3_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
If MoveMe = True Then
  frmmain.Left = frmmain.Left + (X - OldX)
  frmmain.Top = frmmain.Top + (Y - OldY)
End If
Minimize.Top = 0
cmdExit.Top = 0
tray.Top = 0
cmdFull.Top = 330
cmdSaveList.Top = 330
cmdOpen.Top = 300
cmdLoadList.Top = 1310
cmdStop.Top = 1200
cmdStop.Left = 520
cmdNext.Top = 645
cmdPlay.Top = 770
cmdPause.Top = 455
cmdBack.Top = 645
End Sub

Private Sub Label3_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
frmmain.Left = frmmain.Left + (X - OldX)
frmmain.Top = frmmain.Top + (Y - OldY)
MoveMe = False
End Sub

Private Sub Looop_Click()
Timer2.Enabled = False
If Timer4.Enabled = False Then
Timer4.Enabled = True
shuff.Visible = False
cont.Visible = True
Exit Sub
End If
If Timer4.Enabled = True Then
Timer4.Enabled = False
Exit Sub
End If
End Sub

Private Sub Looop_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Label5.Caption = Looop.ToolTipText
End Sub

Private Sub Media_MouseMove(ByVal nButton As Integer, ByVal nShiftState As Integer, ByVal fX As Long, ByVal fY As Long)
Label5.Caption = "Vedio Screen"
End Sub

Private Sub Minimize_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Minimize.Top = 15
cmdExit.Top = 0
tray.Top = 15
Label5.Caption = Minimize.ToolTipText
End Sub

Private Sub Playlist_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Playlist.ToolTipText = SongTitle.Caption
Label5.Caption = "Play-List"
End Sub

Private Sub Shuffle_Click()
Timer4.Enabled = False
If Timer2.Enabled = False Then
Timer2.Enabled = True
shuff.Visible = True
cont.Visible = False
Exit Sub
End If
If Timer2.Enabled = True Then
Timer2.Enabled = False
Exit Sub
End If
End Sub

Private Sub Media_OpenStateChange(ByVal NewState As Long)
If Timer2.Enabled = True Then
shuff.Visible = True
cont.Visible = False
End If

If Timer4.Enabled = True Then
shuff.Visible = False
cont.Visible = True
End If

On Error GoTo b:
Timer1.Enabled = True
b:
End Sub

Private Sub Minimize_Click()
frmmain.WindowState = 1
End Sub

Private Sub Playlist_Click()
SongTitle.Caption = Playlist.Text
Horizental
End Sub

Private Sub Playlist_DblClick()
SongTitle.Caption = Playlist.Text
On Error Resume Next
Media.URL = SongTitle.Caption
If SongTitle.Caption <> "" Then
Media.Controls.play
TimeSlider.Max = Media.currentMedia.duration
Else
MsgBox "No file to play", vbOKOnly, "Error"
End If
End Sub

Private Sub Shuffle_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Label5.Caption = Shuffle.ToolTipText
End Sub

Private Sub Slider1_Change(Value As Long)
On Error GoTo b
If Slider1.Value > -500 And Slider1.Value < 500 Then
End If
If Slider1.Value < -500 Then
End If
If Slider1.Value > 500 Then
End If
Media.settings.balance = Slider1.Value
Exit Sub
b:
MsgBox "Err"
Exit Sub
End Sub

Private Sub Slider1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Label5.Caption = "Balance Bar"
End Sub

Private Sub Timer1_Timer()
On Error GoTo F
TimeSlider.Value = Media.Controls.currentPosition
TimeSlider.Max = Media.currentMedia.duration
If Media.currentMedia.duration > 0 Then
Else
Exit Sub
End If
Dim i As Integer
Dim min As Integer
Dim sec As Integer
i = Val(Format(Media.Controls.currentPosition, "###"))
If i > 59 Then
min = i \ 60
sec = i Mod 60
SongDuration.Caption = Format(min, "0#") & ":" & Format(sec, "00")
Else
If i > -1 Then
SongDuration.Caption = "00" & ":" & Format(i, "0#")
End If
End If

i = Val(Format(frmmain.Media.currentMedia.duration, "###"))
If i > 59 Then
min = i \ 60
sec = i Mod 60
SongTime.Caption = "/" & Format(min, "0#") & ":" & Format(sec, "00")
Else
If i > -1 Then
End If
End If
F:
End Sub

Private Sub Timer2_Timer()
On Error GoTo b:
Dim rand$
Dim blah$
If Media.playState = wmppsStopped Then
On Error Resume Next
Playlist.ListIndex = Module1.RandomNumber(Playlist.ListCount)
rand$ = Playlist.Text
On Error Resume Next
Media.URL = rand$
Media.Controls.play
Playlist.ListIndex = Playlist.Text
blah$ = Module1.ReplaceString(Playlist.Text, ".mp3 ", "")
Playlist.Text = Playlist.ListIndex
SongTitle.Caption = Media.URL
Timer1.Enabled = True
End If
b:
End Sub

Private Sub Timer4_Timer()
On Error GoTo b:
If Media.playState = wmppsStopped Then
Playlist.ListIndex = Playlist.ListIndex + 1
Media.URL = Playlist.Text
On Error Resume Next
Media.Controls.play
End If
b:
End Sub

Private Sub TimeSlider_Change(Value As Long)
Media.Controls.currentPosition = TimeSlider.Value
End Sub

Private Sub TimeSlider_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Label5.Caption = "Time Bar"
End Sub

Private Sub tray_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Minimize.Top = 0
cmdExit.Top = 0
tray.Top = 30
Label5.Caption = tray.ToolTipText
End Sub

Private Sub VolumeSlider_Change(Value As Long)
Media.settings.volume = VolumeSlider.Value
lblVolume.Caption = "Volume " & VolumeSlider.Value & " %"
End Sub

Private Sub VolumeSlider_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Media.settings.volume = VolumeSlider.Value
lblVolume.Caption = "Volume " & VolumeSlider.Value & " %"
End Sub

Private Sub VolumeSlider_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Label5.Caption = "Volume Bar"
End Sub

Function Horizental()
On Error GoTo b
  Dim c As Long
  Dim rcText As RECT
  Dim newWidth As Long
  Dim itemWidth As Long
  Dim sysScrollWidth As Long
  Me.Font.Name = Playlist.Font.Name
  Me.Font.Bold = Playlist.Font.Bold
  Me.Font.Size = Playlist.Font.Size
  sysScrollWidth = GetSystemMetrics(SM_CXVSCROLL)
  For c = 0 To Playlist.ListCount - 1
      Call DrawText(frmmain.hDC, (Playlist.List(c)), -1&, rcText, DT_CALCRECT)
            itemWidth = rcText.Right + sysScrollWidth
      If itemWidth >= newWidth Then
        newWidth = itemWidth
      End If
  Next
      Call SendMessage(Playlist.hwnd, LB_SETHORIZONTALEXTENT, newWidth, ByVal 0&)
b:
End Function

Public Function MoveUp_Click(lstMove As listbox) As Integer
On Error GoTo b
'not by source
    Dim strTemp1 As String  '-- hold the selected index data temporarily for move
    Dim iCnt    As Integer  '-- holds the index of the item to be moved
    iCnt = lstMove.ListIndex
    If iCnt > -1 Then
        strTemp1 = lstMove.List(iCnt)
        '-- Add the item selected to one position above the current position
        lstMove.AddItem strTemp1, (iCnt - 1)
        '-- remove it from the current position. Note the current position has changed because the add has moved everything down by 1
        lstMove.RemoveItem (iCnt + 1)
        '-- Reselect the item that was moved.
            lstMove.Selected(iCnt - 1) = True
    End If
b:
End Function
Public Function MoveDown_Click(lstMove As listbox) As Integer
On Error GoTo b
    Dim strTemp1 As String    '-- hold the selected index data temporarily for move
    Dim iCnt    As Integer    '-- holds the index of the item to be moved
    '-- Assign the first index
    iCnt = lstMove.ListIndex
    If iCnt > -1 Then
        strTemp1 = lstMove.List(iCnt)
        '-- Add the item selected to below the current position
        lstMove.AddItem strTemp1, (iCnt + 2)
        lstMove.RemoveItem (iCnt)
        '-- Reselect the item that was moved.
        lstMove.Selected(iCnt + 1) = True
  End If
b:
End Function

'Burda da ana form bitiyor
 

Option Explicit

Public CalculationDone As Boolean
Public TransColor As Long
Public ByteCtr As Long
Public RgnData() As Byte

Private Const RGN_XOR = 3
Private Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function CombineRgn Lib "gdi32" (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long
Private Declare Function SetWindowRgn Lib "user32" (ByVal hwnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC 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 GetRegionData Lib "gdi32" (ByVal hRgn As Long, ByVal dwCount As Long, lpRgnData As Any) As Long


Private Declare Function GetBitmapBits Lib "gdi32" (ByVal hBitmap As Long, ByVal dwCount As Long, lpBits As Any) As Long
Private Declare Function SetBitmapBits Lib "gdi32" (ByVal hBitmap As Long, ByVal dwCount As Long, lpBits As Any) As Long
Private Declare Function GetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long



Private PicInfo As BITMAP

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

'Calculate a Region to shape the form
Public Sub CalcPic()

Dim rgnMain As Long
Dim X As Long
Dim Y As Long
Dim rgnPixel As Long
Dim RGBColor As Long
Dim dcMain As Long
Dim bmpMain As Long
Dim Width As Long
Dim Height As Long

Dim LastHit As Boolean
Dim StartX As Long
Dim StartY As Long


'Create A region to shape the Form
    Width = frmmain.ScaleX(frmmain.Width, vbTwips, vbPixels)
    Height = frmmain.ScaleY(frmmain.Height, vbTwips, vbPixels)
'Create a new Region
    rgnMain = CreateRectRgn(0, 0, Width, Height)
    dcMain = CreateCompatibleDC(frmmain.hDC)
'Get the picture we us for this calculation
    bmpMain = SelectObject(dcMain, frmmain.Picture.Handle)

'Move thru it
    For Y = 0 To Height
        For X = 0 To Width
            RGBColor = GetPixel(dcMain, X, Y)
'Found a transparent spot
'make it also tramsparent on the region
            If RGBColor = TransColor And LastHit = False Then
                LastHit = True
                StartX = X
                StartY = Y
            ElseIf LastHit = True And RGBColor <> TransColor Then
                LastHit = False
'we found Transparent Pixels now create a region
                If Y > StartY Then 'We found more than one row of transparent pixels
                    If StartX > 0 Then 'We didnt start at point 0 so create the first line
                        rgnPixel = CreateRectRgn(StartX, StartY, Width + 1, StartY + 1) 'The first line from start to the end
                        CombineRgn rgnMain, rgnMain, rgnPixel, RGN_XOR
                        DeleteObject rgnPixel
                    Else
                        StartY = StartY - 1 'Tell the code to do one line more
                    End If
                    If Y > StartY + 1 Then
                        rgnPixel = CreateRectRgn(0, StartY + 1, Width + 1, Y)  'Now line 2 to y
                        CombineRgn rgnMain, rgnMain, rgnPixel, RGN_XOR
                        DeleteObject rgnPixel
                    End If
                    rgnPixel = CreateRectRgn(0, Y, X, Y + 1) 'the last line (x because the actual pixel is not ok)
                    CombineRgn rgnMain, rgnMain, rgnPixel, RGN_XOR
                    DeleteObject rgnPixel
                Else 'We are still in the same line so create only the pixels we found
                    rgnPixel = CreateRectRgn(StartX, Y, X, Y + 1)
                    CombineRgn rgnMain, rgnMain, rgnPixel, RGN_XOR
                    DeleteObject rgnPixel
                End If
            End If
        Next X
    Next Y

'Remove unused
    SelectObject dcMain, bmpMain
    DeleteDC dcMain
    DeleteObject bmpMain
   
'Get the Region Data so we can store it later
    If rgnMain <> 0 Then
        ByteCtr = GetRegionData(rgnMain, 0, ByVal 0&)
        If ByteCtr > 0 Then
            ReDim RgnData(0 To ByteCtr - 1)
            ByteCtr = GetRegionData(rgnMain, ByteCtr, RgnData(0))
        End If
'Shape the form
        SetWindowRgn frmmain.hwnd, rgnMain, True
    End If
    CalculationDone = True

End Sub

'---------------------------------------------------------------
Function RandomNumber(finished)
Randomize
RandomNumber = Int((Val(finished) * Rnd) + 1)
End Function

Public Function ReplaceString(MyString As String, ToFind As String, ReplaceWith As String) As String
    Dim Spot As Long, NewSpot As Long, LeftString As String
    Dim RightString As String, NewString As String
    Spot& = InStr(LCase(MyString$), LCase(ToFind))
    NewSpot& = Spot&
    Do
        If NewSpot& > 0& Then
            LeftString$ = Left(MyString$, NewSpot& - 1)
            If Spot& + Len(ToFind$) <= Len(MyString$) Then
                RightString$ = Right(MyString$, Len(MyString$) - NewSpot& - Len(ToFind$) + 1)
            Else
                RightString = ""
            End If
            NewString$ = LeftString$ & ReplaceWith$ & RightString$
            MyString$ = NewString$
        Else
            NewString$ = MyString$
        End If
        Spot& = NewSpot& + Len(ReplaceWith$)
        If Spot& > 0 Then
            NewSpot& = InStr(Spot&, LCase(MyString$), LCase(ToFind$))
        End If
    Loop Until NewSpot& < 1
    ReplaceString$ = NewString$
End Function

'burda da 1.modül bitiyor
 

Option Explicit
Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Public Declare Function SendMessageByString Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As String) As Long
Public Declare Function SendMessageLong& Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long)
Public Declare Function SendMessageByNum& Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long)
Public Const LB_ADDSTRING& = &H180
Public Const LB_DELETESTRING = &H182
Public Const LB_FINDSTRINGEXACT& = &H1A2
Public Const LB_GETCOUNT& = &H18B
Public Const LB_GETCURSEL& = &H188
Public Const LB_GETITEMDATA = &H199
Public Const LB_GETTEXT = &H189
Public Const LB_GETTEXTLEN& = &H18A
Public Const LB_INSERTSTRING = &H181
Public Const LB_RESETCONTENT& = &H184
Public Const LB_SETHORIZONTALEXTENT = &H194
Public Const LB_SETSEL = &H185

Public Const LB_GETHORIZONTALEXTENT = &H193
Public Const DT_CALCRECT = &H400
Public Const SM_CXVSCROLL = 2

Public Type RECT
  Left As Long
  Top As Long
  Right As Long
  Bottom As Long
End Type

Public Declare Function DrawText Lib "user32" _
  Alias "DrawTextA" _
  (ByVal hDC As Long, _
  ByVal lpStr As String, _
  ByVal nCount As Long, _
  lpRect As RECT, ByVal _
  wFormat As Long) As Long
 
Public Declare Function GetSystemMetrics Lib "user32" _
  (ByVal nIndex As Long) As Long



Public Sub xListKillDupes(listbox As listbox)
'Kills dublicite items in a listbox
        Dim Search1 As Long
        Dim Search2 As Long
        Dim KillDupe As Long
KillDupe = 0
For Search1& = 0 To listbox.ListCount - 1
For Search2& = Search1& + 1 To listbox.ListCount - 1
KillDupe = KillDupe + 1
If listbox.List(Search1&) = listbox.List(Search2&) Then
listbox.RemoveItem Search2&
Search2& = Search2& - 1
End If
Next Search2&
Next Search1&
End Sub
 

Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hDC As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long


Private Declare Function TransparentBlt Lib "msimg32" _
                (ByVal hDCDst As Long, ByVal nXOriginDst As Long, _
                ByVal nYOriginDst As Long, ByVal nWidthDst As Long, _
                ByVal nHeightDst As Long, ByVal hDCSrc As Long, _
                ByVal nXOriginSrc As Long, ByVal nYOriginSrc As Long, _
                ByVal nWidthSrc As Long, ByVal nHeightSrc As Long, _
                ByVal crTransparent As Long) As Long
               
               
Private Declare Function DrawIconEx Lib "user32" (ByVal hDC As Long, ByVal xLeft As Long, ByVal yTop As Long, ByVal hIcon As Long, ByVal cxWidth As Long, ByVal cyHeight As Long, ByVal istepIfAniCur As Long, ByVal hbrFlickerFreeDraw As Long, ByVal diFlags As Long) As Long
' DrawIconEx constants
Private Const DI_MASK = &H1
Private Const DI_IMAGE = &H2
Private Const DI_NORMAL = &H3
Private Const DI_COMPAT = &H4
Private Const DI_DEFAULTSIZE = &H8


Private Declare Function SetCapture Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long

Private Type POINTAPI
    X As Long
    Y As Long
End Type

Enum AlignConstants
    [AlignNone]
    [AlignTop]
    [AlignBottom]
    [AlignLeft]
    [AlignRight]
End Enum


Enum ButtonStyleConstants
    [Standard]
    [Graphical]
End Enum

Dim g_3DInc As Integer

Dim g_MouseDown As Boolean, g_MouseIn As Boolean, g_Selected As Boolean
Dim g_Button As Integer, g_Shift As Integer, g_X As Single, g_Y As Single

Const m_def_Style = 0              'Standard
Const m_def_UseMaskColor = False
Const m_def_PictureAlign = 0        'AlignNone (Center)

'Property Variables:
Dim m_Style As ButtonStyleConstants
Dim m_UseMaskColor As Boolean
Dim m_PictureAlign As AlignConstants

'Dim m_PictureBack As StdPicture
Dim m_PictureNormal As StdPicture
Dim m_PictureDown As StdPicture
Dim m_PictureOver As StdPicture
Dim m_PictureDisabled As StdPicture

Dim g_Light As OLE_COLOR
Dim g_Shadow As OLE_COLOR
Dim g_HighLight As OLE_COLOR
Dim g_DarkShadow As OLE_COLOR

'Event Declarations:
Event Click()
Event KeyDown(KeyCode As Integer, Shift As Integer)
Event KeyPress(KeyAscii As Integer)
Event KeyUp(KeyCode As Integer, Shift As Integer)
Event MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Event MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Event MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
Event MouseIn(Shift As Integer)
Event MouseOut(Shift As Integer)



'################################################################################
'  Init / read / write properties
'################################################################################

Private Sub UserControl_InitProperties()


    m_Style = m_def_Style
    m_UseMaskColor = m_def_UseMaskColor
    m_PictureAlign = m_def_PictureAlign

   
    Set m_PictureNormal = LoadPicture("")
    Set m_PictureDisabled = LoadPicture("")
    Set m_PictureDown = LoadPicture("")
    Set m_PictureOver = LoadPicture("")
   
    UserControl.BackColor = Ambient.BackColor

End Sub

Private Sub UserControl_ReadProperties(PropBag As PropertyBag)

    m_Style = PropBag.ReadProperty("Style", m_def_Style)
    m_UseMaskColor = PropBag.ReadProperty("UseMaskColor", m_def_UseMaskColor)
    m_PictureAlign = PropBag.ReadProperty("PictureAlign", m_def_PictureAlign)

    Set UserControl.Picture = PropBag.ReadProperty("PictureBack", Nothing)
    Set m_PictureNormal = PropBag.ReadProperty("PictureNormal", Nothing)
    Set m_PictureDisabled = PropBag.ReadProperty("PictureDisabled", Nothing)
    Set m_PictureDown = PropBag.ReadProperty("PictureDown", Nothing)
    Set m_PictureOver = PropBag.ReadProperty("PictureOver", Nothing)
    Set MouseIcon = PropBag.ReadProperty("MouseIcon", Nothing)
   
    UserControl.BackColor = PropBag.ReadProperty("ButtonColor", &H8000000F)
   
    g_Selected = PropBag.ReadProperty("Selected", falso)
    UserControl.MaskColor = PropBag.ReadProperty("MaskColor", &H8000000F)
    UserControl.MousePointer = PropBag.ReadProperty("MousePointer", 0)
   
    Refresh
End Sub

Private Sub UserControl_WriteProperties(PropBag As PropertyBag)

    Call PropBag.WriteProperty("ButtonColor", UserControl.BackColor, &H8000000F)
    Call PropBag.WriteProperty("Selected", g_Selected, False)
    Call PropBag.WriteProperty("PictureAlign", m_PictureAlign, m_def_PictureAlign)
    Call PropBag.WriteProperty("MaskColor", UserControl.MaskColor, &H8000000F)
    Call PropBag.WriteProperty("MouseIcon", MouseIcon, Nothing)
    Call PropBag.WriteProperty("MousePointer", UserControl.MousePointer, 0)
    Call PropBag.WriteProperty("PictureBack", UserControl.Picture, Nothing)
    Call PropBag.WriteProperty("PictureNormal", m_PictureNormal, Nothing)
    Call PropBag.WriteProperty("PictureDisabled", m_PictureDisabled, Nothing)
    Call PropBag.WriteProperty("PictureDown", m_PictureDown, Nothing)
    Call PropBag.WriteProperty("PictureOver", m_PictureOver, Nothing)
    Call PropBag.WriteProperty("Style", m_Style, m_def_Style)
    Call PropBag.WriteProperty("UseMaskColor", m_UseMaskColor, m_def_UseMaskColor)

End Sub


'################################################################################
'  'Ambient' control
'################################################################################
Private Sub UserControl_Resize()
   
    Refresh
   
End Sub

Public Sub Refresh()
   
    AutoRedraw = True
   
        UserControl.Cls
 
        'Draw picture
       
        If m_Style = Graphical Then DrawPicture
           
    AutoRedraw = False
   
End Sub


'################################################################################
'  Events
'################################################################################

Private Sub UserControl_DblClick()

    SetCapture hwnd 'Preseve hWnd on DblClick
    UserControl_MouseDown g_Button, g_Shift, g_X, g_Y

End Sub

Private Sub UserControl_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
   
    g_Button = Button: g_Shift = Shift: g_X = X: g_Y = Y
       
    If Button <> vbRightButton Then
   
        g_MouseDown = True
        Refresh
       
    End If
   
    RaiseEvent MouseDown(Button, Shift, X, Y)
   
End Sub

Private Sub UserControl_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
       
    If (X >= 0 And Y >= 0) And (X < ScaleWidth And Y < ScaleHeight) Then
   
        If g_MouseIn = False Then
           
            OverTimer.Enabled = True
            g_MouseIn = True
           
            RaiseEvent MouseIn(Shift)
           
            Refresh
           
        End If
 
    End If
 
    RaiseEvent MouseMove(Button, Shift, X, Y)

End Sub

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

    g_MouseDown = False
   
    If Button <> vbRightButton Then
       
        Refresh
        If (X >= 0 And Y >= 0) And (X < ScaleWidth And Y < ScaleHeight) Then RaiseEvent Click
   
    End If
   
    RaiseEvent MouseUp(Button, Shift, X, Y)
   
End Sub




'################################################################################
'  Properties
'################################################################################

Public Property Get PictureAlign() As AlignConstants

    PictureAlign = m_PictureAlign
   
End Property

Public Property Let PictureAlign(ByVal New_PictureAlign As AlignConstants)

    m_PictureAlign = New_PictureAlign
    PropertyChanged "PictureAlign"
   
    Refresh
   
End Property

'ButtonColor ####################################################################

Public Property Get ButtonColor() As OLE_COLOR

    ButtonColor = UserControl.BackColor
   
End Property

Public Property Let ButtonColor(ByVal New_ButtonColor As OLE_COLOR)
               
    UserControl.BackColor = New_ButtonColor
    PropertyChanged "ButtonColor"

    Refresh
   
End Property

'Selected ########################################################################
Public Property Get Selected() As Boolean

    Selected = g_Selected
   
End Property

Public Property Let Selected(ByVal New_Selected As Boolean)

    g_Selected = New_Selected
    PropertyChanged "Selected"
   
    Refresh
   
End Property

'hWnd ###########################################################################
Public Property Get hwnd() As Long

    hwnd = UserControl.hwnd

End Property

'MaskColor ######################################################################
Public Property Get MaskColor() As OLE_COLOR

    MaskColor = UserControl.MaskColor
   
End Property

Public Property Let MaskColor(ByVal New_MaskColor As OLE_COLOR)

    UserControl.MaskColor() = New_MaskColor
    PropertyChanged "MaskColor"
   
    Refresh
   
End Property

'MousePointer & MouseIcon #######################################################
Public Property Get MousePointer() As MousePointerConstants

    MousePointer = UserControl.MousePointer
   
End Property

Public Property Let MousePointer(ByVal New_MousePointer As MousePointerConstants)

    UserControl.MousePointer() = New_MousePointer
    PropertyChanged "MousePointer"
   
End Property

Public Property Get MouseIcon() As StdPicture

    Set MouseIcon = UserControl.MouseIcon
   
End Property

Public Property Set MouseIcon(ByVal New_MouseIcon As StdPicture)

    Set UserControl.MouseIcon = New_MouseIcon
    PropertyChanged "MouseIcon"
   
End Property

'Picture, PictureNormal,PictureDisabled, PictureDown & PictureOver ############################
Public Property Get PictureBack() As StdPicture

    Set PictureBack = UserControl.Picture
   
End Property

Public Property Set PictureBack(ByVal New_Picture As StdPicture)
   
    Set UserControl.Picture = New_Picture
    PropertyChanged "PictureBack"
   
    Refresh
End Property


Public Property Get PictureNormal() As StdPicture

    Set PictureNormal = m_PictureNormal
   
End Property

Public Property Set PictureNormal(ByVal New_Picture As StdPicture)
   
    Set m_PictureNormal = New_Picture
    PropertyChanged "PictureNormal"
 
    Refresh
End Property

Public Property Get PictureDisabled() As StdPicture

    Set PictureDisabled = m_PictureDisabled
   
End Property

Public Property Set PictureDisabled(ByVal New_PictureDisabled As StdPicture)

    Set m_PictureDisabled = New_PictureDisabled
    PropertyChanged "PictureDisabled"
   
    Refresh
   
End Property

Public Property Get PictureDown() As StdPicture

    Set PictureDown = m_PictureDown
   
End Property

Public Property Set PictureDown(ByVal New_PictureDown As StdPicture)

    Set m_PictureDown = New_PictureDown
    PropertyChanged "PictureDown"
   
    Refresh
   
End Property

Public Property Get PictureOver() As StdPicture

    Set PictureOver = m_PictureOver
   
End Property

Public Property Set PictureOver(ByVal New_PictureOver As StdPicture)

    Set m_PictureOver = New_PictureOver
    PropertyChanged "PictureOver"
   
    Refresh
   
End Property

'Style ##########################################################################
Public Property Get Style() As ButtonStyleConstants

    Style = m_Style
   
End Property

Public Property Let Style(ByVal New_Style As ButtonStyleConstants)

    m_Style = New_Style
    PropertyChanged "Style"
   
    Refresh
   
End Property

'UseMaskColor ###################################################################
Public Property Get UseMaskColor() As Boolean

    UseMaskColor = m_UseMaskColor
   
End Property

Public Property Let UseMaskColor(ByVal New_UseMaskColor As Boolean)

    m_UseMaskColor = New_UseMaskColor
    PropertyChanged "UseMaskColor"
    Refresh
   
End Property

Public Sub Reset()
    Set m_PictureNormal = LoadPicture("")
    Set m_PictureDisabled = LoadPicture("")
    Set m_PictureDown = LoadPicture("")
    Set m_PictureOver = LoadPicture("")
    UserControl.MouseIcon = LoadPicture()
End Sub

'DrawPicture ####################################################################
'            1. Get picture by actual state
'            2. If no image in actual state: take normal state picture
'              If no normal state picture: exit sub
'            3. Set picture position by align mode
'            4. Readjust drawed text left/right margins
'            5. If UseMaskColor = True draw picture with standard PaintPicture
'              If not case:
'                  a) BMP, DIB, GIF, JPG: TransparentBlt function
'                    (StdPicture not accepted -> CreateCompatibleDC)
'                  b) ICO, CUR:          DrawIconEx function
'                    (Transp. 'ability' included in this type)
'                  c) WMF, EMF:          Standard PaintPicture function
'                    (Transp. 'ability' included in this type)
'                  d) Invalid picture

Private Sub DrawPicture()
   
    Set tmpPicture = New StdPicture
    Dim PosInc As Integer, PosX As Integer, PosY As Integer
    Dim W As Integer, H As Integer
       
    'Set tmpPicture by button state:
    If g_MouseDown Then
        'Mouse down
        Set tmpPicture = m_PictureDown  ': PosInc = 1
    ElseIf g_MouseIn And g_Selected = False Then
        'Mouse in (over)
        Set tmpPicture = m_PictureOver
    ElseIf g_Selected = True Then
        'Button disabled
        Set tmpPicture = m_PictureDisabled
    Else
        'Mouse out
        Set tmpPicture = m_PictureNormal
    End If
   
    If tmpPicture Is Nothing Then
        If m_PictureNormal Is Nothing Then
            'No picture
            Exit Sub
        Else
            'Use default picture for actual state
            Set tmpPicture = m_PictureNormal
        End If
    End If
   
    If tmpPicture = 0 Then Exit Sub 'Filter if not initialized
   
    g_TextWithPicture = True        'We have a picture
   
    'Set drawed picture dimensions (cms to pixels)
    W = Int(tmpPicture.Width / 26.1)
    H = Int(tmpPicture.Height / 26.1)
   
    'Set drawed picture location
    Select Case m_PictureAlign
   
        Dim MaxPicture As Integer
   
        Case 0 'None (center picture)
            PosX = Int((ScaleWidth - W) / 2) + PosInc
            PosY = Int((ScaleHeight - H) / 2) + PosInc
           
        Case 1 'Top
            PosX = Int((ScaleWidth - W) / 2) + PosInc
            PosY = PosInc + MaxPicture + 3
               
        Case 2 'Bottom
            PosX = Int((ScaleWidth - W) / 2) + PosInc
            PosY = (ScaleHeight - H) + PosInc - MaxPicture - 4
                 
        Case 3 'Left
            PosX = PosInc + MaxPicture + 3
            PosY = Int((ScaleHeight - H) / 2) + PosInc
       
        Case 4 'Right
            PosX = (ScaleWidth - W) + PosInc - MaxPicture - 4
            PosY = Int((ScaleHeight - H) / 2) + PosInc
       
    End Select
           

    If m_UseMaskColor Then
   
        Select Case tmpPicture.Type
         
            Case vbPicTypeBitmap        ' BMP, DIB, GIF, JPG
               
                hDCScreen = GetDC(0&)
               
                hDCSrc = CreateCompatibleDC(hDCScreen)
                        SelectObject hDCSrc, tmpPicture.Handle
               
                '???: TransparentBlt turns to 0 nXOriginDst and nYOriginDst values
                '    If PosX or PosY < 0 -> The picture can't be centered
               
                TransparentBlt hDC, PosX, PosY, W, H, _
                              hDCSrc, 0, 0, W, H, MaskColor
   
                DeleteDC hDCSrc
                ReleaseDC 0&, hDCScreen
               
            Case vbPicTypeIcon          ' ICO, CUR
   
                DrawIconEx hDC, PosX, PosY, tmpPicture.Handle, W, H, 0, 0, DI_NORMAL Or DI_DEFAULTSIZE
           
            Case vbPicTypeMetafile, _
                vbPicTypeEMetafile    ' WMF, EMF
           
                PaintPicture tmpPicture, PosX, PosY
           
            Case Else                  ' Invalid picture
   
                Err.Raise 481
               
        End Select
   
    Else
       
        PaintPicture tmpPicture, PosX, PosY
       
    End If
       
End Sub


'Timer ##########################################################################
'      Use of WindowFromPoint(X,Y) function
'      1. Get handle of actual absolute mouse position
'      2. If UserControl handle <> returned handle : Out of button
'        (See: Sub UserControl_MouseMove)

Private Sub OverTimer_Timer()
   
    Dim P As POINTAPI
   
    GetCursorPos P
   
    If hwnd <> WindowFromPoint(P.X, P.Y) Then
       
        OverTimer.Enabled = False
       
        g_MouseIn = False
        RaiseEvent MouseOut(g_Shift)

        Refresh                    'Refresh picture
       
        If g_MouseDown = True Then  'Resfresh state
            g_MouseDown = False
            Refresh
            g_MouseDown = True
        End If
       
    End If

End Sub
 

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 WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long

Private Type POINTAPI
    X As Long
    Y As Long
End Type

' Declarations
Dim iY As Long
Dim bDrag As Boolean
Dim iMin As Long
Dim iMax As Long
Dim iValue As Long
Private bMouseOver As Boolean, bMouseDown As Boolean
Private iLargeChange As Integer

Public Enum ePos
  Vertical = 0
  Horizontal = 1
End Enum

Private Enum eImg
  Normal = 0
  down = 1
  Over = 2
End Enum

Private ePosition As ePos
' Events
Event Change(Value As Long)
Event MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Event MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
Event MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)

'//--------------------------------------------------------------------------

Public Sub ResetPictures()
  picBack.Picture = LoadPicture()
  picBack1.Picture = LoadPicture()
  picBar.Picture = LoadPicture()
  picBarOver.Picture = LoadPicture()
  picBarDown.Picture = LoadPicture()
  picBack.MouseIcon = LoadPicture()
End Sub

Public Property Get MouseIcon() As Picture
    Set MouseIcon = picBar.MouseIcon
End Property

Public Property Set MouseIcon(ByVal New_Icon As Picture)
    Set picBack.MouseIcon = New_Icon

    PropertyChanged "MouseIcon"
End Property

Public Property Get BackColor() As OLE_COLOR
    BackColor = picBack.BackColor
End Property

Public Property Let BackColor(ByVal New_Color As OLE_COLOR)
    picBack.BackColor = New_Color
    picBack1.BackColor = New_Color
       
    PropertyChanged "BackColor"
End Property

Public Property Get Position() As ePos
    Position = ePosition
End Property

Public Property Let Position(ByVal NewValue As ePos)
  Dim W As Integer, H As Integer
    ePosition = NewValue
   
   
    If picBar.Picture <> 0 Then
      picBar.AutoSize = True
    Else
      picBar.Width = 9: picBar.Height = 9
    End If
   
    picBarOver.Width = picBar.Width: picBarOver.Height = picBar.Height
    picBarDown.Width = picBar.Width: picBarDown.Height = picBar.Height
       
    W = ScaleWidth
    H = ScaleHeight
   
    UserControl.Width = H * 15
    UserControl.Height = W * 15
   
    picBar.AutoSize = False
    picBarDown.AutoSize = False
    picBarOver.AutoSize = False
       
    UserControl_Resize
   
    PropertyChanged "Position"
End Property

Public Property Get Bar() As Picture
    Set Bar = picBar.Picture
End Property

Public Property Set Bar(ByVal New_Bar As Picture)
    Set picBar.Picture = New_Bar
         
    picBar.AutoSize = True
   
    If picBarDown.Picture = 0 Then
      picBarDown.Picture = picBar.Picture
      picBarDown.AutoSize = True
    End If
   
    If picBarOver.Picture = 0 Then
      picBarOver.Picture = picBar.Picture
      picBarOver.AutoSize = True
    End If
 
    picBar.AutoSize = False
    picBarDown.AutoSize = False
    picBarOver.AutoSize = False

 
    Call DrawBar(Normal)
    PropertyChanged "Bar"
End Property

Public Property Get BarDown() As Picture
    Set BarDown = picBarDown.Picture
End Property

Public Property Set BarDown(ByVal New_Bar As Picture)
    Set picBarDown.Picture = New_Bar
    picBarDown.AutoSize = True
    picBarDown.AutoSize = False
    PropertyChanged "BarDown"
End Property

Public Property Get BarOver() As Picture
    Set BarOver = picBarOver.Picture
End Property

Public Property Set BarOver(ByVal New_Bar As Picture)
    Set picBarOver.Picture = New_Bar
    picBarOver.AutoSize = True
    picBarOver.AutoSize = False
    PropertyChanged "BarOver"
End Property


Private Sub CalcValue()
On Error Resume Next
  If ePosition = Vertical Then
    iValue = iY / (picBack.Height - picBar.Height) * (iMax - iMin) + iMin
    If iMin < 0 Then iValue = -iValue Else iValue = iMax - iValue
  Else
    iValue = iY / (picBack.Width - picBar.Width) * (iMax - iMin) + iMin
  End If
End Sub


Private Sub DrawBar(ImgState As eImg, Optional CalculateX As Boolean = True)
  On Error Resume Next
  Dim intY As Integer, intX As Integer
     
     
    If CalculateX Then
      If ePosition = Vertical Then
      If iMin < 0 Then iValue = -iValue Else iValue = iMax - iValue
      iY = (iValue - iMin) / (iMax - iMin) * (picBack.Height - picBar.Height)
      intX = 0: intY = iY
      Else
      iY = (iValue - iMin) / (iMax - iMin) * (picBack.Width - picBar.Width)
      intX = iY: intY = 0
      End If
    Else
      If ePosition = Vertical Then intX = 0: intY = iY Else intX = iY: intY = 0
    End If
   
    picBack.Cls
   
    '// draw progress
    If ePosition = Vertical Then
      Call BitBlt(picBack.hDC, intX, intY, picBack1.ScaleWidth, picBack1.ScaleHeight, _
        picBack1.hDC, intX, intY, vbSrcCopy)
    Else
      Call BitBlt(picBack.hDC, 0, 0, intX, picBack1.ScaleHeight, _
        picBack1.hDC, 0, 0, vbSrcCopy)
    End If
 
    '//IMAGE OVER
    If bMouseOver = True Then
      If bMouseDown = True Then
          Call BitBlt(picBack.hDC, intX, intY, picBar.ScaleWidth, picBar.ScaleHeight, _
          picBarDown.hDC, 0, 0, vbSrcCopy)
      Else
          Call BitBlt(picBack.hDC, intX, intY, picBar.ScaleWidth, picBar.ScaleHeight, _
          picBarOver.hDC, 0, 0, vbSrcCopy)
      End If
     
      picBack.Refresh
      UserControl.Refresh
      Exit Sub
    End If

    If ImgState = Normal Then
        Call BitBlt(picBack.hDC, intX, intY, picBar.ScaleWidth, picBar.ScaleHeight, _
        picBar.hDC, 0, 0, vbSrcCopy)
    ElseIf ImgState = down Then
          Call BitBlt(picBack.hDC, intX, intY, picBar.ScaleWidth, picBar.ScaleHeight, _
          picBarDown.hDC, 0, 0, vbSrcCopy)
        ElseIf ImgState = Over Then
          Call BitBlt(picBack.hDC, intX, intY, picBar.ScaleWidth, picBar.ScaleHeight, _
            picBarOver.hDC, 0, 0, vbSrcCopy)
        End If
       
    picBack.Refresh
    UserControl.Refresh
End Sub
Public Property Get Max() As Long
    Max = iMax
End Property

Public Property Let Max(New_Max As Long)
    If iValue > New_Max Then iValue = New_Max
       
    iMax = New_Max
    Call DrawBar(Normal)
   
    PropertyChanged "Max"
End Property

Public Property Get min() As Long
    min = iMin
End Property

Public Property Let min(New_Min As Long)
    If New_Min > iValue Then iValue = New_Min
   
    iMin = New_Min
    Call DrawBar(Normal)
   
    PropertyChanged "Min"
End Property

Public Property Get LargeChange() As Integer
    LargeChange = iLargeChange
End Property

Public Property Let LargeChange(New_Value As Integer)
    If New_Value >= iMax Then Exit Property
   
    iLargeChange = New_Value
       
    PropertyChanged "LargeChange"
End Property


Public Property Get PictureBack() As Picture
    Set PictureBack = picBack.Picture
End Property

Public Property Set PictureBack(ByVal New_Picture As Picture)
    Set picBack.Picture = New_Picture
    picBack.AutoSize = True
    picBack.AutoSize = False
'    UserControl.Width = picBack.ScaleWidth * 15
'    UserControl.Height = picBack.ScaleHeight * 15
   
    If picBack1.Picture = 0 Then
    picBack1.Picture = picBack.Picture
    picBack1.AutoSize = True
    picBack1.AutoSize = False
    End If
   
    Call DrawBar(Normal)
   
    PropertyChanged "PictureBack"
End Property
Public Property Get PictureProgress() As Picture
    Set PictureProgress = picBack1.Picture
End Property

Public Property Set PictureProgress(ByVal New_Picture2 As Picture)
    Set picBack1.Picture = New_Picture2
    picBack1.AutoSize = True
    picBack1.AutoSize = False
   
    Call DrawBar(Normal)
   
    PropertyChanged "PictureProgress"
End Property


Public Property Get Value() As Long
    Value = iValue
End Property

Public Property Let Value(New_Value As Long)
    If New_Value < iMin Or New_Value > iMax Then Exit Property
    If bMouseDown = True Then Exit Property
    iValue = New_Value
    Call DrawBar(Normal)
   
    PropertyChanged "Value"
End Property
Private Sub picBack_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button = 1 Then
   
'// vertical
If ePosition = Vertical Then
    If Y >= iY And Y <= iY + picBar.ScaleHeight And Button = 1 Then
        bDrag = True
        bMouseDown = True
        Call DrawBar(down, False)
    Else
      If iLargeChange = 0 Then
        iY = Y
        If iY > picBack.ScaleHeight - (picBar.ScaleHeight / 2) Then iY = picBack.ScaleHeight - (picBar.ScaleHeight / 2)
        If iY < picBar.ScaleHeight / 2 Then iY = picBar.ScaleHeight / 2
        iY = iY - picBar.ScaleHeight / 2
      Else
        If Y > iY Then '// sumar
          Value = Value + LargeChange
        Else
          Value = Value - LargeChange
        End If
      End If
    End If
Else '// horizontal
    If X >= iY And X <= iY + picBar.ScaleWidth And Button = 1 Then
        bDrag = True
        bMouseDown = True
        Call DrawBar(down, False)
    Else
      If iLargeChange = 0 Then
        iY = X
        If iY > picBack.ScaleWidth - (picBar.ScaleWidth / 2) Then iY = picBack.ScaleWidth - (picBar.ScaleWidth / 2)
        If iY < picBar.ScaleWidth / 2 Then iY = picBar.ScaleWidth / 2
        iY = iY - picBar.ScaleWidth / 2
      Else
        If X > iY Then '// sumar
          Value = Value + LargeChange
        Else
          Value = Value - LargeChange
        End If
      End If
  End If
 
End If
 
    RaiseEvent MouseDown(Button, Shift, X, Y)
End If
End Sub


Private Sub picBack_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
  If bDrag Then  '// dragging
      '// vertical
      If ePosition = Vertical Then
        iY = Y

        If iY > picBack.ScaleHeight - (picBar.ScaleHeight / 2) Then iY = picBack.ScaleHeight - (picBar.ScaleHeight / 2)
       
        If iY < picBar.ScaleHeight / 2 Then iY = picBar.ScaleHeight / 2

        iY = iY - picBar.ScaleHeight / 2
      '// horizontal
      Else
        iY = X
       
        If iY > picBack.Width - (picBar.Width / 2) Then iY = picBack.Width - (picBar.Width / 2)

        If iY < picBar.Width / 2 Then iY = picBar.Width / 2
               
        iY = iY - picBar.Width / 2
       
      End If
        Call CalcValue
        Call DrawBar(down, False)
       
        RaiseEvent Change(iValue)
       
  Else
    '// mouse over
    If ePosition = Vertical Then
          If bMouseOver = False Then
            bMouseOver = True
            Call DrawBar(Over, False)
            OverTimer.Enabled = True
          End If
    Else
          If bMouseOver = False Then
            bMouseOver = True
            Call DrawBar(Over, False)
            OverTimer.Enabled = True
          End If
    End If
  End If
   
    RaiseEvent MouseMove(Button, Shift, X, Y)
 
End Sub

Private Sub picBack_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
  If bDrag = False Then
      Call CalcValue
      RaiseEvent Change(iValue)
  End If
      bMouseDown = False
      Call DrawBar(Normal)
      bDrag = False
  RaiseEvent MouseUp(Button, Shift, X, Y)
End Sub


Private Sub UserControl_Initialize()
    If iMax = 0 Then iMax = 100
    Call DrawBar(Normal)
End Sub

Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
    picBack.Picture = PropBag.ReadProperty("Pict")
End Sub