[Amin_Mansouri]

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