giu 14
Posted by TheTrigger on giugno 14th, 2009
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 |
Read the rest of this entry »
mag 17
Posted by TheTrigger on maggio 17th, 2009
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
mag 17
Posted by TheTrigger on maggio 17th, 2009
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 |
mag 17
Posted by TheTrigger on maggio 17th, 2009
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
mag 17
Posted by TheTrigger on maggio 17th, 2009
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
mag 17
Posted by TheTrigger on maggio 17th, 2009
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
mag 17
Posted by TheTrigger on maggio 17th, 2009
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.
mag 17
Posted by TheTrigger on maggio 17th, 2009
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
mag 17
Posted by TheTrigger on maggio 17th, 2009
Ecco come far scorrere il titolo del form, può essere usato anche per texbox e label…
Richiamato con:
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 |
mag 17
Posted by TheTrigger on maggio 17th, 2009
Private Sub Text1_KeyPress(KeyAscii As Integer)
If KeyAscii < Asc("0") Or KeyAscii > Asc("9") Then
KeyAscii = 0
Beep
End If
End Sub
mag 17
Posted by TheTrigger on maggio 17th, 2009
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
Recent Comments