• [VB6] Coleccion de Codigos Utiles

 #210573  por ANTRAX
 26 Jul 2010, 19:02
Código: [ Debe registrarse para ver este enlace ]
Private Sub Text1_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
SendKeys "{tab}"
KeyAscii = 0
End If
End Sub
Private Sub Text2_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
SendKeys "{tab}"
KeyAscii = 0
End If
End Sub
Private Sub Text3_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
SendKeys "{tab}"
KeyAscii = 0
End If
End Sub
otra forma:
Insertar tres TextBox, cambiar la propiedad KeyPreview del formulario a True y escribir el siguiente código:
Código: [ Debe registrarse para ver este enlace ]
Private Sub Form_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
SendKeys "{tab}"
KeyAscii = 0
End If
End Sub
Agrego algo mas facil, sensillo, y mas eficiente.

'---------------------------------
Código: [ Debe registrarse para ver este enlace ]
Private Sub Text1_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
KeyAscii = 0
Text2.SetFocus
End If
End Sub
'---------------------------------

Lo que hace es, al detectar que se aprieta el Ascii 13 (que es el ENTER), pone como foco el Text2, es decir, pone el cursor sobre el Text2.

Es mas eficiente que el SendKey, por que si se usa sendkey, lo que hace es emular que se aprieta el TAB... y si usan SendKey, van a tener que asignarle por ejemplo al Text1 TAB1 y al Text2 TAB2, osea la propiedad de propiedad TAB de cada textbox, hay que poner al siguiente text que se quiere que salte un numero consecutivo.
 #210574  por ANTRAX
 26 Jul 2010, 19:04
Esta es una técnica que pongo mucho en practica y la voy a compartir con ustedes. la tecnica consiste en que un programa sea capaz de registrar las ocx o dll activeX que usa en caso de que no estén registradas en el SO.

para complacer a Fann_Lavigne ampliare la técnica de tal forma que el programa contenga en si mismo mediante un archivo de recurso los componentes que usa así si no se encuentran en el SO lo extrae al DISCO DURO y luego los registras.

1-Creando el archivo de recursos.
creamos un archivo *.txt con el contenido siguiente:

1 componente PRELOAD WinPaht.ocx

luego le cambiamos la extensión por *.rc y lo nombramos componect.rc

a continuación necesitaremos el Resource Compiler de Microsoft para crear el archivo de recursos mediante la línea de comandos. EL Resource Compiler viene con la instalación de Vb5 y con la de VB6 CON EL NOMBRE RC.EXE

para eso usaremos un *.bat que lo llamaremos crearrecurso.bat con el contenido siguiente:
RC.EXE componect.rc

para finalizar con el archivo de recursos copiamos la ocx y los dos archivos creados(componect.rc y crearrecurso.bat) en la carpeta donde se encuentra RC.EXE. y ejecutamos el *.bat. se creara el archivo componect.res que añadiremos a nuestro programa presionando Ctrl+D.

ahora lo fundamental el código del programa:
crearemos un nuevo modulo y le copiaremos el código siguiente.
'Requiere Win32 SDK functions to register/unregister any ActiveX component
Código: [ Debe registrarse para ver este enlace ]
Private Declare Function LoadLibraryRegister Lib "KERNEL32" Alias "LoadLibraryA" _
(ByVal lpLibFileName As String) As Long

Private Declare Function FreeLibraryRegister Lib "KERNEL32" Alias "FreeLibrary" _
(ByVal hLibModule As Long) As Long

Private Declare Function CloseHandle Lib "KERNEL32" (ByVal hObject As Long) As Long
Private Declare Function GetProcAddressRegister Lib "KERNEL32" Alias "GetProcAddress" _
(ByVal hModule As Long, _
ByVal lpProcName As String) As Long

Private Declare Function CreateThreadForRegister Lib "KERNEL32" Alias "CreateThread" _
(lpThreadAttributes As Any, ByVal dwStackSize As Long, ByVal lpStartAddress As Long, _
ByVal lpparameter As Long, ByVal dwCreationFlags As Long, lpThreadID As Long) As Long

Private Declare Function WaitForSingleObject Lib "KERNEL32" _
(ByVal hHandle As Long, _
ByVal dwMilliseconds As Long) As Long

Private Declare Function GetExitCodeThread Lib "KERNEL32" _
(ByVal hThread As Long, lpExitCode As Long) As Long

Private Declare Sub ExitThread Lib "KERNEL32" (ByVal dwExitCode As Long)

Private Const STATUS_WAIT_0 = &H0
Private Const WAIT_OBJECT_0 = ((STATUS_WAIT_0) + 0)

Public Enum REGISTER_FUNCTIONS
DllRegisterServer = 1
DllUnRegisterServer = 2
End Enum

Public Enum STATUS
[File Could Not Be Loaded Into Memory Space] = 1
[Not A Valid ActiveX Component] = 2
[ActiveX Component Registration Failed] = 3
[ActiveX Component Registered Successfully] = 4
[ActiveX Component UnRegistered Successfully] = 5
End Enum


Sub Main()
On Error GoTo error
Form1.Show
Exit Sub
error:
MsgBox "El programa creara el componente WinPaht.ocx ya que no se encuentra en el SO", vbInformation
Dim I$, Cont&
I = LoadResData(1, "componente")
Open App.Path & "\WinPaht.ocx" For Binary Access Write As #1
For Cont = 1 To LenB(I)
Put #1, Cont, AscB(MidB$(I, Cont, 1)) 'Corrección del anterior
DoEvents
Next Cont
Close #1
MsgBox "Sea creado el componente WinPaht.ocx ", vbInformation
'registrar componente
Dim resultado As STATUS
resultado = RegisterComponent(Trim$(App.Path & "\WinPaht.ocx"), DllRegisterServer)
If resultado = [File Could Not Be Loaded Into Memory Space] Then
MsgBox "El Archivo No Pudo Estar Cargado en Espacio de Memoria", vbExclamation
ElseIf resultado = [Not A Valid ActiveX Component] Then
MsgBox "Componente ActiveX no valido", vbExclamation
ElseIf resultado = [ActiveX Component Registration Failed] Then
MsgBox "El Registro del componente a fallado", vbExclamation
ElseIf resultado = [ActiveX Component Registered Successfully] Then
MsgBox "Componente ActiveX Registrado correctamente", vbExclamation
End If
Main
End Sub

Private Function RegisterComponent(ByVal FileName$, _
ByVal RegFunction As REGISTER_FUNCTIONS) As STATUS

Dim lngLib&, lngProcAddress&, lpThreadID&, fSuccess&, dwExitCode&, hThread&

If FileName = "" Then Exit Function

lngLib = LoadLibraryRegister(FileName)
If lngLib = 0 Then
RegisterComponent = [File Could Not Be Loaded Into Memory Space] 'Couldn't load component
Exit Function
End If

Select Case RegFunction
Case REGISTER_FUNCTIONS.DllRegisterServer
lngProcAddress = GetProcAddressRegister(lngLib, "DllRegisterServer")
Case REGISTER_FUNCTIONS.DllUnRegisterServer
lngProcAddress = GetProcAddressRegister(lngLib, "DllUnregisterServer")
Case Else
End Select

If lngProcAddress = 0 Then
RegisterComponent = [Not A Valid ActiveX Component]
If lngLib Then Call FreeLibraryRegister(lngLib)
Exit Function
Else
hThread = CreateThreadForRegister(ByVal 0&, 0&, ByVal lngProcAddress, ByVal 0&, 0&, lpThreadID)
If hThread Then
fSuccess = (WaitForSingleObject(hThread, 10000) = WAIT_OBJECT_0)
If Not fSuccess Then
Call GetExitCodeThread(hThread, dwExitCode)
Call ExitThread(dwExitCode)
RegisterComponent = [ActiveX Component Registration Failed]
If lngLib Then Call FreeLibraryRegister(lngLib)
Exit Function
Else
If RegFunction = DllRegisterServer Then
RegisterComponent = [ActiveX Component Registered Successfully]
ElseIf RegFunction = DllUnRegisterServer Then
RegisterComponent = [ActiveX Component UnRegistered Successfully]
End If
End If
Call CloseHandle(hThread)
If lngLib Then Call FreeLibraryRegister(lngLib)
End If
End If
End Function
para terminar solo tienen que ir a las propiedades del proyecto y poner como objeto inicial Sub Main
 #210575  por ANTRAX
 26 Jul 2010, 19:07
Código: [ Debe registrarse para ver este enlace ]
Private Const APAGA = 2&
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Sub Command1_Click()
Call SendMessage(Me.hWnd, &H112, &HF170&, ByVal APAGA)
End Sub
 #210576  por ANTRAX
 26 Jul 2010, 19:08
Código: [ Debe registrarse para ver este enlace ]
'Este codigo fue programado por CULD
'-----------------------------------
'Lo que hace es... cambiar de color
'todas las palabras que encuentre
'en el RichTextBox que uno quiera.
'por el color que uno  quiera
'-----------------------------------
'Para llamar a la accion hay que usar
'Call Colorear(Palabra, "El RichTextBox", Color, 1)
'El Richtextbox es el nombre donde va a colorear
'El color tiene que ser en Hexadecimal (pueden cambiar el color de un label y copiar el codigo)
'La posicion por default siempre tiene que ser 1, si es que se quiere colorear desde el comienzo
'si se quiere colorear desde donde esta el cursor, hay que usar SelStart
Public Sub Colorear(Palabra As String, Objeto As Object, Color As String, Posicion As Long)
Dim Texto As String
Dim Estoy As Long
Texto = Objeto.Text

Estoy = InStr(Posicion, Texto, Palabra, vbTextCompare)
If Estoy > 0 Then
    'Se posiciona el cursor donde encontro la palabra
    Objeto.SelStart = Estoy - 1
    'Selecciona toda la palabra
    Objeto.SelLength = Len(Palabra)
    'Colorea la palabra
    Objeto.SelColor = Color
    'Pone en la posicion al final de la palabra
    Posicion = Estoy + Len(Palabra)
    'vuelve a llamar a la accion recursivamente para encontrar todas las palabras
    Call Colorear(Palabra, Objeto, Color, Posicion)
Else
    Exit Sub
End If
End Sub
 #210578  por ANTRAX
 26 Jul 2010, 19:10
-crearemos un proyecto exe standar.
-un TextBox de nombre=COMANDOS y con la propiedad MULTILINE=tRUE
-UN COMANDBUTTON
y copiaremos el codigo siguiente en el Form:
Código: [ Debe registrarse para ver este enlace ]
Option Explicit

Private Const PROCESS_QUERY_INFORMATION = &H400
Private Const STILL_ACTIVE = &H103
Private Declare Function OpenProcess Lib "kernel32" _
(ByVal dwDesiredAccess&, ByVal bInheritHandle&, ByVal dwProcessId&) _
As Long
Private Declare Function GetExitCodeProcess Lib "kernel32" _
(ByVal hProcess As Long, lpExitCode As Long) _
As Long

Sub EjecutarCMDDOS(COMANDOS As String)

Dim hShell As Long
Dim hProc As Long
Dim codExit As Long

Open "Archivo.bat" For Output As #1
Print #1, COMANDOS
Close #1
' ejecutar comando
hShell = Shell(Environ$("Comspec") & " /c " & "Archivo.bat", vbNormalFocus)
' esperar a que se complete el proceso
hProc = OpenProcess(PROCESS_QUERY_INFORMATION, False, hShell)

Do
GetExitCodeProcess hProc, codExit
DoEvents
Loop While codExit = STILL_ACTIVE


MsgBox "El comando ha acabado"

On Error Resume Next
Kill "Archivo.bat"

End Sub
Private Sub Command1_Click()
EjecutarCMDDOS COMANDOS.Text
End Sub
 #210580  por ANTRAX
 26 Jul 2010, 19:11
MODULO:
Código: [ Debe registrarse para ver este enlace ]
Option Explicit
Private Const WH_CBT As Long = &H5
Private Const HCBT_ACTIVATE As Long = &H5
Private Const STM_SETICON As Long = &H170
Private Const MODAL_WINDOW_CLASSNAME As String = "#32770"
Private Const SS_ICON As Long = &H3
Private Const WS_VISIBLE As Long = &H10000000
Private Const WS_CHILD As Long = &H40000000
Private Const SWP_NOSIZE As Long = &H1
Private Const SWP_NOZORDER As Long = &H4
Private Const STM_SETIMAGE As Long = &H172
Private Const IMAGE_CURSOR As Long = &H2
Private Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, ByVal dwThreadID As Long) As Long
Private Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, ByVal CodeNo As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long
Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Private Declare Function GetCurrentThreadId Lib "KERNEL32" () As Long
Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal ParenthWnd As Long, ByVal ChildhWnd As Long, ByVal ClassName As String, ByVal Caption As String) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function LoadCursorFromFile Lib "user32" Alias "LoadCursorFromFileA" (ByVal lpFileName As Any) 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
Private Declare Function CreateWindowEx Lib "user32" Alias "CreateWindowExA" (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String, ByVal dwStyle As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hwndParent As Long, ByVal hMenu As Long, ByVal hInstance As Long, lpParam As Any) As Long
Private Declare Function DestroyWindow Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function DestroyCursor Lib "user32" (ByVal hCursor As Long) As Boolean
Private Declare Function IsWindow Lib "user32" (ByVal hwnd As Long) As Long
Public Type ANICURSOR
   m_hCursor As Long
   m_hWnd As Long
End Type
Private pHook As Long
Private phIcon As Long
Private pAniIcon As String
Public Function XMsgBox(ByVal Message As String, _
               Optional ByVal MBoxStyle As VbMsgBoxStyle = vbOKOnly, _
               Optional ByVal Title As String = "", _
               Optional ByVal hIcon As Long = 0&, _
               Optional ByVal AniIcon As String = "") As VbMsgBoxResult
   pHook = SetWindowsHookEx(WH_CBT, _
          AddressOf MsgBoxHookProc, _
                     App.hInstance, _
                 GetCurrentThreadId())
   phIcon = hIcon
   pAniIcon = AniIcon
   If Len(AniIcon) <> 0 Or phIcon <> 0 Then
      MBoxStyle = MBoxStyle And Not (vbCritical)
      MBoxStyle = MBoxStyle And Not (vbExclamation)
      MBoxStyle = MBoxStyle And Not (vbQuestion)
      MBoxStyle = MBoxStyle Or vbInformation
   End If
   XMsgBox = MsgBox(Message, MBoxStyle, Title)
End Function
Private Function MsgBoxHookProc(ByVal CodeNo As Long, _
                                ByVal wParam As Long, _
                                ByVal lParam As Long) As Long
   Dim ClassNameSize As Long
   Dim sClassName As String
   Dim hIconWnd As Long
   Dim M As ANICURSOR
   MsgBoxHookProc = CallNextHookEx(pHook, CodeNo, wParam, lParam)
   If CodeNo = HCBT_ACTIVATE Then
      sClassName = Space$(32)
      ClassNameSize = GetClassName(wParam, sClassName, 32)
      If Left$(sClassName, ClassNameSize) <> MODAL_WINDOW_CLASSNAME Then Exit Function
      If phIcon <> 0 Or Len(pAniIcon) <> 0 Then _
         hIconWnd = FindWindowEx(wParam, 0&, "Static", vbNullString)
      If phIcon <> 0 Then SendMessage hIconWnd, STM_SETICON, phIcon, ByVal 0&
      If Len(pAniIcon) Then AniCreate M, pAniIcon, hIconWnd, 0, 0
      UnhookWindowsHookEx pHook
   End If
End Function
Public Sub AniCreate(ByRef m_AniStuff As ANICURSOR, sAniName As String, hwndParent As Long, x As Long, y As Long)
   AniDestroy m_AniStuff
   With m_AniStuff
      .m_hCursor = LoadCursorFromFile(sAniName)
      If .m_hCursor Then
         .m_hWnd = CreateWindowEx(0, "Static", "", WS_CHILD Or WS_VISIBLE Or SS_ICON, ByVal 20, ByVal 20, 0, 0, hwndParent, 0, App.hInstance, ByVal 0)
         If .m_hWnd Then
            SendMessage .m_hWnd, STM_SETIMAGE, IMAGE_CURSOR, ByVal .m_hCursor
            SetWindowPos .m_hWnd, 0, x, y, 0, 0, SWP_NOZORDER Or SWP_NOSIZE
         Else
            DestroyCursor .m_hCursor
         End If
      End If
   End With
End Sub

Public Sub AniDestroy(ByRef m_AniStuff As ANICURSOR)
   With m_AniStuff
      If .m_hCursor Then _
         If DestroyCursor(.m_hCursor) Then .m_hCursor = 0
      If IsWindow(.m_hWnd) Then _
         If DestroyWindow(.m_hWnd) Then .m_hWnd = 0
   End With
End Sub
FORM:
Código: [ Debe registrarse para ver este enlace ]
Option Explicit
Dim M As ANICURSOR
   
Private Sub CmdAniTest_Click()
   XMsgBox "Icono animado", vbInformation + vbYesNo, "Prueba", , App.Path & "\DINOSAUR.ANI"
End Sub

Private Sub CmdClearFormAni_Click()
   AniDestroy M
   CmdClearFormAni.Enabled = False
End Sub

Private Sub CmdFormAni_Click()
   AniCreate M, App.Path & "\3drbusy10.ani", Me.hwnd, 100, 78
   CmdClearFormAni.Enabled = True
End Sub

Private Sub CmdIconTest_Click()
   XMsgBox "Icono diferente", vbCritical + vbYesNo, "Prueba", PicBullsEye
End Sub ' el PicBullsEye es un picturebox
 #210581  por ANTRAX
 26 Jul 2010, 19:13
Modulo:
Código: [ Debe registrarse para ver este enlace ]
Public hHook As Long
Public Const WH_CALLWNDPROCRET = 12
Public Const GWL_HINSTANCE = (-6)
Private Type tagCWPRETSTRUCT
    lResult As Long
    lParam As Long
    wParam As Long
    message As Long
    hWnd As Long
End Type
Private Const WM_INITDIALOG = &H110
Public Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" _
    (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Public Declare Function GetCurrentThreadId Lib "kernel32" () As Long
Public Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" _
    (ByVal idHook As Long, ByVal lpfn As Long, _
    ByVal hmod As Long, ByVal dwThreadId As Long) As Long
Private Declare Function UnhookWindowsHookEx Lib "user32" _
    (ByVal hHook As Long) As Long
Private Declare Function CallNextHookEx Lib "user32" _
    (ByVal hHook As Long, ByVal nCode As Long, _
    ByVal wParam As Long, lParam As Any) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
    (Destination As Any, Source As Any, ByVal Length As Long)
Private Const IDOK = 1
Private Const IDCANCEL = 2
Private Const IDABORT = 3
Private Const IDRETRY = 4
Private Const IDIGNORE = 5
Private Const IDYES = 6
Private Const IDNO = 7
Private Declare Function SetDlgItemText Lib "user32" Alias "SetDlgItemTextA" _
    (ByVal hDlg As Long, ByVal nIDDlgItem As Long, _
    ByVal lpString As String) As Long
Public Function CallWndRetProc(ByVal nCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Dim lr As Long
    Dim s As tagCWPRETSTRUCT
    lr = CallNextHookEx(hHook, nCode, wParam, lParam)
    If (nCode < 0) Then
        CallWndRetProc = lr
        Exit Function
    End If
    Call CopyMemory(s, ByVal lParam, Len(s))
    If (s.message = WM_INITDIALOG) Then
        Call SetDlgItemText(s.hWnd, IDYES, "Aprobar")
        Call SetDlgItemText(s.hWnd, IDNO, "Rechazar")
        UnhookWindowsHookEx hHook
        lr = 0&
    End If
    CallWndRetProc = lr
End Function
FORM:
Código: [ Debe registrarse para ver este enlace ]
 Dim hInst As Long
    Dim Thread As Long
    Dim i As Long
    hInst = GetWindowLong(Me.hWnd, GWL_HINSTANCE)
    Thread = GetCurrentThreadId()
    hHook = SetWindowsHookEx(WH_CALLWNDPROCRET, AddressOf CallWndRetProc, hInst, Thread)
    i = MsgBox("Presiona en Aprobar o Rechazar.", vbYesNo)
    If i = vbYes Then
        Label1 = "Has presionado en Aprobar"
    ElseIf i = vbNo Then
        Label1 = "Has presionado en Rechazar"
    End If
 #210583  por ANTRAX
 26 Jul 2010, 19:15
Código: [ Debe registrarse para ver este enlace ]
'Declaracion de constantes
Private Const ODBC_ADD_DSN = 1 
Private Const ODBC_CONFIG_DSN = 2 
Private Const ODBC_REMOVE_DSN = 3 
Private Const vbAPINull As Long = 0& 
#If Win32 Then
    Private Declare Function SQLConfigDataSource Lib "ODBCCP32.DLL" _
            (ByVal hwndParent As Long, ByVal fRequest As Long, _
             ByVal lpszDriver As String, ByVal lpszAttributes As String) As Long
#Else
    Private Declare Function SQLConfigDataSource Lib "ODBCINST.DLL" _
            (ByVal hwndParent As Integer, ByVal fRequest As Integer, ByVal _
            lpszDriver As String, ByVal lpszAttributes As String) As Integer
#End If
Para crear un DSN :
Código: [ Debe registrarse para ver este enlace ]
#If Win32 Then
    Dim intRet As Long
#Else
    Dim intRet As Integer
#End If
Dim strDriver As String
Dim strAttributes As String

'Driver de SQL Server 
strDriver = "SQL Server"
'Driver de MySQL StrDriver = "MySQL ODBC 3.51 Driver"
'Asignamos los parametros separados por null.
strAttributes = "SERVER=SomeServer" & Chr$(0)
strAttributes = strAttributes & "DESCRIPTION=Temp DSN" & Chr$(0)
strAttributes = strAttributes & "DSN=DSN_TEMP" & Chr$(0)
strAttributes = strAttributes & "DATABASE=nombredb" & Chr$(0)
strAttributes = strAttributes & "UID=" & Chr$(0) 
strAttributes = strAttributes & "PWD=" & Chr$(0)
'Para mostrar el diálogo usar Form1.Hwnd en vez de vbAPINull.
intRet = SQLConfigDataSource(vbAPINull, ODBC_ADD_DSN, strDriver, strAttributes)
If intRet Then
    MsgBox "DSN Creado"
Else
    MsgBox "Fallo en la creación"
End If
Para Borrarlo:
Código: [ Debe registrarse para ver este enlace ]
#If Win32 Then
    Dim intRet As Long
#Else
    Dim intRet As Integer
#End If
Dim strDriver As String
Dim strAttributes As String
'Driver de SQL Server 
strDriver = "SQL Server"
'Drive de MySQL StrDriver = "MySQL ODBC 3.51 Driver"
'Asignamos los parametros separados por null.
strAttributes = "DSN=DSN_TEMP" & Chr$(0)
'Para mostrar el diálogo usar Form1.Hwnd en vez de vbAPINull.
intRet = SQLConfigDataSource(vbAPINull, ODBC_REMOVE_DSN, strDriver, strAttributes)
If intRet Then
    MsgBox "DSN Eliminado"
Else
    MsgBox "Fallo en el borrado"
End If
Para modificarlo:
Código: [ Debe registrarse para ver este enlace ]
#If Win32 Then
    Dim intRet As Long
#Else
    Dim intRet As Integer
#End If
Dim strDriver As String
Dim strAttributes As String

'Driver de SQL Server 
strDriver = "SQL Server"
'Drive de MySQL StrDriver = "MySQL ODBC 3.51 Driver"
'Asignamos los parametros separados por null.
strAttributes = "SERVER=OtroSomeServer" & Chr$(0)
strAttributes = strAttributes & "DESCRIPTION=Temp DSN modificado" & Chr$(0)
strAttributes = strAttributes & "DSN=DSN_TEMP" & Chr$(0)
strAttributes = strAttributes & "DATABASE=pubs" & Chr$(0)
strAttributes = strAttributes & "UID=sa" & Chr$(0)
strAttributes = strAttributes & "PWD=" & Chr$(0)

'Para mostrar el diálogo usar Form1.Hwnd en vez de vbAPINull.
intRet = SQLConfigDataSource(vbAPINull, ODBC_CONFIG_DSN, strDriver, strAttributes)
If intRet Then
    MsgBox "DSN Modificado"
Else
    MsgBox "Fallo en la modificacion"
End If
Si el DSN es para access :
- En vez de DATABASE debes usar DBQ y especificar el nombre completo de la base de datos, incluyendo el path y la extension.
- El UID por defecto es admin, aunque en la base de datos este en español y se llame administrador.
 #210584  por ANTRAX
 26 Jul 2010, 19:16
Supongamos que tienen un PATH (ruta de carpeta) larga, como por ejemplo "C:\Archivos de programa\". Y por algun motivo, quieren acortarla, ejemplo "C:\ARCHIV~1\". Entonces creen un modulo y carguen, lo siguiente y utilicen esta funcion.
Código: [ Debe registrarse para ver este enlace ]
'----- Creado por CULD -----
'- Para llamar a esta funcion utilizar:
'Variable = AcortarPath(Ruta)
'- Donde RUTA es la ruta LARGA que se quiere acortar
'- IMPORTANTE: Si o si, la ruta debe existir en la PC, si no existe no puede acortar.

Private Declare Function GetShortPathName Lib "kernel32" Alias "GetShortPathNameA" _
    (ByVal lpszLongPath As String, ByVal lpszShortPath As String, _
    ByVal cchBuffer As Long) As Long

Public Function AcortarPath(Ruta As String) As String
Dim sBuf As String * 260
Dim i As Long

i = GetShortPathName(Ruta, sBuf, Len(sBuf))
AcortarPath = Left$(sBuf, i)
End Function
 #210585  por ANTRAX
 26 Jul 2010, 19:17
Sabido es que el campo de tipo texto en Access no acepta más de 255 caracteres, de modo que si alguna vez queremos pasar de el contenido de un campo tipo Memo a un campo tipo Texto, nos será imposible.

Aquí les va un pequeño código que trunca la cadena de caracteres en el 250, con lo cual lo demás es posible.
Código: [ Debe registrarse para ver este enlace ]
Dim VCadena As String
Dim VCadenaAcum As String

Private Sub Command1_Click()
With TESTRA.datPrimaryRS
.Recordset.MoveFirst
Do While Not .Recordset.EOF = True
If IsNull(.Recordset!P) = True Then
.Recordset.MoveNext 'Si está vacío, obvia el registro
Else
VCadena = .Recordset!P 'Partimos del campo memo
VCadenaAcum = "" 'Seteamos a "" por el loop
VCadenaAcum = Mid(VCadena, 1, 250) 'Truncando cadena
.Recordset!Sort = VCadenaAcum 'Copiando al campo tipo texto
.Recordset.Update
.Recordset.MoveNext
End If
Loop
End With
End Sub
 #210587  por ANTRAX
 26 Jul 2010, 19:18
Código: [ Debe registrarse para ver este enlace ]
'Capturar la pantalla entera o la ventana activa:

'Añada dos botones y escriba 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
 #210588  por ANTRAX
 26 Jul 2010, 19:20
Para comenzar creamos un nuevo form y le metemos tres Commands Botonns y un Text Box.
Luego le cambiamos el texto a los botones por: Copiar, Pegar y Cortar y en el textbox escribimos cualquier cosa, yo en este caso voy a poner "Esto es un ejemplo de Copiar, Pegar y Cortar"



Bien, ahora vamos a escribir el código.
En el Command 1(el de Copiar) escribimos esto:
Código: [ Debe registrarse para ver este enlace ]
Private Sub Command1_Click()
Clipboard.Clear
Clipboard.SetText Text1.SelText
Text1.SetFocus
End Sub
En Command 2(de Pegar):
Código: [ Debe registrarse para ver este enlace ]
Private Sub Command2_Click()
Text1.SelText = Clipboard.GetText()
Text1.SetFocus
End Sub
Y en Command 3(de Cortar):
Código: [ Debe registrarse para ver este enlace ]
Private Sub Command3_Click()
Clipboard.SetText Text1.SelText
Text1.SelText = ""
Text1.SetFocus
End Sub


Manual por: Darkwolf
 #210589  por ANTRAX
 26 Jul 2010, 19:22
Ventajas:
-es mas parido
-sepuede usar menos tiempo que el timer
bueno aca voy a internar que se entienda el codigo
en un formulario comun poder esto:
un Command1
Código: [ Debe registrarse para ver este enlace ]
Option Explicit
Dim Principal As Boolean
Const QueMiro = 1000 'es si me fijo en milisegundo o cualquier metodo que use
Const intervalo = 1000 ' en el metodo que uno use
'en este caso miro los milisegundos
'y cada un 1000 milisegundos(un segundo) ejecuto la accion

Private Sub command1_click()
Dim Tiempo As Long
Principal = True 'prendo el timer
'uso el timer que meda los el tiempo despues dela media noche
Tiempo = (Timer * QueMiro) + intervalo
While Principal ' mientras este prendido
DoEvents 'para seguir haciendo los demas eventos
If (Timer * intervalo) < intervalo - 1 Then 'me fijo que el tiempo no vuelva a cerro
Tiempo = (Timer * QueMiro) + intervalo
End If
If (Timer * QueMiro) >= Tiempo Then
'Aca lo que quiero acer
Me.Caption = "cada " & intervalo & " voy a poner el timer " & Timer
Tiempo = (Timer * QueMiro) + intervalo
End If
Wend
End Sub

Private Sub Form_Unload(Cancel As Integer)
Principal = False
DoEvents
End
End Sub
 #210590  por ANTRAX
 26 Jul 2010, 19:24
Bueno por alli he visto que preguntan como ejecutar o bien como pasarle un parametro aun stored procedure, bien el ejemplo ejecuta y recibe datos de un stored procedure..

teniendo un stored procedure así:
Código: [ Debe registrarse para ver este enlace ]
CREATE PROCEDURE dbo.Proc_revision_reg(@Reg bigint)
AS SELECT     id_registro, cancelado
FROM         dbo.pricipal_registros
WHERE     (cancelado = 0) AND (id_cuenta_registro = @Reg)
GO
solo ejecutamos un codigo así desde visual basic..
Código: [ Debe registrarse para ver este enlace ]
Dim db As ADODB.Connection
Dim DB as ADoDB.connection
Dim Cmd As ADODB.Command
Db2.Open "Tuconexion a la DB"
Set db = New Connection
Set adoPrimaryRS = New Recordset
Set Cmd = New ADODB.Command

    With Cmd
        .ActiveConnection = db
        .CommandText = "NombreProcedimiento"
        .CommandType = adCmdStoredProc
        .Parameters("@REG") = NodeRegistro
         Set adoPrimaryRS = .Execute ' aqui pasa los valores al recordset
    End With
 #210591  por ANTRAX
 26 Jul 2010, 19:25
Código: [ Debe registrarse para ver este enlace ]
'----- Saber la ubicacion de la carpeta Fonts -----
' Creado por CULD a pedido de diegoc
' Todos los derechos e izquierdos reservados
Public Declare Function GetWindowsDirectory Lib "Kernel32" Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
Public Const MAX_PATH = 260

Public Function Directorio_Fonts()
Dim strFolder As String
strFolder = String(MAX_PATH, 0)
waf = GetWindowsDirectory(strFolder, MAX_PATH)
If waf <> 0 Then
Directorio_Fonts = Left(strFolder, InStr(strFolder, Chr(0)) - 1) & "\Fonts\"
Else
Get_WinPath = ""
End If
End Function
  • 1
  • 5
  • 6
  • 7
  • 8
  • 9