BestKill ☠ » vb6

[VB6] Creare delle Ballon Tips

TheTrigger — Sun, 14 Jun 2009 17:56:11 +0000

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58

Option Explicit
Private Const APP_SYSTRAY_ID = 999
Private Const NOTIFYICON_VERSION = &H3

Private Const NIF_MESSAGE = &H1
Private Const NIF_ICON = &H2
Private Const NIF_TIP = &H4
Private Const NIF_STATE = &H8
Private Const NIF_INFO = &H10

Private Const NIM_ADD = &H0
Private Const NIM_MODIFY = &H1
Private Const NIM_DELETE = &H2
Private Const NIM_SETFOCUS = &H3
Private Const NIM_SETVERSION = &H4
Private Const NIM_VERSION = &H5

Private Const NIS_HIDDEN = &H1
Private Const NIS_SHAREDICON = &H2

'icone
Private Const NIIF_NONE = &H0
Private Const NIIF_INFO = &H1
Private Const NIIF_WARNING = &H2
Private Const NIIF_ERROR = &H3
Private Const NIIF_GUID = &H5
Private Const NIIF_ICON_MASK = &HF
Private Const NIIF_NOSOUND = &H10
Private Const WM_USER = &H400
Private Const NIN_BALLOONSHOW = (WM_USER + 2)
Private Const NIN_BALLOONHIDE = (WM_USER + 3)
Private Const NIN_BALLOONTIMEOUT = (WM_USER + 4)
Private Const NIN_BALLOONUSERCLICK = (WM_USER + 5)
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(7) As Byte
End Type

Private Type NOTIFYICONDATA
cbSize As Long
hWnd As Long
uID As Long
uFlags As Long
uCallbackMessage As Long
hIcon As Long
szTip As String * 128
dwState As Long
dwStateMask As Long
szInfo As String * 256
uTimeoutAndVersion As Long
szInfoTitle As String * 64
dwInfoFlags As Long
guidItem As GUID
End Type

Private Declare Function Shell_NotifyIcon Lib "shell32.dll" Alias "Shell_NotifyIconA" (ByVal dwMessage As Long, lpData As NOTIFYICONDATA) As Long

Form in VB

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94

Private Sub Form_Load()

Text1.Text = "Esempio di balloon nella Tray " & _
"Notification Area. Prova " & _
"Ballon Tips"

Command1.Caption = "Inserisci Icona nella Systray"
Command2.Caption = "Visualizza Balloon Tip"
Command2.Enabled = False
Option1(1).Value = True

End Sub

Private Sub Form_Unload(Cancel As Integer)

ShellTrayRemove

End Sub

Private Sub Command1_Click()

Call ShellTrayAdd
Command2.Enabled = True

End Sub

Private Sub Command2_Click()

ShellTrayModifyTip GetSelectedOptionIndex()

End Sub

Private Sub ShellTrayAdd()

Dim nid As NOTIFYICONDATA

With nid

.cbSize = Len(nid)
.hWnd = Form1.hWnd
.uID = APP_SYSTRAY_ID
.uFlags = NIF_MESSAGE Or NIF_ICON Or NIF_TIP
.dwState = NIS_SHAREDICON
.hIcon = Form1.Icon
.szTip = "Visualizza il Balloon Tip!" & Chr(0)
.uTimeoutAndVersion = NOTIFYICON_VERSION

End With

Call Shell_NotifyIcon(NIM_ADD, nid)

Call Shell_NotifyIcon(NIM_SETVERSION, nid)

End Sub

Private Sub ShellTrayRemove()

Dim nid As NOTIFYICONDATA

With nid
.cbSize = Len(nid)
.hWnd = Form1.hWnd
.uID = APP_SYSTRAY_ID
End With

Call Shell_NotifyIcon(NIM_DELETE, nid)

End Sub

Private Sub ShellTrayModifyTip(nIconIndex As Long)

Dim nid As NOTIFYICONDATA

With nid
.cbSize = Len(nid)
.hWnd = Form1.hWnd
.uID = APP_SYSTRAY_ID
.uFlags = NIF_INFO
.dwInfoFlags = nIconIndex
.szInfoTitle = "Visualizza il Balloon Tip!" & Chr(0)
.szInfo = Text1.Text
End With

Call Shell_NotifyIcon(NIM_MODIFY, nid)

End Sub

Private Function GetSelectedOptionIndex() As Long

GetSelectedOptionIndex = Option1(0).Value * 0 Or _
Option1(1).Value * -1 Or _
Option1(2).Value * -2 Or _
Option1(3).Value * -3
End Function

Post from: BestKill ☠

[VB6] Controllare connessione internet

TheTrigger — Sun, 14 Jun 2009 17:34:24 +0000

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20

Private Declare Function InternetGetConnectedState Lib "wininet.dll" (ByRef _
lpSFlags As Long, ByVal dwReserved As Long) As Long
Const INTERNET_CONNECTION_MODEM = 1
Const INTERNET_CONNECTION_LAN = 2
Const INTERNET_CONNECTION_PROXY = 4
Const INTERNET_CONNECTION_MODEM_BUSY = 8
Dim flags As Long

Private Sub Form_Load()

If InternetGetConnectedState(flags, 0) = 0 Then
MsgBox "Non sei connesso ad internet"
ElseIf flags = INTERNET_CONNECTION_MODEM Then
MsgBox "Sei connesso con il Modem" ' connessione attiva via modem
ElseIf flags = INTERNET_CONNECTION_LAN Then
MsgBox "Sei connesso con LAN" ' connessione attiva via LAN
ElseIf flags = INTERNET_CONNECTION_PROXY Then
MsgBox "Sei connesso via Proxy" ' connessione attiva via proxy
End If
End Sub

Post from: BestKill ☠

[VB6] Simulazione tasto Windows (Start)

TheTrigger — Sun, 14 Jun 2009 17:27:12 +0000

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15

Private Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
Private Const KEYEVENTF_KEYUP = &H2

Private Sub Form_Load()
' simula la pressione dei tasti Ctrl-Esc
keybd_event vbKeyControl, 0, 0, 0
keybd_event vbKeyEscape, 0, 0, 0
DoEvents

' simula il rilascio dei due tasti
keybd_event vbKeyControl, 0, KEYEVENTF_KEYUP, 0
keybd_event vbKeyEscape, 0, KEYEVENTF_KEYUP, 0
DoEvents

End Sub

Post from: BestKill ☠

[VB6] Calcolare l’anno bisestile

TheTrigger — Sun, 17 May 2009 17:21:37 +0000

Calcolo dell’anno bisestile.

1
2
3

Dim year As Integer
year = 2004
Label1 = DateSerial(year, 2, 29) <> DateSerial(year, 3, 1)

Restituisce un valore VERO o FALSO

Post from: BestKill ☠

[VB6] Convesione basi

TheTrigger — Sun, 17 May 2009 17:21:16 +0000

Ecco come fare conversioni da Dec > Bin > Dec > Hex e calcoli di radianti e gradi.

Nel programma basta usare:

1
2
3
4
5
6
7
8
9
10

Bin(Num_decimale)
BinToDec(Num_bin)
Hex(Num_decimale)
'Hex questo non è presente nel modulo, ma è già integrato in vb6.

Radians(valore_gradi)
Degrees(valore_radiante)

'Ovviamente tutti letti da una variabile o un campo..
variabile = Bin(34)

Crea un Modulo:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54

Option Explicit

' Conversione da bdecimale a binario
Function Bin(ByVal value As Long) As String
Dim result As String, exponent As Integer
result = String$(32, "0")
Do
If value And Power2(exponent) Then
Mid$(result, 32 - exponent, 1) = "1"
value = value Xor Power2(exponent)
End If
exponent = exponent + 1
Loop While value
Bin = Mid$(result, 33 - exponent)
End Function

' Convesrione da binario a decimale.
Function BinToDec(value As String) As Long
Dim result As Long, i As Integer, exponent As Integer
For i = Len(value) To 1 Step -1
Select Case Asc(Mid$(value, i, 1))
Case 48 ' "0", niente.
Case 49 ' "1", aggiungere la corrispondente potenza di 2
result = result + Power2(exponent)
Case Else
Err.Raise 5
End Select
exponent = exponent + 1
Next
BinToDec = result
End Function

' conversione gradi > radiante.
Function Radians(Degrees As Double) As Double
Radians = Degrees / 57.29577951
End Function

' Convertire radiante in gradi.
Function Degrees(Radians As Double) As Double
Degrees = Radians * 57.29577951
End Function

'Private function
Private Function Power2(ByVal exponent As Long) As Long
Static result(0 To 31) As Long, i As Integer
If result(0) = 0 Then
result(0) = 1
For i = 1 To 30
result(i) = result(i - 1) * 2
Next
result(31) = &H80000000
End If
Power2 = result(exponent)
End Function

Post from: BestKill ☠

Catturare lo schermo senza il tasto Stamp

TheTrigger — Sun, 17 May 2009 17:21:02 +0000

Può essere necessarrio catturare l’immagine di schermo senze dover emulare la pressione del tasto STAMP

Chiamato con:

Set Picture1.Picture = ImmagineSchermo()

Private Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
Private Const KEYEVENTF_KEYUP = &H2

Public Function ImmagineSchermo(Optional ActiveWindow As Boolean) As Picture
Dim Picture As StdPicture
Set Picture = Clipboard.GetData(vbCFBitmap)
If ActiveWindow Then
keybd_event vbKeyMenu, 0, 0, 0
End If
keybd_event vbKeySnapshot, 0, 0, 0
DoEvents
keybd_event vbKeySnapshot, 0, KEYEVENTF_KEYUP, 0
If ActiveWindow Then
keybd_event vbKeyMenu, 0, KEYEVENTF_KEYUP, 0
End If
Set ImmagineSchermo = Clipboard.GetData(vbCFBitmap)
Clipboard.SetData Picture, vbCFBitmap
End Function

Post from: BestKill ☠

Centrare un form nello schermo

TheTrigger — Sun, 17 May 2009 17:20:59 +0000

Per centrare lo schermo:

Form1.Move(Screen.width-form1.width)\2,(screen.height-form1.height)\2

Se cè la necessità di impedire lo sostamento del form nel menù a fianco settare ‘Moveable’ su FALSE

Post from: BestKill ☠

Form sempre in primo piano – Always on top

TheTrigger — Sun, 17 May 2009 17:20:49 +0000

Inserisci un modulo nel progetto e copia questo nel modulo:

Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Public Const HWND_TOPMOST = -1
Public Const HWND_NOTOPMOST = -2
Public Const SWP_NOACTIVATE = &H10
Public Const SWP_NOMOVE = &H2
Public Const SWP_NOSIZE = &H1

E questo nella form

Dim lRetVal As Long

Private Sub Form_Load()
lRetVal = SetWindowPos(Form1.hwnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOACTIVATE Or SWP_NOSIZE Or SWP_NOMOVE)
End Sub

Post from: BestKill ☠

Realizzare un keylogger

TheTrigger — Sun, 17 May 2009 17:20:10 +0000

Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
'Per sapere il tempo di ripetizione usate questa API
Private Declare Function SystemParamsLong Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, lpvParam As Long, ByVal fuWinIni As Long) As Long
'Costante che indichera che a noi interessa la velocità di ripetizione e non il tempo di ritardo
Const SPI_GETKEYBOARDSPEED = 10

Private Sub Timer1_Timer()
If GetAsyncKeyState(vbKeyF1) Then  ' azione
MsgBox "F1 è stato premuto!"
End If
End Sub

Regolare l’intervallo del Timer(serve per la lettura del tasto) a seconda delle esigenze, sul 80-90 và più che bene.

Post from: BestKill ☠

[VB6] funzione Sleep

TheTrigger — Sun, 17 May 2009 17:19:49 +0000

1
2
3
4
5
6
7

Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Private Sub Form_Load()
Sleep 1000
MsgBox ":D"

End Sub

Post from: BestKill ☠

Riprodurre suoni midi, wave, mp3, avi, mpeg

TheTrigger — Sun, 17 May 2009 17:16:49 +0000

Componenti > Controlli > Microsoft Multimedia Controll

'Mpeg e MP3:
Private Sub Form_Load()
With MMControl1
.Notify = False
.Wait = True
.Visible = False ' se non si vuole far visualizzare il controllo
.DeviceType = "MPEGvideo"
.TimeFormat = mciFormatMilliseconds
.FileName = "C:\CartellaSuoni\Test.Mpeg" ' o Test.Mp3
.Command = "seek"
.Command = "Open" 'apri
.Command = "Play" 'auto start
End With
End Sub

'File Wave:
Private Sub Form_Load()
With MMControl1
.Notify = False
.Wait = True
.Visible = False
.DeviceType = "WaveAudio"
.TimeFormat = mciFormatMilliseconds
.FileName = "C:\CartellaSuoni\Test.wav"
.Command = "seek"
.Command = "Open"
.Command = "Play"
End With
End Sub

'Midi:
Private Sub Form_Load()
With MMControl1
.Notify = False
.Wait = True
.Visible = False
.DeviceType = "Sequencer"
.TimeFormat = mciFormatMilliseconds
.FileName = "C:\CartellaSuoni\Test.mid"
.Command = "seek"
.Command = "Open"
.Command = "Play"
End With
End Sub

'File AVIVideo:
Private Sub Form_Load()
With MMControl1
.Notify = False
.Wait = True
.Visible = False
.DeviceType = "AVIVideo"
.TimeFormat = mciFormatMilliseconds
.FileName = "C:\CartellaSuoni\Test.avi"
.Command = "seek"
.Command = "Open"
.Command = "Play"
End With
End Sub

Post from: BestKill ☠

[VB6] Titolo scorrevole

TheTrigger — Sun, 17 May 2009 17:16:40 +0000

Ecco come far scorrere il titolo del form, può essere usato anche per texbox e label…

Richiamato con:

1	Call TitleScroll(Form1)

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26

Sub TitleScroll(frm As Form)
Dim X As Integer
Dim current As Variant
Dim Y As String
Y = frm.Caption
frm.Caption = ""
frm.Show
For X = 0 To Len(Y)
If X = 0 Then
frm.Caption = ""
current = Timer
Do While Timer - current < 0.1
DoEvents
Loop
GoTo done
Else:
End If
frm.Caption = Left(Y, X)
current = Timer
Do While Timer - current < 0.05
DoEvents
Loop
done:
Next X

End Sub

Post from: BestKill ☠

[VB6] Textbox numerica

TheTrigger — Sun, 17 May 2009 17:16:37 +0000

Private Sub Text1_KeyPress(KeyAscii As Integer) If KeyAscii < Asc("0") Or KeyAscii > Asc("9") Then KeyAscii = 0 Beep End If End Sub Post from: BestKill ☠

Post from: BestKill ☠

[VB6] Split leggere le righe

TheTrigger — Sun, 17 May 2009 17:16:37 +0000

In questo modo il contenuto presente su ‘txt_MultiLine’ viene splittato su altri textbox.

Dim SettagiLetti as string
Dim Settaggi() as string

Private Sub Command1_Click()
SettaggiLetti = txt_MultiLine.text 'cambo testo multilinee con una frase/parola per riga
Settaggi() = Split(SettaggiLetti, vbCrLf)

text1.text = Settaggi(0)
text2.text = Settaggi(1)
text3.text = Settaggi(2)
text4.text = Settaggi(3)
End Sub

Post from: BestKill ☠