Source Codes y Proyectos de Visual Basic

[Vassily]

Aqui les dejo varios codigos fuente de programas hechos en Visual Basic que he recopilado

Nota: Los codigos no son de mi propiedad

Colores

Código:

Option Explicit


Private Sub Form_Load()
    txtCaja.Top = 0
End Sub

Private Sub optArriba_Click()
    txtCaja.Top = 0
End Sub

Private Sub optAbajo_Click()
    txtCaja.Top = frmColores0.ScaleHeight - txtCaja.Height
End Sub

Private Sub optAzul_Click()
    txtCaja.BackColor = vbBlue
End Sub

Private Sub optRojo_Click()
    txtCaja.BackColor = vbRed
End Sub

Private Sub optVerde_Click()
    txtCaja.BackColor = vbGreen
End Sub

Private Sub optAmarillo_Click()
    txtCaja.BackColor = vbYellow
End Sub

[Vassily]

Código:

Option Explicit

Private Sub cmdDiv_Click()
   txtResult.Text = Val(txtOper1.Text) / Val(txtOper2.Text)
   lblOp.Caption = "/"
End Sub

Private Sub cmdProd_Click()
   txtResult.Text = Val(txtOper1.Text) * Val(txtOper2.Text)
   lblOp.Caption = "*"
End Sub

Private Sub cmdResta_Click()
   txtResult.Text = Val(txtOper1.Text) - Val(txtOper2.Text)
   lblOp.Caption = "-"
End Sub

Private Sub cmdSuma_Click()
   txtResult.Text = Val(txtOper1.Text) + Val(txtOper2.Text)
   lblOp.Caption = "+"
End Sub

[Vassily]

Código:

Option Explicit

Private Sub cmbSalir_Click()
   Beep
   End
End Sub

Private Sub mnuFileExit_Click()
   End
End Sub

Private Sub vsbTemp_Change()
    txtCent.Text = vsbTemp.Value
    txtFahr.Text = 32 + 1.8 * vsbTemp.Value
End Sub

[Vassily]

Código:

Option Explicit
Public Brojo, Bverde, Bazul As Integer
Public Frojo, Fverde, Fazul As Integer

Private Sub cmdSalir_Click()
   End
End Sub

Private Sub Form_Load()
   Brojo = 0
   Bverde = 0
   Bazul = 0
   Frojo = 255
   Fverde = 255
   Fazul = 255
   lblCuadro.BackColor = RGB(Brojo, Bverde, Bazul)
   lblCuadro.ForeColor = RGB(Frojo, Fverde, Fazul)
End Sub

Private Sub hsbColor_Change(Index As Integer)
   If optColor(0).Value = True Then
      lblCuadro.BackColor = RGB(hsbColor(0).Value, hsbColor(1).Value, hsbColor(2).Value)
      Dim i As Integer
      For i = 0 To 2
         txtColor(i).Text = hsbColor(i).Value
      Next i
   Else
      lblCuadro.ForeColor = RGB(hsbColor(0).Value, hsbColor(1).Value, hsbColor(2).Value)
      For i = 0 To 2
         txtColor(i).Text = hsbColor(i).Value
      Next i
   End If
End Sub

Private Sub optColor_Click(Index As Integer)
   If Index = 0 Then  'Se pasa a cambiar el fondo
      Frojo = hsbColor(0).Value
      Fverde = hsbColor(1).Value
      Fazul = hsbColor(2).Value
      hsbColor(0).Value = Brojo
      hsbColor(1).Value = Bverde
      hsbColor(2).Value = Bazul
   Else               'Se pasa a cambiar el texto
      Brojo = hsbColor(0).Value
      Bverde = hsbColor(1).Value
      Bazul = hsbColor(2).Value
      hsbColor(0).Value = Frojo
      hsbColor(1).Value = Fverde
      hsbColor(2).Value = Fazul
    End If
End Sub

[Vassily]

Código:

Dim X, Xa, t, frec, Pi As Single
Dim Ti, Ind As Integer

Private Sub cmdExit_Click()
    End
End Sub

Private Sub cmdStart_Click()
    Dim rotulo As String
    Timer1.Enabled = Not Timer1.Enabled
    rotulo = cmdStart.Caption
    If rotulo = "Stop Motion" Then
        cmdStart.Caption = "Start Motion"
    Else
        cmdStart.Caption = "Stop Motion"
    End If
End Sub

Private Sub Form_Load()
    Xa = 2000
    txtAmplitud.Text = Xa
    cmdStart.Caption = "Stop Motion"
    frec = 1
    txtFrec.Text = 1
    Pi = 3.141592654  ' Pi=4*Atn(1)
    Ti = 20  ' Son milisegundos, 50 imagenes por segundo
    Timer1.Interval = Ti
    pctBox.DrawWidth = 4
    lblBloque.Visible = False
    pctBox.Scale (-2500, 100)-(2500, -100)
End Sub

Private Sub hsbFrec_Change()
    frec = hsbFrec.Value / 10
    txtFrec.Text = frec
End Sub

Private Sub optMovil_Click(Index As Integer)
    Ind = Index
    pctBox.DrawWidth = 1
    If Ind = 0 Then
         pctBox.DrawWidth = 4
    End If
    If Ind = 3 Then
        lblBloque.Visible = True
    Else
        lblBloque.Visible = False
    End If
End Sub

Private Sub pctBox_DragDrop(Source As Control, X As Single, Y As Single)
    Xa = X
    txtAmplitud.Text = Xa
    lblBloque.Left = X - lblBloque.Width / 2
End Sub

Private Sub Timer1_Timer()
    X = Xa * Sin(2 * Pi * frec * t)
    pctBox.Cls
    Select Case Ind
        Case 0
            pctBox.PSet (X, 0), vbBlue
        Case 1
            pctBox.Line (X - 200, 20)-(X + 200, -20), vbRed, B
        Case 2
            pctBox.Circle (X, 0), 200, vbGreen
        Case 3
            lblBloque.Left = X - lblBloque.Width / 2
    End Select
    t = t + Ti / 1000
End Sub

Private Sub txtAmplitud_KeyPress(KeyAscii As Integer)
    If KeyAscii = 13 Then
        Xa = txtAmplitud.Text
    End If
End Sub

[Vassily]

Código:

Option Explicit
Dim vx, vy, t, altura, anchura, xpos As Double

Private Sub cmdDispara_Click()
    vx = Val(txtV.Text) * Cos(Val(txtAngulo.Text) * 3.141592 / 180#)
    vy = Val(txtV.Text) * Sin(Val(txtAngulo.Text) * 3.141592 / 180#)
    Timer1.Interval = 50
    Timer1.Enabled = True
    t = 0
End Sub

Private Sub cmdEnd_Click()
    End
End Sub

Private Sub Form_Load()
    pctBox.Scale (0, 100)-(200, 0)
    t = 0
    txtV.Text = 35
    txtAngulo.Text = 50
    pctBox.Circle (190, 10), 10, vbRed
    pctBox.Line (100, 0)-(120, 50), vbRed, BF
    altura = 50
    vsbAltura.Value = 100 - altura
    anchura = 20
    hsbAnchura.Value = anchura
    xpos = 100
    hsbXpos.Value = xpos
End Sub

Private Sub hsbXpos_Change()
    xpos = hsbXpos.Value
    pctBox.Cls
    pctBox.Circle (190, 10), 10, vbRed
    pctBox.Line (xpos, 0)-(xpos + anchura, altura), vbRed, BF
End Sub


Private Sub Timer1_Timer()
    Dim x, y As Double
    Dim distancia As Double
    pctBox.Cls
    pctBox.Circle (190, 10), 10, vbRed
    pctBox.Line (xpos, 0)-(xpos + anchura, altura), vbRed, BF
    t = t + 0.1
    x = vx * t
    y = vy * t - 9.81 / 2# * t * t
    pctBox.DrawWidth = 3
    pctBox.PSet (x, y), vbRed
    pctBox.DrawWidth = 1
    If x > xpos Then
    If y > 0 Then
    If x < xpos + anchura Then
        If y < altura Then
            MsgBox ("Hemos tocado el bloque")
            Timer1.Enabled = False
        End If
    End If
    End If
    End If
    distancia = Sqr((x - 190) ^ 2 + (y - 10) ^ 2)
    If distancia < 10 Then
        Beep
        MsgBox ("YOU WIN")
        Timer1.Enabled = False
    End If

End Sub

Private Sub vsbAltura_Change()
    altura = 100 - vsbAltura.Value
    pctBox.Cls
    pctBox.Circle (190, 10), 10, vbRed
    pctBox.Line (xpos, 0)-(xpos + anchura, altura), vbRed, BF
End Sub

Private Sub hsbAnchura_Change()
    anchura = hsbAnchura.Value
    pctBox.Cls
    pctBox.Circle (190, 10), 10, vbRed
    pctBox.Line (xpos, 0)-(xpos + anchura, altura), vbRed, BF
End Sub

[Vassily]

Código:

Option Explicit

Private Sub cmdDeleteAll_Click()
    lstBox.Clear
    txtBox.SetFocus
End Sub

Private Sub cmdDeleteSel_Click()
    Dim i As Integer
    Do While i <= lstBox.ListCount - 1
        If lstBox.Selected(i) Then
            lstBox.RemoveItem (i)
            i = i - 1
        End If
        i = i + 1
    Loop
    txtBox.SetFocus
End Sub

Private Sub cmdPoblarLista_Click()
    lstBox.Clear
    lstBox.List(0) = "uno"
    lstBox.List(1) = "dos"
    lstBox.List(2) = "tres"
    lstBox.List(3) = "cuatro"
    lstBox.List(4) = "cinco"
    lstBox.List(5) = "seis"
    lstBox.List(6) = "siete"
    lstBox.List(7) = "ocho"
    lstBox.List(8) = "nueve"
    lstBox.List(9) = "diez"
    txtBox.SetFocus
End Sub

Private Sub cmdSalir_Click()
    End
End Sub

Private Sub cmdInvertSel_Click()
    Dim i As Integer
    For i = 0 To lstBox.ListCount - 1
        lstBox.Selected(i) = Not lstBox.Selected(i)
    Next
    txtBox.SetFocus
End Sub

Private Sub cmdSelectAll_Click()
    Dim i As Integer
    For i = 0 To lstBox.ListCount - 1
        lstBox.Selected(i) = True
    Next
    txtBox.SetFocus
End Sub

Private Sub cmdDeselectAll_Click()
    Dim i As Integer
    For i = 0 To lstBox.ListCount - 1
        lstBox.Selected(i) = False
    Next
    txtBox.SetFocus
End Sub

Private Sub Form_Activate()
    txtBox.SetFocus
End Sub

Private Sub lstBox_GotFocus()
    txtBox.SetFocus
End Sub

Private Sub txtBox_KeyPress(KeyAscii As Integer)
    If KeyAscii = 13 Then
       lstBox.AddItem (txtBox.Text)
       txtBox.Text = ""
    End If
End Sub

[Vassily]

Código:

Option Explicit
Dim m_lfVX As Double
Dim m_lSentidoX As Long
Dim m_lfVY As Double
Dim m_lSentidoY As Long
Dim m_lfX As Double
Dim m_lfY As Double
Dim m_lfTimeStep As Double
'Dim m_lfVel As Double
Dim m_lfMaxX As Double
Dim m_lfMaxY As Double
Dim m_lfMinX As Double
Dim m_lfMinY As Double
Dim m_lfWall As Double
Dim m_bChoqueXMax As Boolean
Dim m_bChoqueXMin As Boolean
Dim m_bChoqueYMax As Boolean
Dim m_bChoqueYMin As Boolean
Const ROJO = &HFF&
Const VERDE = &HFF00&

Private Sub chkUp_Click()
'Movimiento hacia arriba
    If (chkUp.Value = Checked) Then
        chkDown.Value = Unchecked
        m_lSentidoY = 1
    Else
        m_lSentidoY = 0
    End If
End Sub
Private Sub chkDown_Click()
'Movimiento hacia abajo
    If (chkDown.Value = Checked) Then
        chkUp.Value = Unchecked
        m_lSentidoY = -1
    Else
        m_lSentidoY = 0
    End If
End Sub
Private Sub chkLeft_Click()
'Movimiento hacia la izda.
    If (chkLeft.Value = Checked) Then
        chkRight.Value = Unchecked
        m_lSentidoX = -1
    Else
        m_lSentidoX = 0
    End If
End Sub
Private Sub chkRight_Click()
'Movimiento hacia la dcha.
    If (chkRight.Value = Checked) Then
        chkLeft.Value = Unchecked
        m_lSentidoX = 1
    Else
        m_lSentidoX = 0
    End If
End Sub
Private Sub ResetMotion()
    If (chkUp.Value = Checked) Then
        chkUp.Value = Unchecked
        Call chkUp_Click
    End If
    If (chkDown.Value = Checked) Then
        chkDown.Value = Unchecked
        Call chkDown_Click
    End If
    If (chkRight.Value = Checked) Then
        chkRight.Value = Unchecked
        Call chkRight_Click
    End If
    If (chkLeft.Value = Checked) Then
        chkLeft.Value = Unchecked
        Call chkLeft_Click
    End If
End Sub

Private Sub cmdEnd_Click()
    End
End Sub

Private Sub cmdReset_Click()
    Call Init
End Sub

Private Sub cmdStart_Click()
    If (cmdStart.Caption = "Start") Then
        Timer1.Enabled = True
        cmdStart.Caption = "Stop"
    Else
        Timer1.Enabled = False
        cmdStart.Caption = "Start"
    End If
End Sub

Private Sub Form_Initialize()
    Call Init
End Sub

Private Sub Init()
    m_lfMaxX = pctPecera.Width / 2
    m_lfMinX = -pctPecera.Width / 2
    m_lfMaxY = pctPecera.Height / 2
    m_lfMinY = -pctPecera.Height / 2
    m_lfWall = 290#
    pctPecera.Scale (m_lfMinX, m_lfMaxY)-(m_lfMaxX, m_lfMinY)
    Call InitLines
    Call InitPos
    hsbVelX.Value = 100
    vsbVelY.Value = 100
    Timer1.Enabled = False
    cmdStart.Caption = "Start"
    'Tiempo de integracion en segundos
    m_lfTimeStep = 0.05
    Timer1.Interval = Int(m_lfTimeStep * 1000#)
    Call DrawCar
    Call ResetMotion
End Sub

Private Sub InitLines()
    Dim m_lfHeight As Double
    Dim m_lfWidth As Double
    Dim m_lfLeft As Double
    Dim m_lfRight As Double
    Dim m_lfUp As Double
    Dim m_lfDown As Double
    m_lfHeight = 0
    m_lfWidth = 2000
    m_lfLeft = -m_lfWidth
    m_lfRight = m_lfWidth
    m_lfDown = -m_lfHeight
    m_lfUp = m_lfHeight
End Sub

Private Sub InitPos()
    m_lfX = 0
    m_lfY = 1000
    Call DetectarParedes
End Sub

Private Sub Timer1_Timer()
    Dim lfVelX, lfVelY As Double
    lfVelX = hsbVelX.Value
    lfVelY = vsbVelY.Value
    m_lfVX = lfVelX * m_lSentidoX
    m_lfVY = lfVelY * m_lSentidoY
    m_lfX = m_lfX + m_lfTimeStep * m_lfVX
    m_lfY = m_lfY + m_lfTimeStep * m_lfVY
    Call DrawCar
    Call DetectarParedes
End Sub

Private Sub DetectarParedes()
    If (m_lfX >= m_lfMaxX - m_lfWall) Then
        m_bChoqueXMax = True
        m_lSentidoX = 0
    Else
        m_bChoqueXMax = False
    End If
   
    If (m_lfX <= m_lfMinX) Then
        m_bChoqueXMin = True
        m_lSentidoX = 0
    Else
        m_bChoqueXMin = False
    End If
   
    If (m_lfY >= m_lfMaxY) Then
        m_bChoqueYMax = True
        m_lSentidoY = 0
    Else
        m_bChoqueYMax = False
    End If
   
    If (m_lfY <= m_lfMinY + m_lfWall) Then
        m_bChoqueYMin = True
        m_lSentidoY = 0
    Else
        m_bChoqueYMin = False
    End If
   
    If ((m_bChoqueXMin = True) Or (m_bChoqueXMax = True) Or (m_bChoqueYMin = True) Or (m_bChoqueYMax = True)) Then
        lblCrash.BackColor = &HFF&
    Else
        lblCrash.BackColor = &HFF00&
    End If
End Sub

Private Sub DrawCar()
    shpPez.Left = m_lfX
    shpPez.Top = m_lfY
End Sub

[Vassily]

[code]Option Explicit
Dim xv As Single, yv As Single
Dim started As Boolean, finished As Boolean

Private Sub dibujarPoligon o()
    Dim i As Integer
    Dim x1 As Single, y1 As Single, x2 As Single, y2 As Single
    ' se borra el contenido de la picture box
    pctBox.Cls
    ' se dibujan los lados del pol

[Vassily]

[code]Option Explicit
Dim xv As Integer, yv As Integer, xn As Integer, yx As Integer
Dim x1(20) As Integer, y1(20) As Integer
Dim i As Integer
Dim reading As Boolean  ' se están leyendo los v

[Vassily]

Código:

Option Explicit
Dim h, dh As Integer

Private Sub cmdExit_Click()
    End
End Sub

Private Sub cmdStart_Click()
    If cmdStart.Caption = "Start" Then
        Timer1.Enabled = True
        cmdStart.Caption = "Stop"
    Else
        Timer1.Enabled = False
        cmdStart.Caption = "Start"
    End If
End Sub

Private Sub Form_Load()
    pctBox.Scale (0, 5000)-(1000, 0)
    lblFluido.Height = 5200
    h = 500: dh = 10
    hsbCaudal.Value = dh
    lblFluido.Top = h
    txtH.Text = h
    Timer1.Enabled = False
    Timer1.Interval = 20
End Sub

Private Sub hsbCaudal_Change()
    dh = hsbCaudal.Value
End Sub

Private Sub Timer1_Timer()
    If optLLenar.Value = True Then
        h = h + dh
    Else
        h = h - dh
    End If
    lblFluido.Top = h
    txtH.Text = h
End Sub

[Vassily]

[code]Option Explicit
Dim A1x, A1y, B1x, B1y As Integer
Dim A2x, A2y, B2x, B2y As Integer
Dim hc, e As Integer
Dim h1, h2, h12 As Integer
Dim qe1, qs1, qe2, qs2, q12, qpaso As Integer

Sub deposito()
    pctBox.DrawWid th = 2
    ' dibujo del primer depósito
    pctBox.Line (A1x, A1y)-(A1x, B1y) ' vertical
    pctBox.Line (B1x, A1y)-(B1x, A1y + hc - e) ' vert inferior
    pctBox.Line (B1x, A1y + hc + e)-(B1x, B1y) ' vert superior
    pctBox.Line (A1x, A1y)-(B1x, A1y) ' horizontal inferior
    pctBox.Line (A1x, B1y)-(B1x, B1y) ' horizontal superior
    ' dibujo del segundo depósito
    pctBox.Line (B2x, A2y)-(B2x, B2y) 'vertical
    pctBox.Line (A2x, A2y)-(A2x, A1y + hc - e) 'vert inferior
    pctBox.Line (A2x, A1y + hc + e)-(A2x, B2y) 'vert superior
    pctBox.Line (A2x, A2y)-(B2x, A2y) 'horizontal inferior
    pctBox.Line (A2x, B2y)-(B2x, B2y) 'horizontal superior
    ' dibujo de conducto de conexión
    pctBox.Line (B1x, A1y + hc - e)-(A2x, A1y + hc - e)
    pctBox.Line (B1x, A1y + hc + e)-(A2x, A1y + hc + e)
End Sub

Sub fluido(ByVal h11 As Integer, ByVal h22 As Integer)
    ' dibujo del fondo de los depósitos
    pctBox.Line (A1x, A1y)-(B1x, B1y), vbWhite, BF
    pctBox.Line (A2x, A2y)-(B2x, B2y), vbWhite, BF
    pctBox.Line (B1x, A1y + hc - e)-(A2x, A1y + hc + e), vbWhite, BF
    ' dibujo del fluido
    pctBox.Line (A1x, A1y)-(B1x, A1y + h11), vbRed, BF
    pctBox.Line (A2x, A2y)-(B2x, A2y + h22), vbRed, BF
    If (h1 > hc Or h22 > hc + h12) And hsbPaso.Value > 0 Then
        pctBox.Line (B1x, A1y + hc - e)-(A2x, A1y + hc + e), vbRed, BF
    End If
End Sub

Private Sub cmdSalir_Click()
    End
End Sub

Private Sub Form_Load()
    ' definición geometr

[Vassily]

Código:

Option Explicit
Dim Fichero, Ficheropath As String
Private Sub Form_Load()
    Form1.Caption = "Untitled - MiNotepad"
    txtBox.Left = 0
    txtBox.Top = 0
    txtBox.FontName = "Fixedsys"
    Fichero = ""
    Ficheropath = ""
End Sub
Private Sub Form_Resize()
    txtBox.Height = Form1.Height
    txtBox.Width = Form1.Width
End Sub

Private Sub mnuEditSetBgndColor_Click()
    cdlNpad.ShowColor
    txtBox.BackColor = cdlNpad.Color
End Sub

Private Sub mnuEditSetfont_Click()
    ' para mostrar las fuentes de pantall y los efectos especiales
    cdlNpad.Flags = cdlCFScreenFonts + cdlCFEffects
    ' la font previa aperecerá preseleccionada
    cdlNpad.FontName = txtBox.FontName
    cdlNpad.ShowFont
    ' se pasan a la textBox las opciones elegidas por el usuario
    txtBox.FontName = cdlNpad.FontName
    txtBox.FontSize = cdlNpad.FontSize
    txtBox.FontBold = cdlNpad.FontBold
    txtBox.FontItalic = cdlNpad.FontItalic
    txtBox.FontStrikethru = cdlNpad.FontStrikethru
    txtBox.FontUnderline = cdlNpad.FontUnderline
    txtBox.ForeColor = cdlNpad.Color
End Sub

Private Sub mnuFileExit_Click()
    End
End Sub
Private Sub mnuFileNew_Click()
    txtBox.Text = ""
    Fichero = ""
    Ficheropath = ""
    Form1.Caption = "Untitled - MiNotepad"
End Sub
Private Sub mnuFileOpen_Click()
    cdlNpad.Filter = "texto (*.txt)|*.txt|todos (*.*)|*.*"
    cdlNpad.ShowOpen
    Fichero = cdlNpad.FileTitle
    Ficheropath = cdlNpad.FileName
    Open Ficheropath For Input As #1
    txtBox.Text = Input(LOF(1), #1)
    Close #1
    Form1.Caption = Fichero & " - MiNotepad"
End Sub
Private Sub mnuFileSave_Click()
    ' si el fichero no ha sido guardado previamente
    If Fichero = "" Then
        Call mnuFileSaveAs_Click
    Else ' si ya ha sido guardado
        Open Ficheropath For Output As #1
        Print #1, txtBox.Text
        Close #1
    End If
End Sub

Private Sub mnuFileSaveAs_Click()
    cdlNpad.DefaultExt = "txt"
    cdlNpad.ShowSave
    Fichero = cdlNpad.FileTitle
    Ficheropath = cdlNpad.FileName
    Open Ficheropath For Output As #1
    Print #1, txtBox.Text
    Close #1
    Form1.Caption = Fichero & " - MiNotepad"
End Sub

[Vassily]

Me faltaron codigos fuente y no los podia subir debido a que se necesitaban imagenes u otro archivo para que funcionara el Programa

Aqui les dejo todos los Ejercicios resueltos en conjunto con su Source Code

Para ver este enlace Registrate o Inicia Sesion

Ejercicios Vb

La clave del rar es

Para ver este enlace Registrate o Inicia Sesion

www.portalhack er.net

[sircuit]

El link murió.