Como crear un grupo de programas:
Muy útil para crear instalaciones por ejemplo:
Añadir un textbox y hacerlo oculto.
Una vez oculto, escribir estas líneas sustituyendo "Nombre del Grupo" por que que se desea crear,
y que lo colocamos en Inicio -> Programas.
Private Sub Command1_Click()
Text1.LinkTopic = "Progman|Progman"
Text1.LinkMode = 2
Text1.LinkExecute "[CreateGroup(" + "Nombre del Grupo" + "]"
End Sub
--------------------------------------------------------------------------------
Vaciar la carpeta de Documentos de Windows:
Inicie un nuevo proyecto y añada el siguiente código:
Private Declare Function SHAddToRecentDocs Lib "Shell32"
(ByVal lFlags As Long, ByVal lPv As Long) As Long
Private Sub Form_Load()
SHAddToRecentDocs 0, 0
End Sub
--------------------------------------------------------------------------------
Abrir la ventana de Propiedades de agregar o quitar aplicaciones:
Añada el siguiente código:
Private Sub Command1_Click()
X = Shell("Rundll32.exe shell32.dll,Control_RunDLL appwiz.cpl @0"
End Sub
--------------------------------------------------------------------------------
Uso de Random:
La función Rnd o Random posee la virtud de obtener números aleatorios entre 0 y 1:
El único inconveniente a la hora de usar Rnd, es que hay que inicializarlo, en otro caso,
el resultado de la función Rnd, será siempre el mismo dentro de un determinado ordenador.
Por ejemplo, el código:
Private Sub Form_Load()
Dim Num As Double
Num = Rnd
MsgBox Num
End Sub
Nos daría como resultado siempre el mismo número.
Para solucionar este problema, debemos escribir la sentencia Randomize antes de llamar
a la función Rnd. De esta manera, la función Rnd actuará correctamente.
El código quedaría así:
Private Sub Form_Load()
Dim Num As Double
Randomize
Num = Rnd
MsgBox Num
End Sub
--------------------------------------------------------------------------------
Calcular la etiqueta o label de un disco duro:
Hallar la etiqueta o label del mismo disco duro:
Escribir el siguiente código:
Private Declare Function GetVolumeInformation& Lib "kernel32" Alias
"GetVolumeInformationA" (ByVal lpRootPathName As String,
ByVal pVolumeNameBuffer As String, ByVal nVolumeNameSize As Long,
lpVolumeSerialNumber As Long, lpMaximumComponentLength As Long,
lpFileSystemFlags As Long, ByVal lpFileSystemNameBuffer As String,
ByVal nFileSystemNameSize As Long)
Private Sub Form_Load()
Dim cad1 As String * 256
Dim cad2 As String * 256
Dim numSerie As Long
Dim longitud As Long
Dim flag As Long
unidad = "D:\"
Call GetVolumeInformation(unidad, cad1, 256, numSerie, longitud,
flag, cad2, 256)
MsgBox "Label de la unidad " & unidad & " = " & cad1
End Sub
--------------------------------------------------------------------------------
Imprimir un RichTextBox tal y como se ve:
Imprimir un RichTextBox con su formato original.
Private Sub Command1_Click()
On Error GoTo ErrorDeImpresion
Printer.Print ""
RichTextBox1.SelPrint Printer.hDC
Printer.EndDoc
Exit Sub
ErrorDeImpresion:
Exit Sub
End Sub
Otra forma:
En el Formulario [Form1 por defecto] :
Private Sub Form_Load()
Dim LineWidth As Long
Me.Caption = "Rich Text Box Ejemplo de Impresion"
Command1.Move 10, 10, 600, 380
Command1.Caption = "&Imprimir"
RichTextBox1.SelFontName = "Verdana, Tahoma, Arial"
RichTextBox1.SelFontSize = 10
LineWidth = WYSIWYG_RTF(RichTextBox1, 1440, 1440)
Me.Width = LineWidth + 200
End Sub
Private Sub Form_Resize()
RichTextBox1.Move 100, 500, Me.ScaleWidth - 200, Me.ScaleHeight - 600
End Sub
Private Sub Command1_Click()
PrintRTF RichTextBox1, 1440, 1440, 1440, 1440
End Sub
Crear un módulo y escribir:
Private Type Rect
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Type CharRange
cpMin As Long
cpMax As Long
End Type
Private Type FormatRange
hdc As Long
hdcTarget As Long
rc As Rect
rcPage As Rect
chrg As CharRange
End Type
Private Const WM_USER As Long = &H400
Private Const EM_FORMATRANGE As Long = WM_USER + 57
Private Const EM_SETTARGETDEVICE As Long = WM_USER + 72
Private Const PHYSICALOFFSETX As Long = 112
Private Const PHYSICALOFFSETY As Long = 113
Private Declare Function GetDeviceCaps Lib "gdi32" ( _
ByVal hdc As Long, ByVal nIndex As Long) As Long
Private Declare Function SendMessage Lib "USER32" Alias "SendMessageA" _
(ByVal hWnd As Long, ByVal msg As Long, ByVal wp As Long, lp As Any) As Long
Private Declare Function CreateDC Lib "gdi32" Alias "CreateDCA" _
(ByVal lpDriverName As String, ByVal lpDeviceName As String, _
ByVal lpOutput As Long, ByVal lpInitData As Long) As Long
Public Function WYSIWYG_RTF(RTF As RichTextBox, LeftMarginWidth As Long, _
RightMarginWidth As Long) As Long
Dim LeftOffset As Long, LeftMargin As Long, RightMargin As Long
Dim LineWidth As Long
Dim PrinterhDC As Long
Dim r As Long
Printer.Print Space(1)
Printer.ScaleMode = vbTwips
LeftOffset = Printer.ScaleGetDeviceCaps(Printer.hdc, _
PHYSICALOFFSETX), vbPixels, vbTwips)
LeftMargin = LeftMarginWidth - LeftOffset
RightMargin = (Printer.Width - RightMarginWidth) - LeftOffset
LineWidth = RightMargin - LeftMargin
PrinterhDC = CreateDC(Printer.DriverName, Printer.DeviceName, 0, 0)
r = SendMessage(RTF.hWnd, EM_SETTARGETDEVICE, PrinterhDC, _
ByVal LineWidth)
Printer.KillDoc
WYSIWYG_RTF = LineWidth
End Function
Public Sub PrintRTF(RTF As RichTextBox, LeftMarginWidth As Long, _
TopMarginHeight, RightMarginWidth, BottomMarginHeight)
Dim LeftOffset As Long, TopOffset As Long
Dim LeftMargin As Long, TopMargin As Long
Dim RightMargin As Long, BottomMargin As Long
Dim fr As FormatRange
Dim rcDrawTo As Rect
Dim rcPage As Rect
Dim TextLength As Long
Dim NextCharPosition As Long
Dim r As Long
Printer.Print Space(1)
Printer.ScaleMode = vbTwips
LeftOffset = Printer.ScaleGetDeviceCaps(Printer.hdc, _
PHYSICALOFFSETX), vbPixels, vbTwips)
TopOffset = Printer.ScaleY(GetDeviceCaps(Printer.hdc, _
PHYSICALOFFSETY), vbPixels, vbTwips)
LeftMargin = LeftMarginWidth - LeftOffset
TopMargin = TopMarginHeight - TopOffset
RightMargin = (Printer.Width - RightMarginWidth) - LeftOffset
BottomMargin = (Printer.Height - BottomMarginHeight) - TopOffset
rcPage.Left = 0
rcPage.Top = 0
rcPage.Right = Printer.ScaleWidth
rcPage.Bottom = Printer.ScaleHeight
rcDrawTo.Left = LeftMargin
rcDrawTo.Top = TopMargin
rcDrawTo.Right = RightMargin
rcDrawTo.Bottom = BottomMargin
fr.hdc = Printer.hdc
fr.hdcTarget = Printer.hdc
fr.rc = rcDrawTo
fr.rcPage = rcPage
fr.chrg.cpMin = 0
fr.chrg.cpMax = -1
TextLength = Len(RTF.Text)
Do
NextCharPosition = SendMessage(RTF.hWnd, EM_FORMATRANGE, True, fr)
If NextCharPosition >= TextLength Then Exit Do
fr.chrg.cpMin = NextCharPosition
Printer.NewPage
Printer.Print Space(1)
fr.hDC = Printer.hDC
fr.hDCTarget = Printer.hDC
Loop
Printer.EndDoc
r = SendMessage(RTF.hWnd, EM_FORMATRANGE, False, ByVal CLng(0))
End Sub
--------------------------------------------------------------------------------
Como obtener el directorio desde donde estamos ejecutando nuestro programa:
Escribir el siguiente código:
Private Sub Form_Load()
Dim Directorio as String
ChDir App.Path
ChDrive App.Path
Directorio = App.Path
If Len(Directorio) > 3 Then
Directorio = Directorio & "\"
End If
End Sub
--------------------------------------------------------------------------------
Determinar si un fichero existe o no:
Escriba el siguiente código: (una de tanta maneras aparte de Dir$())
Private Sub Form_Load()
On Error GoTo Fallo
x = GetAttr("C:\Autoexec.bat"
MsgBox "El fichero existe."
Exit Sub
Fallo:
MsgBox "El fichero no existe."
End Sub
--------------------------------------------------------------------------------
Capturar la pantalla entera o la ventana activa:
Añadir dos botones y escribir el siguiente código:
Private Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte,
ByVal bScan As Byte, ByVal dwFlags As Long,
ByVal dwExtraInfo As Long)
Private Sub Command1_Click()
'Captura la ventana activa
keybd_event 44, 0, 0&, 0&
End Sub
Private Sub Command2_Click()
'Captura toda la pantalla
keybd_event 44, 1, 0&, 0&
End Sub
--------------------------------------------------------------------------------
Salvar el contenido de un TextBox a un fichero en disco:
Añada el siguiente código:
Private Sub Command1_Click()
Dim canalLibre As Integer
'Obtenemos un canal libre que nos dará
'el sistema oparativo para poder operar
canalLibre = FreeFile
'Abrimos el fichero en el canal dado
Open "C:\fichero.txt" For Output As #canalLibre
'Escribimos el contenido del TextBox al fichero
Print #canalLibre, Text1
Close #canalLibre
End Sub
Nuevo
Para abrir:
Código:
Dim foo As Integer
foo = FreeFile
Open "C:\Archivo.txt" For Input As #foo
Text1.Text = Input(LOF(foo), #foo)
Close #foo
Para guardar:
Código:
Dim foo As Integer
foo = FreeFile
Open "C:\Archivo.txt" For Output As #foo
Print #foo, Text1.Text
Close #foo
dialogos:
Ese es para Abrir
Código:
Dim strOpen As String
CommonDialog1.ShowOpen
strOpen = CommonDialog1.FileName
Text1.LoadFile strOpen
Text1.LoadFile strClose
Ese para guardar
Código:
Dim strNewFile As String
CommonDialog1.ShowSave
strNewFile = CommonDialog1.FileName
Text1.SaveFile strNewFile
vean la 2 parte http://taringa.net/posts/info/2273271/Crear-en-Visual-Basic-Manual-Part-2.html
vean la 3 parte http://taringa.net/posts/info/2273315/Crear-en-Visual-Basic-Manual-Part-3.html