randomcodenum
کد:
Private Sub Command1_Click()
Dim A As String
Dim B As String
Dim C As String
Dim D As String
Dim E As String
Dim F As String
Dim G As String
Dim H As String
Dim I As String
Dim J As String
A = Random
B = Random
C = Random
D = Random
E = Random
F = Random
G = Random
H = Random
I = Random
J = Random
Text1 = A + B + C + D + E + F + G + H + I + J
End Sub
Function RandomNum() As Integer
RandomNum = Int((9 - 1 + 1) * Rnd + 1)
End Function
Function RandomChar() As String
Dim Char As Integer
Char = Int((26 - 1 + 1) * Rnd + 1)
If Char = 1 Then RandomChar = "A": Exit Function
If Char = 2 Then RandomChar = "B": Exit Function
If Char = 3 Then RandomChar = "C": Exit Function
If Char = 4 Then RandomChar = "D": Exit Function
If Char = 5 Then RandomChar = "E": Exit Function
If Char = 6 Then RandomChar = "F": Exit Function
If Char = 7 Then RandomChar = "G": Exit Function
If Char = 8 Then RandomChar = "H": Exit Function
If Char = 9 Then RandomChar = "I": Exit Function
If Char = 10 Then RandomChar = "J": Exit Function
If Char = 11 Then RandomChar = "K": Exit Function
If Char = 12 Then RandomChar = "L": Exit Function
If Char = 13 Then RandomChar = "M": Exit Function
If Char = 14 Then RandomChar = "N": Exit Function
If Char = 15 Then RandomChar = "O": Exit Function
If Char = 16 Then RandomChar = "P": Exit Function
If Char = 17 Then RandomChar = "Q": Exit Function
If Char = 18 Then RandomChar = "R": Exit Function
If Char = 19 Then RandomChar = "S": Exit Function
If Char = 20 Then RandomChar = "T": Exit Function
If Char = 21 Then RandomChar = "U": Exit Function
If Char = 22 Then RandomChar = "V": Exit Function
If Char = 23 Then RandomChar = "W": Exit Function
If Char = 24 Then RandomChar = "X": Exit Function
If Char = 25 Then RandomChar = "Y": Exit Function
If Char = 26 Then RandomChar = "Z": Exit Function
End Function
Function Random() As Variant
Dim Randm As Integer
Randm = Int((3 - 1 + 1) * Rnd + 1)
If Randm = 1 Then
Random = RandomNum
Else
Random = RandomChar
End If
End Function
Puts Pics into Menus
کد:
Private Type MENUITEMINFO
cbSize As Long
fMask As Long
fType As Long
fState As Long
wid As Long
hSubMenu As Long
hbmpChecked As Long
hbmpUnchecked As Long
dwItemData As Long
dwTypeData As Long
cch As Long
End Type
Private Declare Function GetMenu Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetSubMenu Lib "user32" (ByVal hMenu As Long, ByVal nPos As Long) As Long
Private Declare Function SetMenuItemInfo Lib "user32" Alias "SetMenuItemInfoA" (ByVal hMenu As Long, ByVal un As Long, ByVal bypos As Long, lpcMenuItemInfo As MENUITEMINFO) As Long
Private Const MF_BITMAP = &H4&
Private Const MFT_BITMAP = MF_BITMAP
Private Const MIIM_TYPE = &H10
Private Sub Form_Load()
' Set the menu bitmaps.
SetMenuBitmap Me, Array(0, 0), imgExit.Picture 'Picture Areas in menu
SetMenuBitmap Me, Array(1, 0), imgDelete.Picture
SetMenuBitmap Me, Array(1, 1, 0), imgStop.Picture
SetMenuBitmap Me, Array(1, 1, 1), imgYield.Picture
SetMenuBitmap Me, Array(1, 1, 2), imgCaution.Picture
End Sub
' Put a bitmap in a menu item.
Public Sub SetMenuBitmap(ByVal frm As Form, ByVal item_numbers As Variant, ByVal pic As Picture)
Dim menu_handle As Long
Dim i As Integer
Dim menu_info As MENUITEMINFO
' Get the menu handle.
menu_handle = GetMenu(frm.hwnd)
For i = LBound(item_numbers) To UBound(item_numbers) - 1
menu_handle = GetSubMenu(menu_handle, item_numbers(i))
Next i
With menu_info
.cbSize = Len(menu_info)
.fMask = MIIM_TYPE
.fType = MFT_BITMAP
.dwTypeData = pic
End With
SetMenuItemInfo menu_handle, item_numbers(UBound(item_numbers)), True, menu_info
End Sub
playsound
کد:
Public Declare Function sndPlaySound Lib "winmm" Alias "sndPlaySoundA" (ByVal lpszSoundName As String, ByVal uFlags As Long) As Long
Public Sub PlaySound(strFileName As String)
sndPlaySound strFileName, 1
End Sub
Open File
کد:
Open Dialogs.fileName For Input As #1
Do While Not EOF(1)
Line Input #1, Temp
text1.Text = text1.Text + vbCrLf & Temp
DoEvents
Loop
Close #1
no spaces
کد:
' add a text box and place this in it. Rename text1 to the name
' of the text box.
Dim Length As String
For L = 1 To text1.MaxLength
Length = Length + " "
If text1 = "" Or text1 = Length Then
MsgBox "You can't have spaces in this textbox!"
'Exit Sub
End If
Next L
move a form without title bar
کد:
Private OldX As Integer
Private OldY As Integer
Private DragMode As Boolean
Dim MoveMe As Boolean
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
Me.Left = Me.Left + (X - OldX)
Me.Top = Me.Top + (Y - OldY)
End If
End Sub
Private Sub Form_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
Me.Left = Me.Left + (X - OldX)
Me.Top = Me.Top + (Y - OldY)
MoveMe = False
End Sub
Midi Play
کد:
Declare Function mciSendString Lib "winmm.dll" Alias "mciSendStringA" (ByVal lpstrCommand As String, ByVal lpstrReturnString As String, ByVal uReturnLength As Long, ByVal hwndCallback As Long) As Long
Private Sub Form_Load()
result = mciSendString("open c:\windows\canyon.mid type sequencer alias canyon", 0&, 0, 0)
result = mciSendString("play canyon", 0&, 0, 0)
End Sub
Private Sub Form_Unload()
result = mciSendString("close all", 0&, 0, 0)
End Sub