EMAIL CON OUTLOOK

Dim olapp As Object
Dim oitem As Object
Set olapp = CreateObject("Outlook.Application")
Set oitem = olapp.CreateItem(0)
With oitem
   .Subject = "TITULO"
   .To = " gtryonp@afphorizonte.com.pe"
   .Body = "Mensaje de la carta"
   .Send
End With

DESHABILITAR OPCION DE MENU BOTON DERECHO

Private Declare Function LockWindowUpdate Lib "user32" (ByVal hwndLock As Long) As Long
Private Sub mnuOne_Click()
Text1.Text = "Se seleccionó el Menú Uno"
End Sub
Private Sub mnuTwo_Click()
Text1.Text = "Se seleccionó el Menú Dos"
End Sub

Private Sub Text1_MouseDown(Button As Integer, Shift As Integer,X As Single, Y As Single)
If Button = vbRightButton Then
' Evitar el texto gris bloqueando las actualizaciones
LockWindowUpdate Text1.hWnd
' Un textos "disabled" no saca menú contextual
Text1.Enabled = False
' Dar tiempo a la línea anterior a ejecutarse
DoEvents
' Sacar nuestro propio menú contextual
PopupMenu mnuPopup
' Poner Enable el control de nuevo
Text1.Enabled = True
' Desbloquear las actualizaciones
LockWindowUpdate 0&
End If
End Sub

MP3 & MULTITHREADING CON VB
'Copia la DLL en el directorio Windows\system\
Type PlayRecord
FileName As String
SeekAtStart As Long
Owner As Long
Result As Long
End Type

Declare Sub mp3gettime Lib "MP3.DLL" (DATA As PlayRecord, total As Double, perframe As Double)
Declare Sub mp3play Lib "MP3.DLL" (DATA As PlayRecord)
Declare Sub mp3stop Lib "MP3.DLL" ()
Declare Sub mp3seek Lib "MP3.DLL" (position As Integer)
Dim PR as PlayRecord
PR.FileName="c:\mp3\...."
Call mp3play(PR)
El código del form de ejemplo y de los módulos BAS:
'El formulario (frmPlayer.frm)
Option Explicit
Private Total As Double
Private PerFrame As Double
Private ProgressTop As Integer
Private ProgressValue As Integer
Private Playing As Boolean
'Gestiona las acciones sobre los controles
Private Sub botones_Click(Index As Integer)
Select Case Index
Case 0
PlayFile
SetControls False, True, True, True, False
Playing = True
Case 1, 2: MsgBox "Las funciones de Seek no las he implementado, eso os lo dejo a vosotros! :-)"
Case 3
StopFile
SetControls True, False, False, False, True
ProgressValue = 0
ProgressBar.AutoRedraw = True
ProgressBar.Cls
ProgressBar.AutoRedraw = False
LCD.Caption = InTime(Total)
Playing = False
Case 4
Dialog.ShowOpen
If Dialog.FileName = "" Then Exit Sub
Mp3Info.FileName = Dialog.FileName
Me.Caption = GetFileName(Dialog.FileName)
SetControls True, False, False, False, True
GetTime Total, PerFrame
ProgressTop = Fix((Total / PerFrame) / 16)
ProgressValue = 0
LCD.Caption = InTime(Total)
End Select
End Sub
'Secuencia de inicialización
Private Sub Form_Load()
HookForm Me
Mp3Info.Owner = Me.hWnd
Playing = False
SetControls False, False, False, False, True
End Sub
'Detener la interceptación de mensajes
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
unHookForm
End Sub
'No puedo salir si se esta reproduciendo
Private Sub Form_Unload(Cancel As Integer)
If Playing Then
StopFile
Playing = False
Cancel = 1
End If
End Sub
'Activa-Desactiva los botones
Private Sub SetControls(ByVal bPlay As Boolean, ByVal bRewind As Boolean, ByVal bForward As Boolean, ByVal bStop As Boolean, ByVal bEject As Boolean)
Botones(0).Enabled = bPlay
Botones(1).Enabled = bRewind
Botones(2).Enabled = bForward
Botones(3).Enabled = bStop
Botones(4).Enabled = bEject
End Sub
'Avanza la barra de progreso
Private Sub PushBar()
Dim Contador As Integer
ProgressBar.AutoRedraw = True
For Contador = 1 To Fix(ProgressBar.ScaleWidth / ProgressTop)
ProgressBar.Line (ProgressValue + Contador, 0)-Step(0, ProgressBar.ScaleHeight)
Next Contador
ProgressBar.AutoRedraw = False
ProgressValue = ProgressValue + Contador
End Sub
'Destino de los mensajes interceptados
Public Sub MessageReceived(ByVal Message As Long, ByVal wParam As Long, ByVal lParam As Long)
Select Case Message
Case FRAME_POS: LCD.Caption = InTime(Total - (PerFrame * wParam)): PushBar
Case APPLY_POS: Debug.Print Now, "Seek Process Done!"
Case PLAY_STOP: SetControls True, False, False, False, True: Playing = False
End Select
End Sub
'Muestra o esconde el *about*
Private Sub LCD_Click()
frmPlayer.Height = IIf(frmPlayer.Height = 3615, 1710, 3615)
End Sub

'El módulo: MP3Control.bas
Option Explicit
'Tipos definidos
Private Type PlayRecord
FileName As String
SeekAtStart As Long
Owner As Long
Result As Long
End Type
'Constantes Globales
Public Const FRAME_POS = &H2EE0
Public Const APPLY_POS = &H2EE1
Public Const PLAY_STOP = &H2EE2
'Variables Globales
Public Mp3Info As PlayRecord
'Funciones Importadas de "mp3.dll"
Private Declare Sub mp3gettime Lib "MP3.DLL" (DATA As PlayRecord, Total As Double, PerFrame As Double)
Private Declare Sub mp3play Lib "MP3.DLL" (DATA As PlayRecord)
Private Declare Sub mp3stop Lib "MP3.DLL" ()
Private Declare Sub mp3seek Lib "MP3.DLL" (Position As Integer)
'Funciones Importadas del API
Private Declare Function CreateThread Lib "kernel32" (ByVal Null1 As Long, ByVal Null2 As Long, ByVal StartAddress As Long, Parameter As Any, ByVal Null3 As Long, ThreadId As Long) As Long
'Reproduce el archivo
Private Sub StartSong()
mp3play Mp3Info
End Sub
'Reproduce el archivo en un thread independiente
Public Sub PlayFile()
Dim Identifier As Long
CreateThread 0, 0, AddressOf StartSong, 0, 0, Identifier
End Sub
'Obtiene la duración del archivo
Public Sub GetTime(Total As Double, PerFrame As Double)
mp3gettime Mp3Info, Total, PerFrame
End Sub
'Situa la reproducción en un punto concreto
Public Sub JumpTo(Frame As Integer)
mp3seek Frame
End Sub
'Para la reproducción
Public Sub StopFile()
mp3stop
End Sub
'Módulo: PrivateEye.bas
Option Explicit
'Variables globales en el módulo
Private Targe
tForm As Form
Private TargetHandle As Long
Private PrevWndProc As Long
Private Const GWL_WNDPROC = (-4&)
'Funciones Importadas del API
Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal MSG As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
'Aquí se reciben los mensajes
Private Function WndProc(ByVal hWnd As Long, ByVal uMSG As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
WndProc = CallWindowProc(PrevWndProc, hWnd, uMSG, wParam, lParam)
If Not TargetForm Is Nothing Then TargetForm.MessageReceived uMSG, wParam, lParam
End Function
'Inicia la interceptación de mensajes
Public Sub HookForm(ByVal Target As Form)
If Not TargetForm Is Nothing Then unHookForm
Set TargetForm = Target
TargetHandle = Target.hWnd
PrevWndProc = SetWindowLong(TargetHandle, GWL_WNDPROC, AddressOf WndProc)
End Sub
'Detiene la interceptación de mensajes
Public Sub unHookForm()
If TargetHandle <> 0 Then SetWindowLong TargetHandle, GWL_WNDPROC, PrevWndProc
End Sub
'Módulo: AuxFuncs.bas
Option Explicit
'Convierte milisegundos --> String hora
Public Function InTime(ByVal Milisecs As Double) As String
Dim Minutes As Integer, Seconds As Integer
Minutes = 0
Seconds = Fix(Milisecs / 1000)
While (Seconds > 59)
Seconds = Seconds - 60
Minutes = Minutes + 1
Wend
InTime = Format(Minutes, "00") & ":" & Format(Seconds, "00")
End Function
'Extrae el nombre de archivo de una ruta completa
Public Function GetFileName(ByVal Path As String) As String
Dim Contador As Integer
Contador = 1
While Mid(Path, Len(Path) - Contador, 1) <> "\"
Contador = Contador + 1
Wend
GetFileName = Mid(Path, Len(Path) - Contador + 1)
End Function

ESTRUCTURA DE UN MP3

Private Type MP3Info
Tag As String * 3
Title As String * 30
Artist As String * 30
Album As String * 30
Year As String * 4
Comment As String * 29
Track As Byte
Genre As Byte
End Type
Dim Info As MP3Info
Open sFileName For Binary As #1
lInfoStart = LOF(1) - 127
Get #1, lInfoStart, Info
Close #1

COMANDOS SQL

dump tran comercialyservicios2 with no_log
dbcc checktable(syslogs)
dbcc checkdb(comercialyservicios2)
SELECT * FROM FORMULAS WHERE BASE = 'A' OR (BASE = 'B' AND NOMBRE NOT IN (SELECT NOMBRE FROM FORMULAS WHERE BASE = 'A'));

SECCION DE TRUCOS PARA VB DE MICROSOFT

http://www.microsoft.com/spain/support/trucos/default.asp

Fade de una imagen

' To change the colors, simply click on the picture boxes on the top. This demonstration was coded By Heian
' This is the same code used to fade the picture box in Mindworks Fader 1.0 For this you will need a CommonDialog box and 4 picture boxes. Picture1 is for the fade itself, Picture2 is color 1 Picture3 is color 2, and Picture 4 is so that you can change the width of picture1 Set everything to Scalemode 3 and All the picture boxes to AutoRedraw = true
Option Explicit
' The RGB Combined Type
Private Type RGBComb
Red As Long
Green As Long
Blue As Long
End Type
' I use this type to define the backcolors of the pictures with another sub I have in this code. It's a little easier when using the common dialog control to change the colors. If you were using sliders or scroll bars, simply use the values of the scrollbars to change the colors of R G and B like Blue1 = Hscroll1.Value: Red1 = HScroll2.Value
Dim Col1 As RGBComb
Dim Col2 As RGBComb
Private Sub Form_Load()
Picture2.BackColor = 0
Picture3.BackColor = 0
End Sub
Private Sub Form_Resize()
On Error Resume Next
Picture4.Width = Me.ScaleWidth - 5
If Picture1.Width > Picture4.Width Then
Picture1.Width = Picture4.Width
End If
End Sub
Private Sub Picture1_Click()
On Error Resume Next
Dim Col1R, Col1G, Col1B, Col2R, Col2G, Col2B
Dim CDiffRed, CDiffGreen, CDiffBlue
Dim CFadeRed, CFadeGreen, CFadeBlue
Dim Fade As Double
' ^ All the variables needed for the calculation of the fade. Col1/2 is Colors one and two. Col1/2/rgb is going to be used as the RGB Values of the colors CDiff is the difference between the colors and CFade is the step it is going to use. Fade is the Variable Used in the actual fading
Col1R = Col1.Red
Col1G = Col1.Green
Col1B = Col1.Blue
Col2R = Col2.Red
Col2G = Col2.Green
Col2B = Col2.Blue
' ^ Starts preparing for all the calculations by setting all of the different variables in the RGB Combinations to thier own variables
CDiffRed = -(Col1R - Col2R)
CDiffGreen = -(Col1G - Col2G)
CDiffBlue = -(Col1B - Col2B)
' ^ Calculates the difference betwen the colors for fading
CFadeRed = CDiffRed / Picture1.ScaleWidth
CFadeGreen = CDiffGreen / Picture1.ScaleWidth
CFadeBlue = CDiffBlue / Picture1.ScaleWidth
' ^ Calculates the step variable for the fading of the colors
For Fade = 0 To Picture1.ScaleWidth
Picture1.Line (Fade, 0)-(Fade, Picture1.ScaleHeight) , RGB(Col1R, Col1G, Col1B)
' ^ Draws a Vertical line the color of the current fade
Col1R = Col1R + CFadeRed
Col1G = Col1G + CFadeGreen
Col1B = Col1B + CFadeBlue
' ^ Boosts or lowers the red green and blue falues for the next pass Goes on to the next color
Next Fade
End Sub
Private Sub Picture2_Click()
' Shows the common dialog color
CommonDialog1.ShowColor
' Sets the picture's color to the selected color
Picture2.BackColor = CommonDialog1.Color
Col1 = GetRGBFromLong(Picture2.BackColor)
End Sub
Private Sub Picture3_Click()
' Same as Picture 2
CommonDialog1.ShowColor
Picture3.BackColor = CommonDialog1.Color
Col2 = GetRGBFromLong(Picture3.BackColor)
End Sub
' Gets the RGB And stores it in the RGB Combined type
Private Function GetRGBFromLong(ColorLong As Double) As RGBComb
' Temporary values
Dim tmpred As Long
Dim tmpgreen As Long
Dim tmpblue As Long
tmpblue = Int(ColorLong / 65536)
tmpgreen = Int((ColorLong - (65536 * tmpblue)) / 256)
tmpred = ColorLong - (65536 * tmpblue + 256 * tmpgreen)
' Sets the Values to what they are (Red Green and Blue)
If tmpred > 256 Then tmpred = 256
If tmpgreen > 256 Then tmpgreen = 256
If tmpblue > 256 Then tmpblue = 256
' Error trapping before it become an error
GetRGBFromLong.Red = tmpred
GetRGBFromLong.Green = tmpgreen
GetRGBFromLong.Blue = tmpblue
End Function
Private Sub Picture4_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Picture4.Cls
Picture4.Line (0, 0)-(X, Picture4.ScaleHeight), vbBlue, BF
Picture1.Width = X
End Sub
Private Sub Picture4_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button = 1 Then
If X <= Picture4.ScaleWidth And X > 0 Then
Picture4.Cls
Picture4.Line (0, 0)-(X, Picture4.ScaleHeight), vbBlue, BF
Picture1.Width = X + 4
End If
End If
End Sub

Usar el marcador telefonico

Private Declare Function tapiRequestMakeCall& Lib "TAPI32.DLL" (ByVal DestAddress&, ByVal AppName$, ByVal CalledParty$, ByVal Comment$)
Private Sub Command1_Click()
Dim ValDev&, Numero$, NombreProg$, Quien$
Numero = "123-4567"
NombreProg = "Mi Programa"
Quien = "Pepe"
ValDev = tapiRequestMakeCall(Numero, NombreProg,Quien,"")
End Sub

Scroll de texto multinlinea desde codigo

Declaramos la función del API a emplear :
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Integer, ByVal lParam As Long) As Long
Private Const EM_LINESCROLL = &HB6
Parámetros :
wParam : Número de columnas a desplazar. Si es positivo se mueve el texto a la izda. y si es negativo a la dcha.
lParam : Número de líneas a desplazar. Si es positivo el texto se mueve hacia arriba y si es negativo hacia abajo.
Por ejemplo para movernos 5 líneas:
dim res as long
res = SendMessage(TextBox1.hwnd, EM_LINESCROLL, 0, 5&)
Nota :
SendMessage devuelve True si el textbox es multilinea y False si no lo es.
Para mover el texto verticalmente no hace falta que el textbox tenga una barra de desplazamiento vertical, sólo que el texto se más largo de lo que cabe en el control.
Para mover el texto horizontalmente sí hace falta que exista una barra de desplazamiento horizontal.

Control redimensionable

Cualquier control que tenga un Hwnd puede hacerse "redimensionable", es decir que cuando esté en ejecución se pueda cambiar el tamaño, para ello hay que usar una serie de llamadas del API.
Veamos las declaraciones del API, así como un procedimiento genérico para hacerlo redimensionable.
Este procedimiento espera un parámetro que será el control al que se le quiere dar esa característica, en el procedimiento he puesto una rutina de detección de errores por si el control que se le pasa no soporta esta característica.
'Declaraciones del API para 32 bits
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private 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
Const GWL_STYLE = (-16)
Const WS_THICKFRAME = &H40000
Const WS_CHILD = &H40000000
Const SWP_DRAWFRAME = &H20
Const SWP_NOMOVE = &H2
Const SWP_NOSIZE = &H1
Const SWP_NOZORDER = &H4
Private Sub Dimensionable(ByVal elControl As Control)
Dim Style As Long
'Por si el control pasado no se puede redimensionar
On Local Error Resume Next
Style = GetWindowLong(elControl.hWnd, GWL_STYLE)
Style = Style Or WS_THICKFRAME
Style = SetWindowLong(elControl.hWnd, GWL_STYLE, Style)
Style = SetWindowPos(elControl.hWnd, Me.hWnd, 0, 0, 0, 0, SWP_NOZORDER Or SWP_NOSIZE Or SWP_NOMOVE Or SWP_DRAWFRAME)
Err = 0
On Local Error GoTo 0
end Sub
'Para usarlo, se haría así:
Private Sub Form_Load()
Dimensionable Picture1
Dimensionable Text1
End Sub

Conexión de acceso telefonico a redes

Dim res As Long
res = Shell("rundll32.exe rnaui.dll,RnaDial " & "MiConexión", 1)

Meter/quitar datos en "mis documentos"

Declaramos :
Private Declare Sub SHAddToRecentDocs Lib "Shell32" (ByVal lFlags As Long, ByVal lPv As String)
Para añadir un documento :
SHAddToRecentDocs 2, "c:\MiDir\MiFichero.txt"
Y para vaciar la carpeta :
SHAddToRecentDocs 2, vbNullString