• [VB6] Coleccion de Codigos Utiles

 #210418  por ANTRAX
 26 Jul 2010, 15:06
En un módulo:
Código: [ Debe registrarse para ver este enlace ]
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
Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Declare Function GetMessage Lib "user32" Alias "GetMessageA" (lpMsg As MSG, ByVal hwnd As Long, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long) As Long

Type POINTAPI
        x As Long
        y As Long
End Type

Type MSG
    hwnd As Long
    message As Long
    wParam As Long
    lParam As Long
    time As Long
    pt As POINTAPI
End Type

Public Const GWL_WNDPROC = -4
Public Const WM_QUERYENDSESSION = &H11
Global Const WM_CANCELMODE = &H1F

Public SDAttempted As Long
Global lpPrevWndProc As Long
Global gHW As Long

Public Sub Hook()
    lpPrevWndProc = SetWindowLong(gHW, GWL_WNDPROC, AddressOf WindowProc)
End Sub

Public Sub Unhook()
    Dim temp As Long
    temp = SetWindowLong(gHW, GWL_WNDPROC, lpPrevWndProc)
End Sub
Function WindowProc(ByVal hw As Long, ByVal uMsg As _
Long, ByVal wParam As Long, ByVal lParam As Long) As _
Long
Dim a As Long
    If uMsg = WM_QUERYENDSESSION Then
            SDAttempted = SDAttempted + 1
            WindowProc = CallWindowProc(lpPrevWndProc, hw, _
            WM_CANCELMODE, wParam, wParam)
             Exit Function
    End If
    WindowProc = CallWindowProc(lpPrevWndProc, hw, _
    uMsg, wParam, lParam)
End Function
En el form Load o Activate:
Código: [ Debe registrarse para ver este enlace ]
SDAttempted = 0
gHW = Me.hwnd
Hook
 #210419  por ANTRAX
 26 Jul 2010, 15:08
Private Sub DataGrid1_HeadClick(ByVal ColIndex As Integer)
With Adodc1.Recordset
If (.Sort = .Fields(ColIndex).[Nombre] & " Asc") Then
.Sort = .Fields(ColIndex).[Nombre] & " Desc"
Else
.Sort = .Fields(ColIndex).[Nombre] & " Asc"
End If
End With
End Sub
 #210422  por ANTRAX
 26 Jul 2010, 15:12
Código: [ Debe registrarse para ver este enlace ]
Option Explicit
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Const SW_NORMAL = 1

Dim X
X = ShellExecute(Me.hwnd, "Open", "http://www.url.com", &O0, &O0, SW_NORMAL)
 #210423  por ANTRAX
 26 Jul 2010, 15:14
Con esto puedes ocultar y/o mostrar los iconos que se encuentran al aldo del reloj del taskbar.

En un módulo:
Código: [ Debe registrarse para ver este enlace ]
Public isvisible As Integer
Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, y, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Private Const HWND_TOPMOST = -1
Private Const HWND_NOTOPMOST = -2
Private Const SWP_NOMOVE = &H2
Private Const SWP_NOSIZE = &H1
Private Const TOPMOST_FLAGS = SWP_NOMOVE Or SWP_NOSIZE
Public Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Public Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
Public Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long

Public Function HideTaskBarIcons()
    Dim FindClass As Long, Handle As Long
    FindClass& = FindWindow("Shell_TrayWnd", "")
    Handle& = FindWindowEx(FindClass&, 0, "TrayNotifyWnd", vbNullString)
    ShowWindow Handle&, 0
End Function

Public Function ShowTaskBarIcons()
    Dim FindClass As Long, Handle As Long
    FindClass& = FindWindow("Shell_TrayWnd", "")
    Handle& = FindWindowEx(FindClass&, 0, "TrayNotifyWnd", vbNullString)
    ShowWindow Handle&, 1
End Function

Public Function HideTaskBarClock()
    Dim FindClass As Long, FindParent As Long, Handle As Long
    FindClass& = FindWindow("Shell_TrayWnd", vbNullString)
    FindParent& = FindWindowEx(FindClass&, 0, "TrayNotifyWnd", vbNullString)
    Handle& = FindWindowEx(FindParent&, 0, "TrayClockWClass", vbNullString)
    ShowWindow Handle&, 0
End Function

Public Function ShowTaskBarClock()
    Dim FindClass As Long, FindParent As Long, Handle As Long
    FindClass& = FindWindow("Shell_TrayWnd", vbNullString)
    FindParent& = FindWindowEx(FindClass&, 0, "TrayNotifyWnd", vbNullString)
    Handle& = FindWindowEx(FindParent&, 0, "TrayClockWClass", vbNullString)
    ShowWindow Handle&, 1
End Function

Public Function HideDesktop()
    ShowWindow FindWindowEx(FindWindowEx(FindWindow("Progman", vbNullString), 0&, "SHELLDLL_DefView", vbNullString), 0&, "SysListView32", vbNullString), 0
End Function

Public Function ShowDesktop()
    ShowWindow FindWindowEx(FindWindowEx(FindWindow("Progman", vbNullString), 0&, "SHELLDLL_DefView", vbNullString), 0&, "SysListView32", vbNullString), 5
End Function

Public Function HideStartButton()
    Dim Handle As Long, FindClass As Long
    FindClass& = FindWindow("Shell_TrayWnd", "")
    Handle& = FindWindowEx(FindClass&, 0, "Button", vbNullString)
    ShowWindow Handle&, 0
End Function

Public Function ShowStartButton()
    Dim Handle As Long, FindClass As Long
    FindClass& = FindWindow("Shell_TrayWnd", "")
    Handle& = FindWindowEx(FindClass&, 0, "Button", vbNullString)
    ShowWindow Handle&, 1
End Function

Public Function HideTaskBar()
    Dim Handle As Long
    Handle& = FindWindow("Shell_TrayWnd", vbNullString)
    ShowWindow Handle&, 0
End Function

Public Function ShowTaskBar()
    Dim Handle As Long
    Handle& = FindWindow("Shell_TrayWnd", vbNullString)
    ShowWindow Handle&, 1
End Function

Public Sub MakeNormal(hwnd As Long)
    SetWindowPos hwnd, HWND_NOTOPMOST, 0, 0, 0, 0, TOPMOST_FLAGS
End Sub

Public Sub MakeTopMost(hwnd As Long)
    SetWindowPos hwnd, HWND_TOPMOST, 0, 0, 0, 0, TOPMOST_FLAGS
End Sub
En el form:
Código: [ Debe registrarse para ver este enlace ]
Dim ico As Integer
Dim clo As Integer
Dim stb As Integer
Dim tsk As Integer
Dim dsk As Integer

Private Sub Command1_Click()
If isvisible = 1 Then
        If ico = 0 Then
        ShowTaskBarIcons
        ico = 1
        ElseIf ico = 1 Then
        HideTaskBarIcons
        ico = 0
        End If
    ElseIf isvisible = 0 Then
    End If
End Sub

Private Sub Command2_Click()
If isvisible = 1 Then
        If clo = 0 Then
        ShowTaskBarClock
        clo = 1
        ElseIf clo = 1 Then
        HideTaskBarClock
        clo = 0
        End If
    ElseIf isvisible = 0 Then
    End If
End Sub

Private Sub Command3_Click()
If isvisible = 1 Then
        If stb = 0 Then
        ShowStartButton
        stb = 1
        ElseIf stb = 1 Then
        HideStartButton
        stb = 0
        End If
    ElseIf isvisible = 0 Then
    End If
End Sub

Private Sub Command4_Click()
 If isvisible = 1 Then
        If tsk = 0 Then
        ShowTaskBar
        tsk = 1
        ElseIf tsk = 1 Then
        HideTaskBar
        tsk = 0
        End If
    ElseIf isvisible = 0 Then
    End If
End Sub

Private Sub Command5_Click()
If isvisible = 1 Then
        If dsk = 0 Then
        ShowDesktop
        dsk = 1
        ElseIf dsk = 1 Then
        HideDesktop
        dsk = 0
        End If
    ElseIf isvisible = 0 Then
    End If
End Sub

Private Sub Command6_Click()
   If isvisible = 1 Then
        ShowTaskBarIcons
        ShowTaskBarClock
        ShowDesktop
        ShowStartButton
        ShowTaskBar
        ico = 1
        clo = 1
        stb = 1
        tsk = 1
        dsk = 1
    ElseIf isvisible = 0 Then
    End If
End Sub

Private Sub Form_Load()
MakeTopMost Me.hwnd
isvisible = 1
ico = 1
clo = 1
stb = 1
tsk = 1
dsk = 1
End Sub
 #210424  por ANTRAX
 26 Jul 2010, 15:18
Código: [ Debe registrarse para ver este enlace ]
Option Explicit

Private Declare Function SetCursorPos Lib "user32" _
(ByVal x As Long, ByVal y As Long) As Long

Private Sub Command1_Click()
Dim a As Long, b As Long, c As Long
SetCursorPos 256, 256
a = 2
b = 5
c = a + b
SetCursorPos 512, 512
End Sub
 #210426  por ANTRAX
 26 Jul 2010, 15:22
Agregas un modulo de clase y lo llamas clsmouse y copias:
Código: [ Debe registrarse para ver este enlace ]
Option Explicit
Public Event PositionChanged()
Public Event SytemClick(ByVal Button As MouseButtonConstants)
Private Const VK_RBUTTON As Long = &H2
Private Const VK_MBUTTON As Long = &H4
Private Const VK_LBUTTON As Long = &H1
Private Const MOUSEEVENTF_LEFTDOWN As Long = &H2
Private Const MOUSEEVENTF_LEFTUP As Long = &H4
Private Const MOUSEEVENTF_MIDDLEDOWN As Long = &H20
Private Const MOUSEEVENTF_MIDDLEUP As Long = &H40
Private Const MOUSEEVENTF_RIGHTDOWN As Long = &H8
Private Const MOUSEEVENTF_RIGHTUP As Long = &H10
Private Type POINTAPI
X As Long
Y As Long
End Type
Private m_WatchPosition As Boolean
Private m_WatchSystemClicks As Boolean
Private m_Position As New clsmouseposition
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Sub mouse_event Lib "user32" (ByVal dwFlags As Long, _
ByVal dx As Long, _
ByVal dy As Long, _
ByVal cButtons As Long, _
ByVal dwExtraInfo As Long)

Public Sub Click(Optional MouseButton As MouseButtonConstants = vbLeftButton)
If (MouseButton = vbLeftButton) Then
Call mouse_event(MOUSEEVENTF_LEFTDOWN, 0&, 0&, 0&, 0&)
Call mouse_event(MOUSEEVENTF_LEFTUP, 0&, 0&, 0&, 0&)
ElseIf (MouseButton = vbMiddleButton) Then
Call mouse_event(MOUSEEVENTF_MIDDLEDOWN, 0&, 0&, 0&, 0&)
Call mouse_event(MOUSEEVENTF_MIDDLEUP, 0&, 0&, 0&, 0&)
ElseIf (MouseButton = vbRightButton) Then
Call mouse_event(MOUSEEVENTF_RIGHTDOWN, 0&, 0&, 0&, 0&)
Call mouse_event(MOUSEEVENTF_RIGHTUP, 0&, 0&, 0&, 0&)
End If
End Sub

Private Function CompKey(KCode As Long) As Boolean
Dim Result As Long
Result = GetAsyncKeyState(KCode)
If Result = -32767 Then
CompKey = True
Else
CompKey = False
End If
End Function

Public Property Get Position() As clsmouseposition
Set Position = m_Position
End Property

Public Property Let TimerEvent(ByVal Dummmy As Boolean)
Dim CurPos As POINTAPI
Dim Value As MouseButtonConstants
Static First As Boolean
Static mx As Long
Static my As Long
If m_WatchPosition Then
Call GetCursorPos(CurPos)
If First Then
If CurPos.X <> mx Or CurPos.Y <> my Then
RaiseEvent PositionChanged
End If
End If
mx = CurPos.X
my = CurPos.Y
End If
If m_WatchSystemClicks Then
If CompKey(VK_LBUTTON) Then
Value = vbLeftButton
End If
If CompKey(VK_RBUTTON) Then
Value = Value Or vbRightButton
End If
If CompKey(VK_MBUTTON) Then
Value = Value Or vbMiddleButton
End If
If Value <> 0 Then
RaiseEvent SytemClick(Value)
End If
End If
First = True
End Property
Agregas otro y lo llamas clsmouseposition y pegas:
Código: [ Debe registrarse para ver este enlace ]
Option Explicit
Private Type POINTAPI
X As Long
Y As Long
End Type
Private m_x As Long
Private m_y As Long
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Function SetCursorPos Lib "user32" (ByVal X As Long, _
ByVal Y As Long) As Long

Private Sub GetPosition()
Dim P As POINTAPI
Call GetCursorPos(P)
m_y = P.Y
m_x = P.X
End Sub

Public Property Get X() As Long
Call GetPosition
X = m_x
End Property

Public Property Let X(lngValue As Long)
Call SetCursorPos(lngValue, m_y)
m_x = lngValue
End Property

Public Property Get Y() As Long
Call GetPosition
Y = m_y
End Property

Public Property Let Y(lngValue As Long)
Call SetCursorPos(m_x, lngValue)
m_y = lngValue
End Property
y en el form pones:
Código: [ Debe registrarse para ver este enlace ]
Option Explicit
Private WithEvents Mouse As clsmouse

Private Sub Command1_Click()
With Mouse
.Position.X = coodenada 
.Position.Y = coordenada 
.Click (vbLeftButton)
End With
'Si quieres pones x=100 y y=100, pones el Startupposition en center screen y que tu form no ocupe la pantalla completa hazlo pequeño para que veas que pasa
End Sub

Private Sub Form_Load()
Set Mouse = New clsmouse
End Sub
 #210428  por ANTRAX
 26 Jul 2010, 15:24
En un modulo:
Código: [ Debe registrarse para ver este enlace ]
Public nid As NOTIFYICONDATA
Public Declare Function Shell_NotifyIcon Lib "shell32" Alias "Shell_NotifyIconA" (ByVal dwMessage As Long, pnid As NOTIFYICONDATA) As Boolean
Public Const WM_CHAR = &H102
Public Const WM_SETTEXT = &HC
Public Const WM_USER = &H400
Public Const WM_KEYDOWN = &H100
Public Const WM_KEYUP = &H101
Public Const WM_LBUTTONDOWN = &H201
Public Const WM_CLOSE = &H10
Public Const WM_COMMAND = &H111
Public Const WM_CLEAR = &H303
Public Const WM_DESTROY = &H2
Public Const WM_GETTEXT = &HD
Public Const WM_GETTEXTLENGTH = &HE
Public Type NOTIFYICONDATA
cbSize As Long
hwnd As Long
uId As Long
uFlags As Long
uCallBackMessage As Long
hIcon As Long
szTip As String * 64
End Type
Public Const NIM_ADD = &H0
Public Const NIM_MODIFY = &H1
Public Const NIM_DELETE = &H2
Public Const NIF_MESSAGE = &H1
Public Const NIF_ICON = &H2
Public Const NIF_TIP = &H4
Public Const WM_MOUSEMOVE = &H200
Public Declare Function SetForegroundWindow Lib "user32" (ByVal hwnd As Long) As Long

Sub InitializeTrayIcon()
With nid
.cbSize = Len(nid)
.hwnd = frmMain.hwnd 'nombre del form que estara minimizado
.uId = vbNull
.uFlags = NIF_ICON Or NIF_TIP Or NIF_MESSAGE
.uCallBackMessage = WM_MOUSEMOVE
.hIcon = frmMain.Icon 'nombre del formulario que contiene el icono
End With
Shell_NotifyIcon NIM_ADD, nid
End Sub
Y en el Form:
Código: [ Debe registrarse para ver este enlace ]
Private Sub Form_Load()
InitializeTrayIcon
End Sub

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim Result As Long
Dim msg As Long
If Me.ScaleMode = vbPixels Then
msg = X
Else
msg = X / Screen.TwipsPerPixelX
End If
Select Case msg
Case 517
Me.PopupMenu MNU
Case 514
Result = SetForegroundWindow(Me.hwnd)
Me.Show
End Select
End Sub

Private Sub Form_Terminate()
Shell_NotifyIcon NIM_DELETE, nid
End Sub

Private Sub Form_Unload(Cancel As Integer)
Shell_NotifyIcon NIM_DELETE, nid
End Sub
 #210429  por ANTRAX
 26 Jul 2010, 15:26
¡OJO! Este codigo funciona solo si el BorderStyle del form es 0...

En un modulo:
Código: [ Debe registrarse para ver este enlace ]
Option Explicit
Private Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function CreateEllipticRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function CreateRoundRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long, ByVal X3 As Long, ByVal Y3 As Long) As Long
Private Declare Function CreatePolygonRgn Lib "gdi32" (lpPoint As POINTAPI, ByVal nCount As Long, ByVal nPolyFillMode As Long) As Long
Private Type POINTAPI
        X As Long
        Y As Long
End Type
Private Declare Function SetWindowRgn Lib "user32" (ByVal hwnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long
Private Declare Function CombineRgn Lib "gdi32" (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long
Const RGN_XOR = 3

Public Sub MakeTransparent(TransForm As Form)
Dim ErrorTest As Double
    On Error Resume Next
    Dim Regn As Long
    Dim TmpRegn As Long
    Dim TmpControl As Control
    Dim LinePoints(4) As POINTAPI
    TransForm.ScaleMode = 3
    If TransForm.BorderStyle <> 0 Then MsgBox "Change the borderstyle to 0!", vbCritical, "ACK!": End
    Regn = CreateRectRgn(0, 0, 0, 0)
    For Each TmpControl In TransForm
        If TypeOf TmpControl Is Line Then
            If Abs((TmpControl.Y1 - TmpControl.Y2) / (TmpControl.X1 - TmpControl.X2)) > 1 Then
                LinePoints(0).X = TmpControl.X1 - 1
                LinePoints(0).Y = TmpControl.Y1
                LinePoints(1).X = TmpControl.X2 - 1
                LinePoints(1).Y = TmpControl.Y2
                LinePoints(2).X = TmpControl.X2 + 1
                LinePoints(2).Y = TmpControl.Y2
                LinePoints(3).X = TmpControl.X1 + 1
                LinePoints(3).Y = TmpControl.Y1
            Else
                LinePoints(0).X = TmpControl.X1
                LinePoints(0).Y = TmpControl.Y1 - 1
                LinePoints(1).X = TmpControl.X2
                LinePoints(1).Y = TmpControl.Y2 - 1
                LinePoints(2).X = TmpControl.X2
                LinePoints(2).Y = TmpControl.Y2 + 1
                LinePoints(3).X = TmpControl.X1
                LinePoints(3).Y = TmpControl.Y1 + 1
            End If
            TmpRegn = CreatePolygonRgn(LinePoints(0), 4, 1)
        ElseIf TypeOf TmpControl Is Shape Then
            If TmpControl.Shape = 0 Then
                TmpRegn = CreateRectRgn(TmpControl.Left, TmpControl.Top, TmpControl.Left + TmpControl.Width, TmpControl.Top + TmpControl.Height)
            ElseIf TmpControl.Shape = 1 Then
                If TmpControl.Width < TmpControl.Height Then
                    TmpRegn = CreateRectRgn(TmpControl.Left, TmpControl.Top + (TmpControl.Height - TmpControl.Width) / 2, TmpControl.Left + TmpControl.Width, TmpControl.Top + (TmpControl.Height - TmpControl.Width) / 2 + TmpControl.Width)
                Else
                    TmpRegn = CreateRectRgn(TmpControl.Left + (TmpControl.Width - TmpControl.Height) / 2, TmpControl.Top, TmpControl.Left + (TmpControl.Width - TmpControl.Height) / 2 + TmpControl.Height, TmpControl.Top + TmpControl.Height)
                End If
            ElseIf TmpControl.Shape = 2 Then
                TmpRegn = CreateEllipticRgn(TmpControl.Left, TmpControl.Top, TmpControl.Left + TmpControl.Width + 0.5, TmpControl.Top + TmpControl.Height + 0.5)
            ElseIf TmpControl.Shape = 3 Then
                If TmpControl.Width < TmpControl.Height Then
                    TmpRegn = CreateEllipticRgn(TmpControl.Left, TmpControl.Top + (TmpControl.Height - TmpControl.Width) / 2, TmpControl.Left + TmpControl.Width + 0.5, TmpControl.Top + (TmpControl.Height - TmpControl.Width) / 2 + TmpControl.Width + 0.5)
                Else
                    TmpRegn = CreateEllipticRgn(TmpControl.Left + (TmpControl.Width - TmpControl.Height) / 2, TmpControl.Top, TmpControl.Left + (TmpControl.Width - TmpControl.Height) / 2 + TmpControl.Height + 0.5, TmpControl.Top + TmpControl.Height + 0.5)
                End If
            ElseIf TmpControl.Shape = 4 Then
                If TmpControl.Width > TmpControl.Height Then
                    TmpRegn = CreateRoundRectRgn(TmpControl.Left, TmpControl.Top, TmpControl.Left + TmpControl.Width + 1, TmpControl.Top + TmpControl.Height + 1, TmpControl.Height / 4, TmpControl.Height / 4)
                Else
                    TmpRegn = CreateRoundRectRgn(TmpControl.Left, TmpControl.Top, TmpControl.Left + TmpControl.Width + 1, TmpControl.Top + TmpControl.Height + 1, TmpControl.Width / 4, TmpControl.Width / 4)
                End If
            ElseIf TmpControl.Shape = 5 Then
                If TmpControl.Width > TmpControl.Height Then
                    TmpRegn = CreateRoundRectRgn(TmpControl.Left + (TmpControl.Width - TmpControl.Height) / 2, TmpControl.Top, TmpControl.Left + (TmpControl.Width - TmpControl.Height) / 2 + TmpControl.Height + 1, TmpControl.Top + TmpControl.Height + 1, TmpControl.Height / 4, TmpControl.Height / 4)
                Else
                    TmpRegn = CreateRoundRectRgn(TmpControl.Left, TmpControl.Top + (TmpControl.Height - TmpControl.Width) / 2, TmpControl.Left + TmpControl.Width + 1, TmpControl.Top + (TmpControl.Height - TmpControl.Width) / 2 + TmpControl.Width + 1, TmpControl.Width / 4, TmpControl.Width / 4)
                End If
            End If
            If TmpControl.BackStyle = 0 Then
                CombineRgn Regn, Regn, TmpRegn, RGN_XOR
                If TmpControl.Shape = 0 Then
                    TmpRegn = CreateRectRgn(TmpControl.Left + 1, TmpControl.Top + 1, TmpControl.Left + TmpControl.Width - 1, TmpControl.Top + TmpControl.Height - 1)
                ElseIf TmpControl.Shape = 1 Then
                    If TmpControl.Width < TmpControl.Height Then
                        TmpRegn = CreateRectRgn(TmpControl.Left + 1, TmpControl.Top + (TmpControl.Height - TmpControl.Width) / 2 + 1, TmpControl.Left + TmpControl.Width - 1, TmpControl.Top + (TmpControl.Height - TmpControl.Width) / 2 + TmpControl.Width - 1)
                    Else
                        TmpRegn = CreateRectRgn(TmpControl.Left + (TmpControl.Width - TmpControl.Height) / 2 + 1, TmpControl.Top + 1, TmpControl.Left + (TmpControl.Width - TmpControl.Height) / 2 + TmpControl.Height - 1, TmpControl.Top + TmpControl.Height - 1)
                    End If
                ElseIf TmpControl.Shape = 2 Then
                    TmpRegn = CreateEllipticRgn(TmpControl.Left + 1, TmpControl.Top + 1, TmpControl.Left + TmpControl.Width - 0.5, TmpControl.Top + TmpControl.Height - 0.5)
                ElseIf TmpControl.Shape = 3 Then
                    If TmpControl.Width < TmpControl.Height Then
                        TmpRegn = CreateEllipticRgn(TmpControl.Left + 1, TmpControl.Top + (TmpControl.Height - TmpControl.Width) / 2 + 1, TmpControl.Left + TmpControl.Width - 0.5, TmpControl.Top + (TmpControl.Height - TmpControl.Width) / 2 + TmpControl.Width - 0.5)
                    Else
                        TmpRegn = CreateEllipticRgn(TmpControl.Left + (TmpControl.Width - TmpControl.Height) / 2 + 1, TmpControl.Top + 1, TmpControl.Left + (TmpControl.Width - TmpControl.Height) / 2 + TmpControl.Height - 0.5, TmpControl.Top + TmpControl.Height - 0.5)
                    End If
                ElseIf TmpControl.Shape = 4 Then
                    If TmpControl.Width > TmpControl.Height Then
                        TmpRegn = CreateRoundRectRgn(TmpControl.Left + 1, TmpControl.Top + 1, TmpControl.Left + TmpControl.Width, TmpControl.Top + TmpControl.Height, TmpControl.Height / 4, TmpControl.Height / 4)
                    Else
                        TmpRegn = CreateRoundRectRgn(TmpControl.Left + 1, TmpControl.Top + 1, TmpControl.Left + TmpControl.Width, TmpControl.Top + TmpControl.Height, TmpControl.Width / 4, TmpControl.Width / 4)
                    End If
                ElseIf TmpControl.Shape = 5 Then
                    If TmpControl.Width > TmpControl.Height Then
                        TmpRegn = CreateRoundRectRgn(TmpControl.Left + (TmpControl.Width - TmpControl.Height) / 2 + 1, TmpControl.Top + 1, TmpControl.Left + (TmpControl.Width - TmpControl.Height) / 2 + TmpControl.Height, TmpControl.Top + TmpControl.Height, TmpControl.Height / 4, TmpControl.Height / 4)
                    Else
                        TmpRegn = CreateRoundRectRgn(TmpControl.Left + 1, TmpControl.Top + (TmpControl.Height - TmpControl.Width) / 2 + 1, TmpControl.Left + TmpControl.Width, TmpControl.Top + (TmpControl.Height - TmpControl.Width) / 2 + TmpControl.Width, TmpControl.Width / 4, TmpControl.Width / 4)
                    End If
                End If
            End If
        Else
               TmpRegn = CreateRectRgn(TmpControl.Left, TmpControl.Top, TmpControl.Left + TmpControl.Width, TmpControl.Top + TmpControl.Height)
       End If
            ErrorTest = 0
            ErrorTest = TmpControl.Width
            If ErrorTest <> 0 Or TypeOf TmpControl Is Line Then
                CombineRgn Regn, Regn, TmpRegn, RGN_XOR
            End If
    Next TmpControl
    SetWindowRgn TransForm.hwnd, Regn, True
End Sub
En el form:
Código: [ Debe registrarse para ver este enlace ]
Private Declare Function ReleaseCapture Lib "user32" () 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 Const WM_SYSCOMMAND = &H112

Private Sub Form_Load()
    MakeTransparent frmTrans
End Sub
 #210433  por ANTRAX
 26 Jul 2010, 15:32
Esto es a pura API de Windows usaremos la función GetKeyState de la libreria user32. Si queremos detectar la o las teclas presionadas tenemos que llamar a la función pasándole como parámetro el código ASCII de la o las teclas que queremos analizar. Si la tecla está pulsada, la función devuelve –127 o –128. (Se van alternando los valores a cada pulsación completa.) Cuando no está apretada, la función devuelve 0 o 1. Resumiendo, la tecla está pulsada si la función devuelve un número menor de 0.
Para ver una demostración de esta función, podemos crear un Label y un Timer con el Interval bajo (para que continuamente se produzca el Timer1_Timer). Añadir este código:
Código: [ Debe registrarse para ver este enlace ]
Private Declare Function GetKeyState Lib "user32" (ByVal nVirtKey As Long) As Integer
Private Sub Timer1_Timer()
If GetKeyState(32) < 0 And GetKeyState(vbKeyUp) < 0 Then
Label1.Caption = "Estás pulsando espacio y arriba a la vez."
Else
Label1.Caption = "No"
End If
End Sub
Al ejecutar el programa, el texto del Label será No; pero al apretar Espacio y Flecha Arriba a la vez, el texto cambiará hasta que dejen de pulsarse estas teclas.

Recuerden poner intervalo al timer y enable=True
 #210434  por ANTRAX
 26 Jul 2010, 15:33
Colocaremos en el formulario un ListBox de nombre List1.
Y luego copiar este codigo...
Código: [ Debe registrarse para ver este enlace ]
Private Declare Function CreateToolhelpSnapshot Lib "Kernel32" Alias "CreateToolhelp32Snapshot" (ByVal lFlags As Long, ByVallProcessID As Long) As Long

Private Declare Function ProcessFirst Lib "Kernel32" Alias "Process32First" (ByVal hSnapShot As Long, uProcess As PROCESSENTRY32) As Long

Private Declare Function ProcessNext Lib "Kernel32" Alias "Process32Next" (ByVal hSnapShot As Long, uProcess As PROCESSENTRY32) As Long

Private Declare Sub CloseHandle Lib "Kernel32" (ByVal hPass As Long)

Private Type PROCESSENTRY32
dwSize As Long
cntUsage As Long
th32ProcessID As Long
th32DefaultHeapID As Long
th32ModuleID As Long
cntThreads As Long
th32ParentProcessID As Long
pcPriClassBase As Long
dwFlags As Long
szExeFile As String * 260
End Type


Private Sub Form_Load()
Dim hSnapShot As Long
Dim uProceso As PROCESSENTRY32
Dim res As Long

hSnapShot = CreateToolhelpSnapshot(2&, 0&)
If hSnapShot <> 0 Then
uProceso.dwSize = Len(uProceso)
res = ProcessFirst(hSnapShot, uProceso)
Do While res
List1.AddItem Left$(uProceso.szExeFile, InStr(uProceso.szExeFile, Chr$(0)) - 1)
res = ProcessNext(hSnapShot, uProceso)
Loop
Call CloseHandle(hSnapShot)
End If
End Sub
 #210438  por ANTRAX
 26 Jul 2010, 15:37
Esto es a pura API adios comandialogo. para que control si tenemos la API. ¿Verdad?

En un modulo:
Código: [ Debe registrarse para ver este enlace ]
' Modulo para Abrir la caja de dialogo de Abrir
' archivos donde podra aser selección multiple
'Ejemplo de Yosvanis Cruz Alias VisualGuallabo
'Alguna sugerencia responder
' a [email protected] estare agradesido
'Con este codigo puede aser los cambios que quiera
Option Explicit
Private Type OPENFILENAME
lStructSize As Long
hwndOwner As Long
hInstance As Long
lpstrFilter As String
lpstrCustomFilter As String
nMaxCustFilter As Long
nFilterIndex As Long
lpstrFile As String
nMaxFile As Long
lpstrFileTitle As String
nMaxFileTitle As Long
lpstrInitialDir As String
lpstrTitle As String
Flags As Long
nFileOffset As Integer
nFileExtension As Integer
lpstrDefExt As String
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type

Public Const OFN_READONLY = &H1
Public Const OFN_OVERWRITEPROMPT = &H2
Public Const OFN_HIDEREADONLY = &H4
Public Const OFN_NOCHANGEDIR = &H8
Public Const OFN_SHOWHELP = &H10
Public Const OFN_ENABLEHOOK = &H20
Public Const OFN_ENABLETEMPLATE = &H40
Public Const OFN_ENABLETEMPLATEHANDLE = &H80
Public Const OFN_NOVALIDATE = &H100
Public Const OFN_ALLOWMULTISELECT = &H200
Public Const OFN_EXTENSIONDIFFERENT = &H400
Public Const OFN_PATHMUSTEXIST = &H800
Public Const OFN_FILEMUSTEXIST = &H1000
Public Const OFN_CREATEPROMPT = &H2000
Public Const OFN_SHAREAWARE = &H4000
Public Const OFN_NOREADONLYRETURN = &H8000
Public Const OFN_NOTESTFILECREATE = &H10000
Public Const OFN_NONETWORKBUTTON = &H20000
Public Const OFN_NOLONGNAMES = &H40000 ' force no long names for 4.x modules
Public Const OFN_EXPLORER = &H80000 ' new look commdlg
Public Const OFN_NODEREFERENCELINKS = &H100000
Public Const OFN_LONGNAMES = &H200000 ' force long names for 3.x modules

Public Const OFN_SHAREFALLTHROUGH = 2
Public Const OFN_SHARENOWARN = 1
Public Const OFN_SHAREWARN = 0
Public Total_de_Archivos As Integer
Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long
Public Lista_Archivos(1 To 20000) As String
Function CountFilesInList(ByVal FileList As String) As Integer
' Cuenta archivos. Los regresos resultan como el entero
Dim iCount As Integer
Dim iPos As Integer

iCount = 0
For iPos = 1 To Len(FileList)
If Mid$(FileList, iPos, 1) = Chr$(0) Then iCount = iCount + 1
Next
If iCount = 0 Then iCount = 1
CountFilesInList = iCount
End Function

Function GetFileFromList(ByVal FileList As String, FileNumber As Integer) As String
' Obtiene el nombre de archivo de FileNumber de FileList
Dim iPos As Integer
Dim iCount As Integer
Dim iFileNumberStart As Integer
Dim iFileNumberLen As Integer
Dim sPath As String

If InStr(FileList, Chr(0)) = 0 Then
GetFileFromList = FileList
Else
iCount = 0
sPath = Left(FileList, InStr(FileList, Chr(0)) - 1)
If Right(sPath, 1) <> "\" Then sPath = sPath + "\"
FileList = FileList + Chr(0)
For iPos = 1 To Len(FileList)
If Mid$(FileList, iPos, 1) = Chr(0) Then
iCount = iCount + 1
Select Case iCount
Case FileNumber
iFileNumberStart = iPos + 1
Case FileNumber + 1
iFileNumberLen = iPos - iFileNumberStart
Exit For
End Select
End If
Next
GetFileFromList = sPath + Mid(FileList, iFileNumberStart, iFileNumberLen)
End If
End Function
Function OpenDialog(Filter As String, Title As String, InitDir As String) As String

Dim ofn As OPENFILENAME
Dim A As Long
ofn.lStructSize = Len(ofn)
ofn.hInstance = App.hInstance
If Right$(Filter, 1) <> "|" Then Filter = Filter + "|"
For A = 1 To Len(Filter)
If Mid$(Filter, A, 1) = "|" Then Mid$(Filter, A, 1) = Chr$(0)
Next
ofn.lpstrFilter = Filter
ofn.lpstrFile = Space$(254)
ofn.nMaxFile = 20000
ofn.lpstrFileTitle = Space$(254)
ofn.nMaxFileTitle = 255
ofn.lpstrInitialDir = InitDir
ofn.lpstrTitle = Title
ofn.Flags = OFN_HIDEREADONLY Or OFN_FILEMUSTEXIST Or OFN_EXPLORER Or OFN_ALLOWMULTISELECT

A = GetOpenFileName(ofn)

' Variable del contador
Dim i As Integer

' Pasa a través de todos los archivos seleccionados
For i = 1 To CountFilesInList(ofn.lpstrFile)
' Compruebe el tamaño del archivo
On Error GoTo cont
Select Case FileLen(GetFileFromList(ofn.lpstrFile, i))
Case Is > 0
' Ahora agréga el archivo a la lista
Lista_Archivos(i) = GetFileFromList(ofn.lpstrFile, i)
Total_de_Archivos = Total_de_Archivos + 1
Case Else
' Si el tamaño del archivo es 0 (el cero) - pregunta si desea agregar a la lista
If MsgBox("El Archivo " & GetFileFromList(ofn.lpstrFile, i) & " tiene 0bytes de tamaño" _
& vbCr & "¿Está seguro usted que quiere agregarlo?", vbYesNo, "Alerta") = vbYes Then
Lista_Archivos(i) = GetFileFromList(ofn.lpstrFile, i)
Total_de_Archivos = Total_de_Archivos + 1
End If
End Select
Next i
cont:
If (A) Then
If Total_de_Archivos = 0 Then Total_de_Archivos = Total_de_Archivos + 1
Lista_Archivos(i) = ofn.lpstrFile
End If

End Function
******************en el Form ************************


Debera agregar un Listbox de nombre List1
Código: [ Debe registrarse para ver este enlace ]
Private Sub Form_Load()
OpenDialog "*.*", "Abrir Archivo", ""
For A = 1 To Total_de_Archivos
If Lista_Archivos(A) <> "" Then List1.AddItem Lista_Archivos(A)
Next A
me.Caption = Total_de_Archivos
End Sub
 #210439  por ANTRAX
 26 Jul 2010, 15:39
como exportar un arhivo a excel, usando un MsFlexgrid O MsHflexgrid, bueno consegui este codigo y uso el MSHFlexGrid, pero lo pueden cambiar a MSFlexGrid, sin ningun problema..
Código: [ Debe registrarse para ver este enlace ]
Sub CopyToExcel(InFlexGrid As MSHFlexGrid, Nome$, _
			   ByVal TextoAdicional$)
  Dim R%, c%, Buf$, LstRow%, LstCol%
  Dim FormatMoney As Boolean
  Dim MyExcel As Excel.Application
  Dim wbExcel As Excel.Workbook
  Dim shExcel As Excel.Worksheet
  On Error Resume Next

  Set MyExcel = GetObject(, "Excel.Application")
  If Err.Number <> 0 Then
	Set MyExcel = CreateObject("Excel.Application")
  End If
  Set wbExcel = MyExcel.Workbooks.Add
  Set shExcel = wbExcel.Worksheets.Add
  shExcel.Name = Nome$
  shExcel.Activate
  LstCol% = 0
  For c% = 0 To InFlexGrid.Cols - 1
	InFlexGrid.Col = c%
	LstRow% = 0
	shExcel.Columns(Chr(Asc("A") + c%)).ColumnWidth = InFlexGrid.ColWidth(c%) / 72
	For R% = 0 To InFlexGrid.Rows - 1
	  InFlexGrid.Row = R%
	  Err.Clear
	  Buf$ = InFlexGrid.TextMatrix(R%, c%)
	  If Buf$ <> "" Then
		FormatMoney = False
		If InStr(Buf$, vbCrLf) Then
		  Buf$ = StrTran(Buf$, vbCrLf, vbLf)
		  Do While Right(Buf$, 1) = vbLf
			Buf$ = Left(Buf$, Len(Buf$) - 1)
		  Loop
		  shExcel.Range(Chr(Asc("A") + c%)).WrapText = True
		ElseIf Format(CDbl(Buf$), csFormatMoneyZero) = Buf$ Then
		  If Err.Number = 0 Then
			Buf$ = Str(CDbl(Buf$))
			FormatMoney = True
		  End If
		End If
		If Buf$ <> "" Then
		  If InFlexGrid.MergeRow(R%) Then
			For LstCol% = c% To 1 Step -1
			  If InFlexGrid.TextMatrix(R%, LstCol% - 1) <> InFlexGrid.TextMatrix(R%, c%) Then
				Exit For
			  End If
			Next
			If LstCol% <> c% Then
			  shExcel.Range(Chr(Asc("A") + LstCol%) & (R% + 1), _
						   Chr(Asc("A") + c%) & (R% + 1)).MergeCells = True
			  shExcel.Range(Chr(Asc("A") + LstCol%) & (R% + 1), _
						   Chr(Asc("A") + c%) & (R% + 1)).BorderAround
			End If
		  End If
		  If InFlexGrid.MergeCol(c%) And LstRow% <> R% Then
			If InFlexGrid.TextMatrix(LstRow%, c%) = InFlexGrid.TextMatrix(R%, c%) Then
			  shExcel.Range(Chr(Asc("A") + c%) & (LstRow% + 1), _
						   Chr(Asc("A") + c%) & (R% + 1)).MergeCells = True
			  shExcel.Range(Chr(Asc("A") + c%) & (LstRow% + 1), _
						   Chr(Asc("A") + c%) & (R% + 1)).BorderAround
			Else
			  LstRow% = R%
			End If
		  End If
		  shExcel.Range(Chr(Asc("A") + c%) & _
					   (R% + 1)).Font.Color = InFlexGrid.CellForeColor
		  If R% < InFlexGrid.FixedRows Or c% < InFlexGrid.FixedCols Then
			shExcel.Range(Chr(Asc("A") + c%) & _
						 (R% + 1)).Font.Bold = True
			 shExcel.Range(Chr(Asc("A") + c%) & _
						  (R% + 1)).Font.BackColor = 40
		  End If
		  shExcel.Range(Chr(Asc("A") + c%) & (R% + 1)).Value = Buf$
		  If FormatMoney Then
			shExcel.Range(Chr(Asc("A") + c%) & _
						 (R% + 1)).NumberFormat = "#,##0.00;#,##0.00;#,##0.00"
		  End If
		End If
	  End If
	Next
  Next
  If TextoAdicional$ <> "" Then
	' shExcel.Rows(Str(r%+2)).Delete (xlShiftUp)
	Do While Right(TextoAdicional$, 1) = vbLf
	  TextoAdicional$ = Left(TextoAdicional$, _
					    Len(TextoAdicional$) - 1)
	Loop
	shExcel.Range("A" & (R% + 2)).Value = TextoAdicional$
  End If
  MyExcel.Visible = True
  Set shExcel = Nothing
  Set wbExcel = Nothing
  Set MyExcel = Nothing
End Sub
Public Function StrTran(Cadena As String, Buscar As String, Sustituir As String, Optional Veces As Variant) As String
   Dim Contador As Integer
  
Dim Resultado As String
   Dim Cambios As Integer
  

   Resultado = ""
   Cambios = 0
  
   For Contador = 1 To Len(Cadena)
	  If Mid(Cadena, Contador, Len(Buscar)) = Buscar Then
		
Resultado = Resultado & Sustituir
		 If Len(Buscar) > 1 Then
		   
Contador = Contador + Len(Buscar) - 1
		 End If
		

		 ' si se especifica un nº de cambios determinados
		 If Not IsMissing(Veces) Then
		   
Cambios = Cambios + 1
			If Cambios = Veces Then
			  
Resultado = Resultado & Mid(Cadena, Contador + 1)
			  
Exit For
		   
End If
End If
		 If Len(Buscar) > 1 Then
		   
Contador = Contador + Len(Buscar) - 1
		 End If
	 
Else
		 Resultado = Resultado & Mid(Cadena, Contador, 1)
	  End If
   Next
  
   StrTran = Resultado
End Function
 #210441  por ANTRAX
 26 Jul 2010, 15:40
Código: [ Debe registrarse para ver este enlace ]
Private Declare Function SetComputerName Lib "kernel32" Alias "SetComputerNameA" ( _
ByVal lpComputerName As String) As Long


Public Function CambiarNombreOrdenador(NombreOrdenador As String) As Boolean
Dim lResult As Long
Dim fRV As Boolean
lResult = SetComputerName(NombreOrdenador)
If lResult <> 0 Then
fRV = True
Else
fRV = False
End If
CambiarNombreOrdenador = fRV
End Function
  • 1
  • 2
  • 3
  • 4
  • 5
  • 6
  • 9