***///***BlackSpion***/// Un Espacio Cibernético

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.ScaleX(GetDeviceCaps(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.ScaleX(GetDeviceCaps(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