Biblioteca de programas

[Cagalas]

bueno no se si ya este esto pero lo voy a poner varios programas solo para compiral y que los modifiquen a su gusto y aprendan
bueno tamien hay que hacerle la contra al changarro de ranefi de su "biblioteca de codigos " que es eso no no no jaja saludos ranefi  jajaja bueno hay que quebrar su changarro le are la contra
jaja no es cierto bueno

TODO ESTA EN VISUAL BASIC

SCANER DE PUERTOS

requerimientos que se nececita okasssss

1.-agregamos 4 textbox (cajas de texto)
2.-agregamos 3 commandbutton (botones)
3.-agregamos un winsock
4.-agregamos un timer
5.-agremamos para terminar un maldito listbox(cajita de listita)
NOTA ya ustedes ponganle mas cositas para que sevea mas bonito y explique cada cosa solo digo hay veen ustedes que p2

Código:

Dim port As Integer     '======================================
Dim X As Long            '= declaramos las malditas variables  =
                                     '======================================
                       
                       
Private Sub Command1_Click()
  Command1.Enabled = False 'deshbilitamos el maldito btoton command1
  Command2.Enabled = True  'habilitamos el maldito boton command2
                     
    Text4 = "0"   'nombramos la caja de texto 4 con el maldito numero 0
    Text3 = "0"   'igual que el de arriba pero con la maldita caja de texto 3
   
Timer1.Enabled = True  'habilitamos el timer1

End Sub

Private Sub Command2_Click()
        Command2.Enabled = False  'deshabilitamos el maldito boton2
    port = X  'declaramos que la variables para cancelar
Timer1.Enabled = False 'dehabilitamos el timer para poder cancelar
End Sub

Private Sub Command3_Click()
    Unload Me  'recargamos el maldito formulario
End Sub

Private Sub Form_Load()
        Text1.Enabled = False       '=======================================
        Text3.Enabled = False '== = bloqueamos las cajas de texto 1,2y4 =
        Text4.Enabled = False       '=======================================
             
             Text1.Text = ""  'limpiamos la maldita caja de texto
             Text2.Text = "10000" 'le ponemos la cantidad de 10000 a la caja
                                  'de text2
             Text3.Text = "0"  'le ponemos a 0 la caja de text3
             Text4.Text = "0"  'igual que el de arriba
Timer1.Interval = 1  'le ponemos el interval a 1 ya que viene el timer
                    'por defecto a 0
Timer1.Enabled = False   'deshabilitamos el maldito timer1
    Winsock1.Connect     'conectamos el winsockkkkkkk ajua
    Text1 = Winsock1.LocalIP  'para que la caja de texto 1 adopte nuestra ip
       
    Command2.Enabled = False  'deshabilitamos el maldito boton 2

End Sub
Private Sub Form_Unload(Cancel As Integer)     '==============================
    Dim Salir As String                                          '=preguntar antes de salir                            =
                                                                             '=TOMADO DE LA BIBLIOTECA DE  =
                                                                             '=CODIGOS DE RANEFIIIII                    =
                                                                             '==============================
Salir = MsgBox("    ¿EN REALIDAD QUIERE SALIR?", _
vbQuestion + vbYesNo + vbDefaultButton2, "SALIR")
       
If Salir <> 6 Then Cancel = True
End Sub

Private Sub Timer1_Timer()
    X = Text2.Text  'se declara para colocar un numero x de va variable guardada
    For port = 1 To X 'declaramos variables
    Text3 = port       'declaramos variables
    Winsock1.Close     'cerramos el winsock
        Winsock1.Connect Text1.Text, port  'el winosck conectara con lo escrito
                                           'en la caja de texto 1
    DoEvents
Next                    'seguiremos con el elvento al tarminar
  MsgBox "FINALIZO EL ESCANEADO LOS PUERTOS", vbInformation, "CALIGASTIA SCAN"
    'soltamos el mensage al terminar
   
    Command1.Enabled = True 'habilitamos el maldito boton 1
                            'ya que estava deshabiltado recuerdan cochinostes
   
Timer1.Enabled = False   'deshabilitamos el maldito timer

End Sub

Private Sub Winsock1_Connect() 'para conectar el winosck
   List1.AddItem ("Puerto Abierto : " & Winsock1.RemotePort) 'llenamos el list
   Winsock1.Close  'cerramos el winsock
   
Text4 = Text4 + 1  'el maldito texto de la caja de texto4
                   'sera siempre mas uno
End Sub

bueno no les pongo mas por que ya me cance de escribir baaaaaaaa
les pondre uno diario o cuando peda okas
hasta pronto cochinotes


ha y ranefi jijijijiiji ya te quebrare tu changarro baaa jaja no te creas pura bromitas nadamas
salu2

[Cagalas]

CALIGASTIA DE MIRON

marcar: para buscar el nomnbre de alguna PC colocando solamente la ip en una caja de texto

REQUERIMOS

1.-dos cajas de texto
2.-un commandbutton (boton)
3.-un modulo

nombres

el modulo va con la propiedad de nombre WSKSOCK


este codigo va en los forms

Código:

Dim texto As String
Private Sub Command1_Click()
   
StartWinsock "Winsock"
   Text1.Text = IpToAddr(Text2.Text)
   EndWinsock
End Sub

Private Sub Form_Load()
Text1.Enabled = False
Text1.Text = ""
Text2.Text = "ACA LA IP COCHINOTES"

      StartWinsock texto
End Sub
Private Sub Form_Unload(Cancel As Integer)
   EndWinsock
End Sub

este codigo va en el modulo con nombre WSKSOCK

Código:

Option Explicit

Public Const FD_SETSIZE = 64

Type fd_set
    fd_count As Integer
    fd_array(FD_SETSIZE) As Integer
End Type

Type timeval
    tv_sec As Long
    tv_usec As Long
End Type

Type HostEnt
    h_name As Long
    h_aliases As Long
    h_addrtype As Integer
    h_length As Integer
    h_addr_list As Long
End Type

Public Const hostent_size = 16

Type servent
    s_name As Long
    s_aliases As Long
    s_port As Integer
    s_proto As Long
End Type

Public Const servent_size = 14

Type protoent
    p_name As Long
    p_aliases As Long
    p_proto As Integer
End Type

Public Const protoent_size = 10
Public Const IPPROTO_TCP = 6
Public Const IPPROTO_UDP = 17
Public Const INADDR_NONE = &HFFFF
Public Const INADDR_ANY = &H0

Type sockaddr
    sin_family As Integer
    sin_port As Integer
    sin_addr As Long
    sin_zero As String * 8
End Type

Public Const sockaddr_size = 16
Public saZero As sockaddr
Public Const WSA_DESCRIPTIONLEN = 256
Public Const WSA_DescriptionSize = WSA_DESCRIPTIONLEN + 1
Public Const WSA_SYS_STATUS_LEN = 128
Public Const WSA_SysStatusSize = WSA_SYS_STATUS_LEN + 1

Type WSADataType
    wVersion As Integer
    wHighVersion As Integer
    szDescription As String * WSA_DescriptionSize
    szSystemStatus As String * WSA_SysStatusSize
    iMaxSockets As Integer
    iMaxUdpDg As Integer
    lpVendorInfo As Long
End Type

Public Const INVALID_SOCKET = -1
Public Const SOCKET_ERROR = -1
Public Const SOCK_STREAM = 1
Public Const SOCK_DGRAM = 2
Public Const MAXGETHOSTSTRUCT = 1024
Public Const AF_INET = 2
Public Const PF_INET = 2

Type LingerType
    l_onoff As Integer
    l_linger As Integer
End Type

Global Const WSAEINTR = 10004
Global Const WSAEBADF = 10009
Global Const WSAEACCES = 10013
Global Const WSAEFAULT = 10014
Global Const WSAEINVAL = 10022
Global Const WSAEMFILE = 10024

Global Const WSAEWOULDBLOCK = 10035
Global Const WSAEINPROGRESS = 10036
Global Const WSAEALREADY = 10037
Global Const WSAENOTSOCK = 10038
Global Const WSAEDESTADDRREQ = 10039
Global Const WSAEMSGSIZE = 10040
Global Const WSAEPROTOTYPE = 10041
Global Const WSAENOPROTOOPT = 10042
Global Const WSAEPROTONOSUPPORT = 10043
Global Const WSAESOCKTNOSUPPORT = 10044
Global Const WSAEOPNOTSUPP = 10045
Global Const WSAEPFNOSUPPORT = 10046
Global Const WSAEAFNOSUPPORT = 10047
Global Const WSAEADDRINUSE = 10048
Global Const WSAEADDRNOTAVAIL = 10049
Global Const WSAENETDOWN = 10050
Global Const WSAENETUNREACH = 10051
Global Const WSAENETRESET = 10052
Global Const WSAECONNABORTED = 10053
Global Const WSAECONNRESET = 10054
Global Const WSAENOBUFS = 10055
Global Const WSAEISCONN = 10056
Global Const WSAENOTCONN = 10057
Global Const WSAESHUTDOWN = 10058
Global Const WSAETOOMANYREFS = 10059
Global Const WSAETIMEDOUT = 10060
Global Const WSAECONNREFUSED = 10061
Global Const WSAELOOP = 10062
Global Const WSAENAMETOOLONG = 10063
Global Const WSAEHOSTDOWN = 10064
Global Const WSAEHOSTUNREACH = 10065
Global Const WSAENOTEMPTY = 10066
Global Const WSAEPROCLIM = 10067
Global Const WSAEUSERS = 10068
Global Const WSAEDQUOT = 10069
Global Const WSAESTALE = 10070
Global Const WSAEREMOTE = 10071

Global Const WSASYSNOTREADY = 10091
Global Const WSAVERNOTSUPPORTED = 10092
Global Const WSANOTINITIALISED = 10093
Global Const WSAHOST_NOT_FOUND = 11001
Global Const WSATRY_AGAIN = 11002
Global Const WSANO_RECOVERY = 11003
Global Const WSANO_DATA = 11004
Global Const WSANO_ADDRESS = 11004

    Public Const FIONREAD = &H8004667F
    Public Const FIONBIO = &H8004667E
    Public Const FIOASYNC = &H8004667D

#If Win16 Then
    Public Declare Function PostMessage Lib "User" (ByVal hWnd As Integer, ByVal wMsg As Integer, ByVal wParam As Integer, lParam As Any) As Integer
    Public Declare Sub MemCopy Lib "Kernel" Alias "hmemcpy" (Dest As Any, Src As Any, ByVal cb&)
    Public Declare Function lstrlen Lib "Kernel" (ByVal lpString As Any) As Integer

    Public Const SOL_SOCKET = &HFFFF
    Public Const SO_LINGER = &H80
    Public Const FD_READ = &H1
    Public Const FD_WRITE = &H2
    Public Const FD_OOB = &H4
    Public Const FD_ACCEPT = &H8
    Public Const FD_CONNECT = &H10
    Public Const FD_CLOSE = &H20

    Public Declare Function accept Lib "Winsock.dll" (ByVal s As Integer, addr As sockaddr, addrlen As Integer) As Integer
    Public Declare Function bind Lib "Winsock.dll" (ByVal s As Integer, addr As sockaddr, ByVal namelen As Integer) As Integer
    Public Declare Function closesocket Lib "Winsock.dll" (ByVal s As Integer) As Integer
    Public Declare Function connect Lib "Winsock.dll" (ByVal s As Integer, addr As sockaddr, ByVal namelen As Integer) As Integer
    Public Declare Function ioctlsocket Lib "Winsock.dll" (ByVal s As Integer, ByVal cmd As Long, argp As Long) As Integer
    Public Declare Function getpeername Lib "Winsock.dll" (ByVal s As Integer, sName As sockaddr, namelen As Integer) As Integer
    Public Declare Function getsockname Lib "Winsock.dll" (ByVal s As Integer, sName As sockaddr, namelen As Integer) As Integer
    Public Declare Function getsockopt Lib "Winsock.dll" (ByVal s As Integer, ByVal level As Integer, ByVal optname As Integer, optval As Any, optlen As Integer) As Integer
    Public Declare Function htonl Lib "Winsock.dll" (ByVal hostlong As Long) As Long
    Public Declare Function htons Lib "Winsock.dll" (ByVal hostshort As Integer) As Integer
    Public Declare Function inet_addr Lib "Winsock.dll" (ByVal cp As String) As Long
    Public Declare Function inet_ntoa Lib "Winsock.dll" (ByVal inn As Long) As Long
    Public Declare Function listen Lib "Winsock.dll" (ByVal s As Integer, ByVal backlog As Integer) As Integer
    Public Declare Function ntohl Lib "Winsock.dll" (ByVal netlong As Long) As Long
    Public Declare Function ntohs Lib "Winsock.dll" (ByVal netshort As Integer) As Integer
    Public Declare Function recv Lib "Winsock.dll" (ByVal s As Integer, ByVal buf As Any, ByVal buflen As Integer, ByVal flags As Integer) As Integer
    Public Declare Function recvfrom Lib "Winsock.dll" (ByVal s As Integer, buf As Any, ByVal buflen As Integer, ByVal flags As Integer, from As sockaddr, fromlen As Integer) As Integer
    Public Declare Function ws_select Lib "Winsock.dll" Alias "select" (ByVal nfds As Integer, readfds As Any, writefds As Any, exceptfds As Any, timeout As timeval) As Integer
    Public Declare Function send Lib "Winsock.dll" (ByVal s As Integer, buf As Any, ByVal buflen As Integer, ByVal flags As Integer) As Integer
    Public Declare Function sendto Lib "Winsock.dll" (ByVal s As Integer, buf As Any, ByVal buflen As Integer, ByVal flags As Integer, to_addr As sockaddr, ByVal tolen As Integer) As Integer
    Public Declare Function setsockopt Lib "Winsock.dll" (ByVal s As Integer, ByVal level As Integer, ByVal optname As Integer, optval As Any, ByVal optlen As Integer) As Integer
    Public Declare Function ShutDown Lib "Winsock.dll" Alias "shutdown" (ByVal s As Integer, ByVal how As Integer) As Integer
    Public Declare Function socket Lib "Winsock.dll" (ByVal af As Integer, ByVal s_type As Integer, ByVal protocol As Integer) As Integer

    Public Declare Function gethostbyaddr Lib "Winsock.dll" (addr As Long, ByVal addr_len As Integer, ByVal addr_type As Integer) As Long
    Public Declare Function gethostbyname Lib "Winsock.dll" (ByVal host_name As String) As Long
    Public Declare Function gethostname Lib "Winsock.dll" (ByVal host_name As String, ByVal namelen As Integer) As Integer
    Public Declare Function getservbyport Lib "Winsock.dll" (ByVal Port As Integer, ByVal proto As String) As Long
    Public Declare Function getservbyname Lib "Winsock.dll" (ByVal serv_name As String, ByVal proto As String) As Long
    Public Declare Function getprotobynumber Lib "Winsock.dll" (ByVal proto As Integer) As Long
    Public Declare Function getprotobyname Lib "Winsock.dll" (ByVal proto_name As String) As Long

    Public Declare Function WSAStartup Lib "Winsock.dll" (ByVal wVR As Integer, lpWSAD As WSADataType) As Integer
    Public Declare Function WSACleanup Lib "Winsock.dll" () As Integer
    Public Declare Sub WSASetLastError Lib "Winsock.dll" (ByVal iError As Integer)
    Public Declare Function WSAGetLastError Lib "Winsock.dll" () As Integer
    Public Declare Function WSAIsBlocking Lib "Winsock.dll" () As Integer
    Public Declare Function WSAUnhookBlockingHook Lib "Winsock.dll" () As Integer
    Public Declare Function WSASetBlockingHook Lib "Winsock.dll" (ByVal lpBlockFunc As Long) As Long
    Public Declare Function WSACancelBlockingCall Lib "Winsock.dll" () As Integer
    Public Declare Function WSAAsyncGetServByName Lib "Winsock.dll" (ByVal hWnd As Integer, ByVal wMsg As Integer, ByVal serv_name As String, ByVal proto As String, buf As Any, ByVal buflen As Integer) As Integer
    Public Declare Function WSAAsyncGetServByPort Lib "Winsock.dll" (ByVal hWnd As Integer, ByVal wMsg As Integer, ByVal Port As Integer, ByVal proto As String, buf As Any, ByVal buflen As Integer) As Integer
    Public Declare Function WSAAsyncGetProtoByName Lib "Winsock.dll" (ByVal hWnd As Integer, ByVal wMsg As Integer, ByVal proto_name As String, buf As Any, ByVal buflen As Integer) As Integer
    Public Declare Function WSAAsyncGetProtoByNumber Lib "Winsock.dll" (ByVal hWnd As Integer, ByVal wMsg As Integer, ByVal number As Integer, buf As Any, ByVal buflen As Integer) As Integer
    Public Declare Function WSAAsyncGetHostByName Lib "Winsock.dll" (ByVal hWnd As Integer, ByVal wMsg As Integer, ByVal host_name As String, buf As Any, ByVal buflen As Integer) As Integer
    Public Declare Function WSAAsyncGetHostByAddr Lib "Winsock.dll" (ByVal hWnd As Integer, ByVal wMsg As Integer, addr As Long, ByVal addr_len As Integer, ByVal addr_type As Integer, buf As Any, ByVal buflen As Integer) As Integer
    Public Declare Function WSACancelAsyncRequest Lib "Winsock.dll" (ByVal hAsyncTaskHandle As Integer) As Integer
    Public Declare Function WSAAsyncSelect Lib "Winsock.dll" (ByVal s As Integer, ByVal hWnd As Integer, ByVal wMsg As Integer, ByVal lEvent As Long) As Integer
    Public Declare Function WSARecvEx Lib "Winsock.dll" (ByVal s As Integer, buf As Any, ByVal buflen As Integer, ByVal flags As Integer) As Integer

#ElseIf Win32 Then
    Public Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Public Declare Sub MemCopy Lib "kernel32" Alias "RtlMoveMemory" (Dest As Any, Src As Any, ByVal cb&)
    Public Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As Any) As Long

    Public Const SOL_SOCKET = &HFFFF&
    Public Const SO_LINGER = &H80&
    Public Const FD_READ = &H1&
    Public Const FD_WRITE = &H2&
    Public Const FD_OOB = &H4&
    Public Const FD_ACCEPT = &H8&
    Public Const FD_CONNECT = &H10&
    Public Const FD_CLOSE = &H20&

    Public Declare Function accept Lib "wsock32.dll" (ByVal s As Long, addr As sockaddr, addrlen As Long) As Long
    Public Declare Function bind Lib "wsock32.dll" (ByVal s As Long, addr As sockaddr, ByVal namelen As Long) As Long
    Public Declare Function closesocket Lib "wsock32.dll" (ByVal s As Long) As Long
    Public Declare Function connect Lib "wsock32.dll" (ByVal s As Long, addr As sockaddr, ByVal namelen As Long) As Long
    Public Declare Function ioctlsocket Lib "wsock32.dll" (ByVal s As Long, ByVal cmd As Long, argp As Long) As Long
    Public Declare Function getpeername Lib "wsock32.dll" (ByVal s As Long, sName As sockaddr, namelen As Long) As Long
    Public Declare Function getsockname Lib "wsock32.dll" (ByVal s As Long, sName As sockaddr, namelen As Long) As Long
    Public Declare Function getsockopt Lib "wsock32.dll" (ByVal s As Long, ByVal level As Long, ByVal optname As Long, optval As Any, optlen As Long) As Long
    Public Declare Function htonl Lib "wsock32.dll" (ByVal hostlong As Long) As Long
    Public Declare Function htons Lib "wsock32.dll" (ByVal hostshort As Long) As Integer
    Public Declare Function inet_addr Lib "wsock32.dll" (ByVal cp As String) As Long
    Public Declare Function inet_ntoa Lib "wsock32.dll" (ByVal inn As Long) As Long
    Public Declare Function listen Lib "wsock32.dll" (ByVal s As Long, ByVal backlog As Long) As Long
    Public Declare Function ntohl Lib "wsock32.dll" (ByVal netlong As Long) As Long
    Public Declare Function ntohs Lib "wsock32.dll" (ByVal netshort As Long) As Integer
    Public Declare Function recv Lib "wsock32.dll" (ByVal s As Long, ByVal buf As Any, ByVal buflen As Long, ByVal flags As Long) As Long
    Public Declare Function recvfrom Lib "wsock32.dll" (ByVal s As Long, buf As Any, ByVal buflen As Long, ByVal flags As Long, from As sockaddr, fromlen As Long) As Long
    Public Declare Function ws_select Lib "wsock32.dll" Alias "select" (ByVal nfds As Long, readfds As fd_set, writefds As fd_set, exceptfds As fd_set, timeout As timeval) As Long
    Public Declare Function send Lib "wsock32.dll" (ByVal s As Long, buf As Any, ByVal buflen As Long, ByVal flags As Long) As Long
    Public Declare Function sendto Lib "wsock32.dll" (ByVal s As Long, buf As Any, ByVal buflen As Long, ByVal flags As Long, to_addr As sockaddr, ByVal tolen As Long) As Long
    Public Declare Function setsockopt Lib "wsock32.dll" (ByVal s As Long, ByVal level As Long, ByVal optname As Long, optval As Any, ByVal optlen As Long) As Long
    Public Declare Function ShutDown Lib "wsock32.dll" Alias "shutdown" (ByVal s As Long, ByVal how As Long) As Long
    Public Declare Function socket Lib "wsock32.dll" (ByVal af As Long, ByVal s_type As Long, ByVal protocol As Long) As Long

    Public Declare Function gethostbyaddr Lib "wsock32.dll" (addr As Long, ByVal addr_len As Long, ByVal addr_type As Long) As Long
    Public Declare Function gethostbyname Lib "wsock32.dll" (ByVal host_name As String) As Long
    Public Declare Function gethostname Lib "wsock32.dll" (ByVal host_name As String, ByVal namelen As Long) As Long
    Public Declare Function getservbyport Lib "wsock32.dll" (ByVal Port As Long, ByVal proto As String) As Long
    Public Declare Function getservbyname Lib "wsock32.dll" (ByVal serv_name As String, ByVal proto As String) As Long
    Public Declare Function getprotobynumber Lib "wsock32.dll" (ByVal proto As Long) As Long
    Public Declare Function getprotobyname Lib "wsock32.dll" (ByVal proto_name As String) As Long

    Public Declare Function WSAStartup Lib "wsock32.dll" (ByVal wVR As Long, lpWSAD As WSADataType) As Long
    Public Declare Function WSACleanup Lib "wsock32.dll" () As Long
    Public Declare Sub WSASetLastError Lib "wsock32.dll" (ByVal iError As Long)
    Public Declare Function WSAGetLastError Lib "wsock32.dll" () As Long
    Public Declare Function WSAIsBlocking Lib "wsock32.dll" () As Long
    Public Declare Function WSAUnhookBlockingHook Lib "wsock32.dll" () As Long
    Public Declare Function WSASetBlockingHook Lib "wsock32.dll" (ByVal lpBlockFunc As Long) As Long
    Public Declare Function WSACancelBlockingCall Lib "wsock32.dll" () As Long
    Public Declare Function WSAAsyncGetServByName Lib "wsock32.dll" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal serv_name As String, ByVal proto As String, buf As Any, ByVal buflen As Long) As Long
    Public Declare Function WSAAsyncGetServByPort Lib "wsock32.dll" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal Port As Long, ByVal proto As String, buf As Any, ByVal buflen As Long) As Long
    Public Declare Function WSAAsyncGetProtoByName Lib "wsock32.dll" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal proto_name As String, buf As Any, ByVal buflen As Long) As Long
    Public Declare Function WSAAsyncGetProtoByNumber Lib "wsock32.dll" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal number As Long, buf As Any, ByVal buflen As Long) As Long
    Public Declare Function WSAAsyncGetHostByName Lib "wsock32.dll" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal host_name As String, buf As Any, ByVal buflen As Long) As Long
    Public Declare Function WSAAsyncGetHostByAddr Lib "wsock32.dll" (ByVal hWnd As Long, ByVal wMsg As Long, addr As Long, ByVal addr_len As Long, ByVal addr_type As Long, buf As Any, ByVal buflen As Long) As Long
    Public Declare Function WSACancelAsyncRequest Lib "wsock32.dll" (ByVal hAsyncTaskHandle As Long) As Long
    Public Declare Function WSAAsyncSelect Lib "wsock32.dll" (ByVal s As Long, ByVal hWnd As Long, ByVal wMsg As Long, ByVal lEvent As Long) As Long
    Public Declare Function WSARecvEx Lib "wsock32.dll" (ByVal s As Long, buf As Any, ByVal buflen As Long, ByVal flags As Long) As Long
#End If

Public MySocket%
Public SockReadBuffer$
Public Const WSA_NoName = "Unknown"
Public WSAStartedUp As Boolean

Public Function WSAGetAsyncBufLen(ByVal lParam As Long) As Long
    If (lParam And &HFFFF&) > &H7FFF Then
        WSAGetAsyncBufLen = (lParam And &HFFFF&) - &H10000
    Else
        WSAGetAsyncBufLen = lParam And &HFFFF&
    End If
End Function
Public Function WSAGetSelectEvent(ByVal lParam As Long) As Integer
    If (lParam And &HFFFF&) > &H7FFF Then
        WSAGetSelectEvent = (lParam And &HFFFF&) - &H10000
    Else
        WSAGetSelectEvent = lParam And &HFFFF&
    End If
End Function
Public Function WSAGetAsyncError(ByVal lParam As Long) As Integer
    WSAGetAsyncError = (lParam And &HFFFF0000) \ &H10000
End Function
Public Function AddrToIP(ByVal AddrOrIP$) As String
    AddrToIP$ = GetAscIP(GetHostByNameAlias(AddrOrIP$))
End Function
#If Win16 Then
    Function ConnectSock(ByVal Host$, ByVal Port%, retIpPort$, ByVal HWndToMsg%, ByVal Async%) As Integer
    Dim s%, SelectOps%, dummy%
#ElseIf Win32 Then
    Function ConnectSock(ByVal Host$, ByVal Port&, retIpPort$, ByVal HWndToMsg&, ByVal Async%) As Long
    Dim s&, SelectOps&, dummy&
#End If
    Dim sockin As sockaddr
    SockReadBuffer$ = ""
    sockin = saZero
    sockin.sin_family = AF_INET
    sockin.sin_port = htons(Port)
    If sockin.sin_port = INVALID_SOCKET Then
        ConnectSock = INVALID_SOCKET
        Exit Function
    End If
    sockin.sin_addr = GetHostByNameAlias(Host$)
    If sockin.sin_addr = INADDR_NONE Then
        ConnectSock = INVALID_SOCKET
        Exit Function
    End If
    retIpPort$ = GetAscIP$(sockin.sin_addr) & ":" & ntohs(sockin.sin_port)
    s = socket(PF_INET, SOCK_STREAM, IPPROTO_TCP)
    If s < 0 Then
        ConnectSock = INVALID_SOCKET
        Exit Function
    End If
    If SetSockLinger(s, 1, 0) = SOCKET_ERROR Then
        If s > 0 Then
            dummy = closesocket(s)
        End If
        ConnectSock = INVALID_SOCKET
        Exit Function
    End If
    If Not Async Then
        If Not connect(s, sockin, sockaddr_size) = 0 Then
            If s > 0 Then
                dummy = closesocket(s)
            End If
            ConnectSock = INVALID_SOCKET
            Exit Function
        End If
        If HWndToMsg <> 0 Then
            SelectOps = FD_READ Or FD_WRITE Or FD_CONNECT Or FD_CLOSE
            If WSAAsyncSelect(s, HWndToMsg, ByVal 1025, ByVal SelectOps) Then
                If s > 0 Then
                    dummy = closesocket(s)
                End If
                ConnectSock = INVALID_SOCKET
                Exit Function
            End If
        End If
    Else
        SelectOps = FD_READ Or FD_WRITE Or FD_CONNECT Or FD_CLOSE
        If WSAAsyncSelect(s, HWndToMsg, ByVal 1025, ByVal SelectOps) Then
            If s > 0 Then
                dummy = closesocket(s)
            End If
            ConnectSock = INVALID_SOCKET
            Exit Function
        End If
        If connect(s, sockin, sockaddr_size) <> -1 Then
            If s > 0 Then
                dummy = closesocket(s)
            End If
            ConnectSock = INVALID_SOCKET
            Exit Function
        End If
    End If
    ConnectSock = s
End Function
#If Win32 Then
    Public Function SetSockLinger(ByVal SockNum&, ByVal OnOff%, ByVal LingerTime%) As Long
#Else
    Public Function SetSockLinger(ByVal SockNum%, ByVal OnOff%, ByVal LingerTime%) As Integer
#End If
    Dim Linger As LingerType
    Linger.l_onoff = OnOff
    Linger.l_linger = LingerTime
    If setsockopt(SockNum, SOL_SOCKET, SO_LINGER, Linger, 4) Then
        Debug.Print "Error setting linger info: " & WSAGetLastError()
        SetSockLinger = SOCKET_ERROR
    Else
        If getsockopt(SockNum, SOL_SOCKET, SO_LINGER, Linger, 4) Then
            Debug.Print "Error getting linger info: " & WSAGetLastError()
            SetSockLinger = SOCKET_ERROR
        Else
            Debug.Print "Linger is on if nonzero: "; Linger.l_onoff
            Debug.Print "Linger time if linger is on: "; Linger.l_linger
        End If
    End If
End Function
Sub EndWinsock()
    Dim ret&
    If WSAIsBlocking() Then
        ret = WSACancelBlockingCall()
    End If
    ret = WSACleanup()
    WSAStartedUp = False
    Debug.Print "Winsock Down!"
End Sub
Public Function GetAscIP(ByVal inn As Long) As String
    #If Win32 Then
        Dim nStr&
    #Else
        Dim nStr%
    #End If
    Dim lpStr&
    Dim retString$
    retString = String(32, 0)
    lpStr = inet_ntoa(inn)
    If lpStr Then
        nStr = lstrlen(lpStr)
        If nStr > 32 Then nStr = 32
        MemCopy ByVal retString, ByVal lpStr, nStr
        retString = Left(retString, nStr)
        GetAscIP = retString
    Else
        GetAscIP = "255.255.255.255"
    End If
End Function
Public Function GetHostByAddress(ByVal addr As Long) As String
    Dim phe&, ret&
    Dim heDestHost As HostEnt
    Dim HostName$
    phe = gethostbyaddr(addr, 4, PF_INET)
    If phe Then
        MemCopy heDestHost, ByVal phe, hostent_size
        HostName = String(256, 0)
        MemCopy ByVal HostName, ByVal heDestHost.h_name, 256
        GetHostByAddress = Left(HostName, InStr(HostName, Chr(0)) - 1)
    Else
        GetHostByAddress = WSA_NoName
    End If
End Function
Public Function GetHostByNameAlias(ByVal HostName$) As Long
    Dim phe&
    Dim heDestHost As HostEnt
    Dim addrList&
    Dim retIP&
    retIP = inet_addr(HostName$)
    If retIP = INADDR_NONE Then
        phe = gethostbyname(HostName$)
        If phe <> 0 Then
            MemCopy heDestHost, ByVal phe, hostent_size
            MemCopy addrList, ByVal heDestHost.h_addr_list, 4
            MemCopy retIP, ByVal addrList, heDestHost.h_length
        Else
            retIP = INADDR_NONE
        End If
    End If
    GetHostByNameAlias = retIP
End Function
Public Function GetLocalHostName() As String
    Dim sName$
    sName = String(256, 0)
    If gethostname(sName, 256) Then
        sName = WSA_NoName
    Else
        If InStr(sName, Chr(0)) Then
            sName = Left(sName, InStr(sName, Chr(0)) - 1)
        End If
    End If
    GetLocalHostName = sName
End Function
#If Win16 Then
    Public Function GetPeerAddress(ByVal s%) As String
    Dim addrlen%
#ElseIf Win32 Then
    Public Function GetPeerAddress(ByVal s&) As String
    Dim addrlen&
#End If
    Dim sa As sockaddr
    addrlen = sockaddr_size
    If getpeername(s, sa, addrlen) Then
        GetPeerAddress = ""
    Else
        GetPeerAddress = SockAddressToString(sa)
    End If
End Function
#If Win16 Then
    Public Function GetPortFromString(ByVal PortStr$) As Integer
#ElseIf Win32 Then
    Public Function GetPortFromString(ByVal PortStr$) As Long
#End If
    If Val(PortStr$) > 32767 Then
        GetPortFromString = CInt(Val(PortStr$) - &H10000)
    Else
        GetPortFromString = Val(PortStr$)
    End If
    If Err Then GetPortFromString = 0
End Function
#If Win16 Then
    Function GetProtocolByName(ByVal protocol$) As Integer
    Dim tmpShort%
#ElseIf Win32 Then
    Function GetProtocolByName(ByVal protocol$) As Long
    Dim tmpShort&
#End If
    Dim ppe&
    Dim peDestProt As protoent
    ppe = getprotobyname(protocol)
    If ppe Then
        MemCopy peDestProt, ByVal ppe, protoent_size
        GetProtocolByName = peDestProt.p_proto
    Else
        tmpShort = Val(protocol)
        If tmpShort Then
            GetProtocolByName = htons(tmpShort)
        Else
            GetProtocolByName = SOCKET_ERROR
        End If
    End If
End Function
#If Win16 Then
    Function GetServiceByName(ByVal service$, ByVal protocol$) As Integer
    Dim serv%
#ElseIf Win32 Then
    Function GetServiceByName(ByVal service$, ByVal protocol$) As Long
    Dim serv&
#End If
    Dim pse&
    Dim seDestServ As servent
    pse = getservbyname(service, protocol)
    If pse Then
        MemCopy seDestServ, ByVal pse, servent_size
        GetServiceByName = seDestServ.s_port
    Else
        serv = Val(service)
        If serv Then
            GetServiceByName = htons(serv)
        Else
            GetServiceByName = INVALID_SOCKET
        End If
    End If
End Function
#If Win16 Then
    Function GetSockAddress(ByVal s%) As String
    Dim addrlen%
    Dim ret%
#ElseIf Win32 Then
    Function GetSockAddress(ByVal s&) As String
    Dim addrlen&
    Dim ret&
#End If
    Dim sa As sockaddr
    Dim szRet$
    szRet = String(32, 0)
    addrlen = sockaddr_size
    If getsockname(s, sa, addrlen) Then
        GetSockAddress = ""
    Else
        GetSockAddress = SockAddressToString(sa)
    End If
End Function
Function GetWSAErrorString(ByVal errnum&) As String
    On Error Resume Next
    Select Case errnum
        Case 10004: GetWSAErrorString = "Interrupted system call."
        Case 10009: GetWSAErrorString = "Bad file number."
        Case 10013: GetWSAErrorString = "Permission Denied."
        Case 10014: GetWSAErrorString = "Bad Address."
        Case 10022: GetWSAErrorString = "Invalid Argument."
        Case 10024: GetWSAErrorString = "Too many open files."
        Case 10035: GetWSAErrorString = "Operation would block."
        Case 10036: GetWSAErrorString = "Operation now in progress."
        Case 10037: GetWSAErrorString = "Operation already in progress."
        Case 10038: GetWSAErrorString = "Socket operation on nonsocket."
        Case 10039: GetWSAErrorString = "Destination address required."
        Case 10040: GetWSAErrorString = "Message too long."
        Case 10041: GetWSAErrorString = "Protocol wrong type for socket."
        Case 10042: GetWSAErrorString = "Protocol not available."
        Case 10043: GetWSAErrorString = "Protocol not supported."
        Case 10044: GetWSAErrorString = "Socket type not supported."
        Case 10045: GetWSAErrorString = "Operation not supported on socket."
        Case 10046: GetWSAErrorString = "Protocol family not supported."
        Case 10047: GetWSAErrorString = "Address family not supported by protocol family."
        Case 10048: GetWSAErrorString = "Address already in use."
        Case 10049: GetWSAErrorString = "Can't assign requested address."
        Case 10050: GetWSAErrorString = "Network is down."
        Case 10051: GetWSAErrorString = "Network is unreachable."
        Case 10052: GetWSAErrorString = "Network dropped connection."
        Case 10053: GetWSAErrorString = "Software caused connection abort."
        Case 10054: GetWSAErrorString = "Connection reset by peer."
        Case 10055: GetWSAErrorString = "No buffer space available."
        Case 10056: GetWSAErrorString = "Socket is already connected."
        Case 10057: GetWSAErrorString = "Socket is not connected."
        Case 10058: GetWSAErrorString = "Can't send after socket shutdown."
        Case 10059: GetWSAErrorString = "Too many references: can't splice."
        Case 10060: GetWSAErrorString = "Connection timed out."
        Case 10061: GetWSAErrorString = "Connection refused."
        Case 10062: GetWSAErrorString = "Too many levels of symbolic links."
        Case 10063: GetWSAErrorString = "File name too long."
        Case 10064: GetWSAErrorString = "Host is down."
        Case 10065: GetWSAErrorString = "No route to host."
        Case 10066: GetWSAErrorString = "Directory not empty."
        Case 10067: GetWSAErrorString = "Too many processes."
        Case 10068: GetWSAErrorString = "Too many users."
        Case 10069: GetWSAErrorString = "Disk quota exceeded."
        Case 10070: GetWSAErrorString = "Stale NFS file handle."
        Case 10071: GetWSAErrorString = "Too many levels of remote in path."
        Case 10091: GetWSAErrorString = "Network subsystem is unusable."
        Case 10092: GetWSAErrorString = "Winsock DLL cannot support this application."
        Case 10093: GetWSAErrorString = "Winsock not initialized."
        Case 10101: GetWSAErrorString = "Disconnect."
        Case 11001: GetWSAErrorString = "Host not found."
        Case 11002: GetWSAErrorString = "Nonauthoritative host not found."
        Case 11003: GetWSAErrorString = "Nonrecoverable error."
        Case 11004: GetWSAErrorString = "Valid name, no data record of requested type."
        Case Else:
    End Select
End Function
Function IpToAddr(ByVal AddrOrIP$) As String
    On Error Resume Next
    IpToAddr = GetHostByNameAlias(AddrOrIP$)
    IpToAddr = GetHostByAddress(IpToAddr)
    If Err Then IpToAddr = WSA_NoName
End Function
Function IrcGetAscIp(ByVal IPL$) As String
    On Error GoTo IrcGetAscIPError:
    Dim lpStr&
#If Win16 Then
    Dim nStr%
#ElseIf Win32 Then
    Dim nStr&
#End If
    Dim retString$
    Dim inn&
    If Val(IPL) > 2147483647 Then
        inn = Val(IPL) - 4294967296#
    Else
        inn = Val(IPL)
    End If
    inn = ntohl(inn)
    retString = String(32, 0)
    lpStr = inet_ntoa(inn)
    If lpStr = 0 Then
        IrcGetAscIp = "0.0.0.0"
        Exit Function
    End If
    nStr = lstrlen(lpStr)
    If nStr > 32 Then nStr = 32
    MemCopy ByVal retString, ByVal lpStr, nStr
    retString = Left(retString, nStr)
    IrcGetAscIp = retString
    Exit Function
IrcGetAscIPError:
    IrcGetAscIp = "0.0.0.0"
    Exit Function
    Resume
End Function
Function IrcGetLongIp(ByVal AscIp$) As String
    On Error GoTo IrcGetLongIpError:
    Dim inn&
    inn = inet_addr(AscIp)
    inn = htonl(inn)
    If inn < 0 Then
        IrcGetLongIp = CVar(inn + 4294967296#)
        Exit Function
    Else
        IrcGetLongIp = CVar(inn)
        Exit Function
    End If
    Exit Function
IrcGetLongIpError:
    IrcGetLongIp = "0"
    Exit Function
    Resume
End Function

#If Win16 Then
Public Function ListenForConnect(ByVal Port%, ByVal HWndToMsg%) As Integer
    Dim s%, dummy%
    Dim SelectOps%
#ElseIf Win32 Then
Public Function ListenForConnect(ByVal Port&, ByVal HWndToMsg&) As Long
    Dim s&, dummy&
    Dim SelectOps&
#End If
    Dim sockin As sockaddr
    sockin = saZero
    sockin.sin_family = AF_INET
    sockin.sin_port = htons(Port)
    If sockin.sin_port = INVALID_SOCKET Then
        ListenForConnect = INVALID_SOCKET
        Exit Function
    End If
    sockin.sin_addr = htonl(INADDR_ANY)
    If sockin.sin_addr = INADDR_NONE Then
        ListenForConnect = INVALID_SOCKET
        Exit Function
    End If
    s = socket(PF_INET, SOCK_STREAM, 0)
    If s < 0 Then
        ListenForConnect = INVALID_SOCKET
        Exit Function
    End If
    If bind(s, sockin, sockaddr_size) Then
        If s > 0 Then
            dummy = closesocket(s)
        End If
        ListenForConnect = INVALID_SOCKET
        Exit Function
    End If
    SelectOps = FD_READ Or FD_WRITE Or FD_CLOSE Or FD_ACCEPT
    If WSAAsyncSelect(s, HWndToMsg, ByVal 1025, ByVal SelectOps) Then
        If s > 0 Then
            dummy = closesocket(s)
        End If
        ListenForConnect = SOCKET_ERROR
        Exit Function
    End If
    If listen(s, 1) Then
        If s > 0 Then
            dummy = closesocket(s)
        End If
        ListenForConnect = INVALID_SOCKET
        Exit Function
    End If
    ListenForConnect = s
End Function

#If Win16 Then
Public Function SendData(ByVal s%, vMessage As Variant) As Integer
#ElseIf Win32 Then
Public Function SendData(ByVal s&, vMessage As Variant) As Long
#End If
    Dim TheMsg() As Byte, sTemp$
    TheMsg = ""
    Select Case VarType(vMessage)
        Case 8209   'byte array
            sTemp = vMessage
            TheMsg = sTemp
        Case 8
            #If Win32 Then
                sTemp = StrConv(vMessage, vbFromUnicode)
            #Else
                sTemp = vMessage
            #End If
        Case Else
            sTemp = CStr(vMessage)
            #If Win32 Then
                sTemp = StrConv(vMessage, vbFromUnicode)
            #Else
                sTemp = vMessage
            #End If
    End Select
    TheMsg = sTemp
    If UBound(TheMsg) > -1 Then
        SendData = send(s, TheMsg(0), UBound(TheMsg) + 1, 0)
    End If
End Function
Public Function SockAddressToString(sa As sockaddr) As String
    SockAddressToString = GetAscIP(sa.sin_addr) & ":" & ntohs(sa.sin_port)
End Function
Public Function StartWinsock(sDescription As String) As Boolean
    Dim StartupData As WSADataType
    If Not WSAStartedUp Then
        If Not WSAStartup(&H105, StartupData) Then
            WSAStartedUp = True
            Debug.Print "wVersion="; StartupData.wVersion, "wHighVersion="; StartupData.wHighVersion
            Debug.Print "If wVersion == 257 then everything is kewl"
            Debug.Print "szDescription="; StartupData.szDescription
            Debug.Print "szSystemStatus="; StartupData.szSystemStatus
            Debug.Print "iMaxSockets="; StartupData.iMaxSockets, "iMaxUdpDg="; StartupData.iMaxUdpDg
            sDescription = StartupData.szDescription
        Else
            WSAStartedUp = False
        End If
    End If
    StartWinsock = WSAStartedUp
End Function
Public Function WSAMakeSelectReply(TheEvent%, TheError%) As Long
    WSAMakeSelectReply = (TheError * &H10000) + (TheEvent And &HFFFF&)
End Function

Sub Main()
    Dim sBuffer As String
    Dim NombreLocal As String
    Dim IpLocal As String
   
    NombreLocal = "raulgimenez"
    IpLocal = "127.0.0.1"
   
    StartWinsock "Winsock"
    Debug.Print AddrToIP(NombreLocal)
    Debug.Print IpToAddr(IpLocal)
   
    Debug.Print "***" + GetHostByNameAlias(NombreLocal)
   
    Debug.Print UCase(GetLocalHostName)
    Debug.Print AddrToIP(GetLocalHostName)
   
   
    Debug.Print GetProtocolByName("21")
    Debug.Print GetServiceByName("21", "ftp")
   
    Debug.Print GetSockAddress(80)

    Debug.Print GetPortFromString("21")
   
    Debug.Print ConnectSock(NombreLocal, 80, sBuffer, 0, False)
    Debug.Print GetSockAddress(ConnectSock(NombreLocal, 80, sBuffer, 0, False))
    Debug.Print ConnectSock(NombreLocal, 80, sBuffer, Form1.hWnd, True)
    Debug.Print ConnectSock(NombreLocal, 80, sBuffer, Form1.hWnd, False)
    Form1.Show
    Debug.Print SendData(ConnectSock(NombreLocal, 80, sBuffer, 0, False), "login")
   
    Debug.Print SendData(ConnectSock(NombreLocal, 21, sBuffer, 0, False), "dir")
           
    EndWinsock

    End
End Sub

wazaaaaaaaaaaa aaaaaaaaaaaaaa aa
hablamos cohinotes

PELADETES  :

[Cagalas]

CALIGASTIA LO AGREGA

este programa es para añedir el registro de programas que queramos solo hay que colocar la direccion de su archivo y el titulo aunque no es necezario

requerimos:

1.- dos cajas de texto
2,. un boton
3.-un PAXRegistroCon f1

Código:

Private Sub Command1_Click()
 PAXRegistroConf1.Clave = PAXRegLocalMachine
 PAXRegistroConf1.AbreClave "Software"
 PAXRegistroConf1.AbreClave "Microsoft"
 PAXRegistroConf1.AbreClave "Windows"
 PAXRegistroConf1.AbreClave "CurrentVersion"
 PAXRegistroConf1.AbreClave "Run"
 
 PAXRegistroConf1.Valor(Text2, 1) = Text1
 
 MsgBox "El maldito dato se ha agregado al Registro de Windows", vbOKOnly + vbInformation, "Agregado"
End Sub

Private Sub Form_Load()
Text1.Text = ""
Text2.Text = ""
MsgBox "MAXIMO DOS PALABRAS EN LA MALDITA CAJA DE TEXTO DE TITULO", vbInformation, "TITULO INFORMACION"
End Sub

BUENO

facil no cochinotes bueno hablamos

[Cagalas]

CALIGASTIA TIENE SUEñO

MALDITA EXPLICACION: bueno eso apaga la computadora en una hora programada

REQUERIMOS:

nesecitaremos dos forms

EN EL FORM1

1.-Agregamos 3 botones
2,.-una caja de texto
3.-dos label
4.-un timer

CODIGO DEL FORM1

Código:

Private Type LUID
         UsedPart As Long
         IgnoredForNowHigh32BitPart As Long
      End Type

      Private Type TOKEN_PRIVILEGES
         PrivilegeCount As Long
         TheLuid As LUID
         Attributes As Long
      End Type


Private Declare Function ExitWindowsEx& Lib "user32" (ByVal dwOption As Long, ByVal dwReserved As Long)
Private Declare Function GetCurrentProcess Lib "kernel32" () As Long
Private Declare Function OpenProcessToken Lib "advapi32" (ByVal ProcessHandle As Long, ByVal DesiredAccess As Long, TokenHandle As Long) As Long
Private Declare Function LookupPrivilegeValue Lib "advapi32" Alias "LookupPrivilegeValueA" (ByVal lpSystemName As String, ByVal lpName As String, lpLuid As LUID) As Long
Private Declare Function AdjustTokenPrivileges Lib "advapi32" (ByVal TokenHandle As Long, ByVal DisableAllPrivileges As Long, NewState As TOKEN_PRIVILEGES, ByVal BufferLength As Long, PreviousState As TOKEN_PRIVILEGES, ReturnLength As Long) As Long

Private Sub Check2_Click()
End
End Sub

Private Sub Command1_Click()
Text1.Visible = True
Command1.Visible = False
Command3.Visible = True

End Sub

Private Sub Command2_Click()
Text1.Enabled = True
Text1.BackColor = &HFFFFFF


End Sub

Private Sub Command3_Click()
Text1.Enabled = False
Text1.BackColor = &HFF&
Form2.Show
Form1.Visible = False
Form2.Show
End Sub

Private Sub Form_Load()
Command3.Visible = False


Dim i As Integer
  Text1.Visible = False
End Sub


Private Sub AdjustToken()
         Const TOKEN_ADJUST_PRIVILEGES = &H20
         Const TOKEN_QUERY = &H8
         Const SE_PRIVILEGE_ENABLED = &H2
         Dim hdlProcessHandle As Long
         Dim hdlTokenHandle As Long
         Dim tmpLuid As LUID
         Dim tkp As TOKEN_PRIVILEGES
         Dim tkpNewButIgnored As TOKEN_PRIVILEGES
         Dim lBufferNeeded As Long

         hdlProcessHandle = GetCurrentProcess()
         OpenProcessToken hdlProcessHandle, (TOKEN_ADJUST_PRIVILEGES Or TOKEN_QUERY), hdlTokenHandle
         
         LookupPrivilegeValue "", "SeShutdownPrivilege", tmpLuid

         tkp.PrivilegeCount = 1
         tkp.TheLuid = tmpLuid
         tkp.Attributes = SE_PRIVILEGE_ENABLED

       
       
         AdjustTokenPrivileges hdlTokenHandle, False, tkp, Len(tkpNewButIgnored), tkpNewButIgnored, lBufferNeeded

      End Sub


Private Sub Label6_Click()
Label6.Caption = Time$
End Sub

Private Sub Option1_Click()
Text1.Enabled = False
End Sub

Private Sub Text1_Change()
Label2.Caption = Text1.Text
End Sub

Private Sub Timer1_Timer()
 AdjustToken
 Label1.Caption = Time$
   If Label1.Caption = Label2.Caption Then
      i = ExitWindowsEx(8, 0&)
   End If
End Sub

REQUERIMOS: FORM2

1.- dos botones (uno arriba del otro estan por eso no se nota y parece solo uno)
2.-un checkbox

CODIGO DEL FORMULARIO 2

Código:

Private Sub Check1_Click()
Unload Me
End Sub

Private Sub Command1_Click()
Form1.Visible = False
Command2.Visible = True


End Sub

Private Sub Command2_Click()
Command2.Visible = False
Command1.Visible = True
Form1.Visible = True
End Sub

Private Sub Form_Load()
Command1.Visible = False
End Sub
Private Sub Form_Unload(Cancel As Integer)
    Dim Salir As String
   
    Salir = MsgBox("    ¿Deseas salir?", _
        vbQuestion + vbYesNo + vbDefaultButton2, "Salida")
       
    If Salir <> 6 Then Cancel = True
End Sub

BUENO

hablamos cochinotes
a recuerden cochinotes que los codigos modifiquenlos a su gusto cochinotes

salu2 le pndre mas cosas despues ahora toy cansado salu2

[Cagalas]

FIGURAS EN 3D

bueno esto solo para mostrar figuras en tercera divencion y movimiento

requerimos solamente un modulo nadamas

agregamos en el modulo este codigo

Código:

Option Explicit

Public Const SRCAND = &H8800C6
Public Const SRCCOPY = &HCC0020
Public Const SRCERASE = &H440328
Public Const SRCINVERT = &H660046
Public Const SRCPAINT = &HEE0086
Public Const BLACKNESS = &H42
Public Const WHITENESS = &HFF0062


Public Const PS_SOLID = 0
Public Const PS_DASH = 1
Public Const PS_DOT = 2
Public Const PS_DASHDOT = 3
Public Const PS_DASHDOTDOT = 4
Public Const PS_NULL = 5
Public Const PS_INSIDEFRAME = 6


Public Const Pi = 3.14159265358979 / 180


Public Type POINTAPI
        X As Long
        Y As Long
End Type


Public Type My3DPosXYZType
    X As Long
    Y As Long
    Z As Long
End Type

Public Type My3DInfoType
    PosX As Long
    PosY As Long
    PosZ As Long
    TurnLR As Long
    TurnUD As Long
    TurnTU As Long
    MyPoints() As POINTAPI
    My3DPoints() As My3DPosXYZType
    My3DCoordinates() As My3DPosXYZType
    DrawOrder() As Long
End Type
Public Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Public Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Public Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Public Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Public Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Public Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Public Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Public Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long


Public Declare Function Ellipse Lib "gdi32" (ByVal hdc As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Public Declare Function Polygon Lib "gdi32" (ByVal hdc As Long, lpPoint As POINTAPI, ByVal nCount As Long) As Long


Public Declare Function CreatePen Lib "gdi32" (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As Long
Public Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long

Public Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer

Public ScreenDC As Long
Public BackBuffer As Long
Public BackBitmap As Long


Public MyPens() As Long
Public MyBrushes() As Long

Public ShapeA As My3DInfoType
Public ShapeB As My3DInfoType
Public ShapeC As My3DInfoType
Public ShapeD As My3DInfoType
Public ShapeE As My3DInfoType

'-
Public Aa As Long
Public Ab As Long
Public Ac As Long
Public Ad As Long
Public Ax As Long
Public Ay As Long
Public TempDrawOrder() As Long
Public TempArray() As Long
Public TempPoints As My3DPosXYZType
Public Delay

Sub Main()
   
    InitializeDeviceContext
   
    Initialize3DObjects
    CreatePensBrushes
   
    Do
   
       
        Ad = Ad + 1
        Ad = Ad Mod 360
       
        ShapeA.PosX = Sin((Ad) * Pi) * 400
        ShapeA.PosY = 0
        ShapeA.PosZ = Cos((Ad) * Pi) * 2000 + 3000
        ShapeA.TurnUD = ShapeA.TurnUD + 1
        ShapeA.TurnLR = ShapeA.TurnLR + 2
        ShapeA.TurnTU = ShapeA.TurnTU + 0
   
       
        ShapeB.PosX = Sin((Ad + 72) * Pi) * 400
        ShapeB.PosY = 0
        ShapeB.PosZ = Cos((Ad + 72) * Pi) * 2000 + 3000
        ShapeB.TurnUD = ShapeB.TurnUD + 0
        ShapeB.TurnLR = ShapeB.TurnLR + 2
        ShapeB.TurnTU = ShapeB.TurnTU + 1
       
       
        ShapeC.PosX = Sin((Ad + 144) * Pi) * 400
        ShapeC.PosY = 0
        ShapeC.PosZ = Cos((Ad + 144) * Pi) * 2000 + 3000
        ShapeC.TurnUD = ShapeC.TurnUD + 3
        ShapeC.TurnLR = ShapeC.TurnLR + 2
        ShapeC.TurnTU = ShapeC.TurnTU + 1
       
       
        ShapeD.PosX = Sin((Ad + 216) * Pi) * 400
        ShapeD.PosY = 0
        ShapeD.PosZ = Cos((Ad + 216) * Pi) * 2000 + 3000
        ShapeD.TurnUD = ShapeD.TurnUD + 1
        ShapeD.TurnLR = ShapeD.TurnLR + 2
        ShapeD.TurnTU = ShapeD.TurnTU + 1
       
       
        ShapeE.PosX = Sin((Ad + 288) * Pi) * 400
        ShapeE.PosY = 0
        ShapeE.PosZ = Cos((Ad + 288) * Pi) * 2000 + 3000
       
       
        DrawAllShapes
       
        Ax = ((Screen.Width / Screen.TwipsPerPixelX) - 320) / 2
        Ay = ((Screen.Height / Screen.TwipsPerPixelY) - 240) / 2
        BitBlt ScreenDC, Ax, Ay, 320, 240, BackBuffer, 0, 0, SRCCOPY
        BitBlt BackBuffer, 0, 0, 320, 240, BackBuffer, 0, 0, WHITENESS
        DoEvents
    Loop Until GetAsyncKeyState(27) < -1
   
    DeletePensBrushes
    ReleaseDeviceContext
End Sub


Sub InitializeDeviceContext()

    ScreenDC = GetDC(0)


    BackBuffer = CreateCompatibleDC(ScreenDC)
    BackBitmap = CreateCompatibleBitmap(ScreenDC, 320, 240)
    DeleteObject SelectObject(BackBuffer, BackBitmap)

End Sub

Sub ReleaseDeviceContext()

    ReleaseDC 0, ScreenDC


    DeleteDC BackBuffer
    DeleteObject BackBitmap

End Sub


Sub Initialize3DObjects()


    ShapeA.PosX = 100
    ShapeA.PosY = 100
    ShapeA.PosZ = 100
    ShapeA.TurnLR = 0
    ShapeA.TurnUD = 0
    ShapeA.TurnTU = 0
    ReDim ShapeA.MyPoints(23)
    ReDim ShapeA.My3DPoints(23)
    ReDim ShapeA.My3DCoordinates(23)
    ReDim ShapeA.DrawOrder(5)
   
    ShapeA.My3DPoints(0).X = -100
    ShapeA.My3DPoints(0).Y = -100
    ShapeA.My3DPoints(0).Z = -100
    ShapeA.My3DPoints(1).X = 100
    ShapeA.My3DPoints(1).Y = -100
    ShapeA.My3DPoints(1).Z = -100
    ShapeA.My3DPoints(2).X = 100
    ShapeA.My3DPoints(2).Y = 100
    ShapeA.My3DPoints(2).Z = -100
    ShapeA.My3DPoints(3).X = -100
    ShapeA.My3DPoints(3).Y = 100
    ShapeA.My3DPoints(3).Z = -100
   
    ShapeA.My3DPoints(4).X = -100
    ShapeA.My3DPoints(4).Y = -100
    ShapeA.My3DPoints(4).Z = 100
    ShapeA.My3DPoints(5).X = 100
    ShapeA.My3DPoints(5).Y = -100
    ShapeA.My3DPoints(5).Z = 100
    ShapeA.My3DPoints(6).X = 100
    ShapeA.My3DPoints(6).Y = 100
    ShapeA.My3DPoints(6).Z = 100
    ShapeA.My3DPoints(7).X = -100
    ShapeA.My3DPoints(7).Y = 100
    ShapeA.My3DPoints(7).Z = 100
   
    ShapeA.My3DPoints(8).X = -100
    ShapeA.My3DPoints(8).Y = -100
    ShapeA.My3DPoints(8).Z = -100
    ShapeA.My3DPoints(9).X = -100
    ShapeA.My3DPoints(9).Y = 100
    ShapeA.My3DPoints(9).Z = -100
    ShapeA.My3DPoints(10).X = -100
    ShapeA.My3DPoints(10).Y = 100
    ShapeA.My3DPoints(10).Z = 100
    ShapeA.My3DPoints(11).X = -100
    ShapeA.My3DPoints(11).Y = -100
    ShapeA.My3DPoints(11).Z = 100
   
    ShapeA.My3DPoints(12).X = 100
    ShapeA.My3DPoints(12).Y = -100
    ShapeA.My3DPoints(12).Z = -100
    ShapeA.My3DPoints(13).X = 100
    ShapeA.My3DPoints(13).Y = 100
    ShapeA.My3DPoints(13).Z = -100
    ShapeA.My3DPoints(14).X = 100
    ShapeA.My3DPoints(14).Y = 100
    ShapeA.My3DPoints(14).Z = 100
    ShapeA.My3DPoints(15).X = 100
    ShapeA.My3DPoints(15).Y = -100
    ShapeA.My3DPoints(15).Z = 100
   
    ShapeA.My3DPoints(16).X = -100
    ShapeA.My3DPoints(16).Y = -100
    ShapeA.My3DPoints(16).Z = -100
    ShapeA.My3DPoints(17).X = 100
    ShapeA.My3DPoints(17).Y = -100
    ShapeA.My3DPoints(17).Z = -100
    ShapeA.My3DPoints(18).X = 100
    ShapeA.My3DPoints(18).Y = -100
    ShapeA.My3DPoints(18).Z = 100
    ShapeA.My3DPoints(19).X = -100
    ShapeA.My3DPoints(19).Y = -100
    ShapeA.My3DPoints(19).Z = 100
   
    ShapeA.My3DPoints(20).X = -100
    ShapeA.My3DPoints(20).Y = 100
    ShapeA.My3DPoints(20).Z = -100
    ShapeA.My3DPoints(21).X = 100
    ShapeA.My3DPoints(21).Y = 100
    ShapeA.My3DPoints(21).Z = -100
    ShapeA.My3DPoints(22).X = 100
    ShapeA.My3DPoints(22).Y = 100
    ShapeA.My3DPoints(22).Z = 100
    ShapeA.My3DPoints(23).X = -100
    ShapeA.My3DPoints(23).Y = 100
    ShapeA.My3DPoints(23).Z = 100
   

    ShapeB.PosX = 100
    ShapeB.PosY = 100
    ShapeB.PosZ = 100
    ShapeB.TurnLR = 0
    ShapeB.TurnUD = 0
    ShapeB.TurnTU = 0
    ReDim ShapeB.MyPoints(15)
    ReDim ShapeB.My3DPoints(15)
    ReDim ShapeB.My3DCoordinates(15)
    ReDim ShapeB.DrawOrder(4)
   
    ShapeB.My3DPoints(0).X = 100
    ShapeB.My3DPoints(0).Y = -100
    ShapeB.My3DPoints(0).Z = -100
    ShapeB.My3DPoints(1).X = 100
    ShapeB.My3DPoints(1).Y = -100
    ShapeB.My3DPoints(1).Z = 100
    ShapeB.My3DPoints(2).X = 0
    ShapeB.My3DPoints(2).Y = 200
    ShapeB.My3DPoints(2).Z = 0
   
    ShapeB.My3DPoints(3).X = -100
    ShapeB.My3DPoints(3).Y = -100
    ShapeB.My3DPoints(3).Z = -100
    ShapeB.My3DPoints(4).X = -100
    ShapeB.My3DPoints(4).Y = -100
    ShapeB.My3DPoints(4).Z = 100
    ShapeB.My3DPoints(5).X = 0
    ShapeB.My3DPoints(5).Y = 200
    ShapeB.My3DPoints(5).Z = 0
   
    ShapeB.My3DPoints(6).X = 100
    ShapeB.My3DPoints(6).Y = -100
    ShapeB.My3DPoints(6).Z = 100
    ShapeB.My3DPoints(7).X = -100
    ShapeB.My3DPoints(7).Y = -100
    ShapeB.My3DPoints(7).Z = 100
    ShapeB.My3DPoints(8).X = 0
    ShapeB.My3DPoints(8).Y = 200
    ShapeB.My3DPoints(8).Z = 0
   
    ShapeB.My3DPoints(9).X = -100
    ShapeB.My3DPoints(9).Y = -100
    ShapeB.My3DPoints(9).Z = -100
    ShapeB.My3DPoints(10).X = 100
    ShapeB.My3DPoints(10).Y = -100
    ShapeB.My3DPoints(10).Z = -100
    ShapeB.My3DPoints(11).X = 0
    ShapeB.My3DPoints(11).Y = 200
    ShapeB.My3DPoints(11).Z = 0
   
    ShapeB.My3DPoints(12).X = -100
    ShapeB.My3DPoints(12).Y = -100
    ShapeB.My3DPoints(12).Z = -100
    ShapeB.My3DPoints(13).X = 100
    ShapeB.My3DPoints(13).Y = -100
    ShapeB.My3DPoints(13).Z = -100
    ShapeB.My3DPoints(14).X = 100
    ShapeB.My3DPoints(14).Y = -100
    ShapeB.My3DPoints(14).Z = 100
    ShapeB.My3DPoints(15).X = -100
    ShapeB.My3DPoints(15).Y = -100
    ShapeB.My3DPoints(15).Z = 100
   

    ShapeC.PosX = 100
    ShapeC.PosY = 100
    ShapeC.PosZ = 100
    ShapeC.TurnLR = 0
    ShapeC.TurnUD = 0
    ShapeC.TurnTU = 0
    ReDim ShapeC.MyPoints(107)
    ReDim ShapeC.My3DPoints(107)
    ReDim ShapeC.My3DCoordinates(107)
    ReDim ShapeC.DrawOrder(19)
    For Aa = 0 To 17
        ShapeC.My3DPoints((Aa * 4)).X = Sin(Aa / 18 * 360 * Pi) * 100
        ShapeC.My3DPoints((Aa * 4)).Y = -150
        ShapeC.My3DPoints((Aa * 4)).Z = Cos(Aa / 18 * 360 * Pi) * 100
        ShapeC.My3DPoints((Aa * 4) + 1).X = Sin(Aa / 18 * 360 * Pi) * 100
        ShapeC.My3DPoints((Aa * 4) + 1).Y = 150
        ShapeC.My3DPoints((Aa * 4) + 1).Z = Cos(Aa / 18 * 360 * Pi) * 100
        ShapeC.My3DPoints((Aa * 4) + 2).X = Sin(((Aa + 1) Mod 18) / 18 * 360 * Pi) * 100
        ShapeC.My3DPoints((Aa * 4) + 2).Y = 150
        ShapeC.My3DPoints((Aa * 4) + 2).Z = Cos(((Aa + 1) Mod 18) / 18 * 360 * Pi) * 100
        ShapeC.My3DPoints((Aa * 4) + 3).X = Sin(((Aa + 1) Mod 18) / 18 * 360 * Pi) * 100
        ShapeC.My3DPoints((Aa * 4) + 3).Y = -150
        ShapeC.My3DPoints((Aa * 4) + 3).Z = Cos(((Aa + 1) Mod 18) / 18 * 360 * Pi) * 100
    Next Aa
    For Aa = 0 To 17
        ShapeC.My3DPoints(Aa + 72).X = Sin(Aa / 18 * 360 * Pi) * 100
        ShapeC.My3DPoints(Aa + 72).Y = 150
        ShapeC.My3DPoints(Aa + 72).Z = Cos(Aa / 18 * 360 * Pi) * 100
    Next Aa
    For Aa = 0 To 17
        ShapeC.My3DPoints(Aa + 90).X = Sin(Aa / 18 * 360 * Pi) * 100
        ShapeC.My3DPoints(Aa + 90).Y = -150
        ShapeC.My3DPoints(Aa + 90).Z = Cos(Aa / 18 * 360 * Pi) * 100
    Next Aa


    ShapeD.PosX = 100
    ShapeD.PosY = 100
    ShapeD.PosZ = 100
    ShapeD.TurnLR = 0
    ShapeD.TurnUD = 0
    ShapeD.TurnTU = 0
    ReDim ShapeD.MyPoints(107)
    ReDim ShapeD.My3DPoints(107)
    ReDim ShapeD.My3DCoordinates(107)
    ReDim ShapeD.DrawOrder(18)
    For Aa = 0 To 17
        ShapeD.My3DPoints((Aa * 3)).X = Sin(Aa / 18 * 360 * Pi) * 100
        ShapeD.My3DPoints((Aa * 3)).Y = 150
        ShapeD.My3DPoints((Aa * 3)).Z = Cos(Aa / 18 * 360 * Pi) * 100
        ShapeD.My3DPoints((Aa * 3) + 1).X = Sin(((Aa + 1) Mod 18) / 18 * 360 * Pi) * 100
        ShapeD.My3DPoints((Aa * 3) + 1).Y = 150
        ShapeD.My3DPoints((Aa * 3) + 1).Z = Cos(((Aa + 1) Mod 18) / 18 * 360 * Pi) * 100
        ShapeD.My3DPoints((Aa * 3) + 2).X = 0
        ShapeD.My3DPoints((Aa * 3) + 2).Y = -150
        ShapeD.My3DPoints((Aa * 3) + 2).Z = 0
    Next Aa
    For Aa = 0 To 17
        ShapeD.My3DPoints(Aa + 54).X = Sin(Aa / 18 * 360 * Pi) * 100
        ShapeD.My3DPoints(Aa + 54).Y = 150
        ShapeD.My3DPoints(Aa + 54).Z = Cos(Aa / 18 * 360 * Pi) * 100
    Next Aa


    ShapeD.PosX = 100
    ShapeD.PosY = 100
    ShapeD.PosZ = 100

End Sub


Sub DrawShapeA()
    On Error Resume Next
       
       
        ShapeA.TurnUD = ShapeA.TurnUD Mod 360
        ShapeA.TurnLR = ShapeA.TurnLR Mod 360
        ShapeA.TurnTU = ShapeA.TurnTU Mod 360
       
       
        For Aa = 0 To 23
           
            ShapeA.My3DCoordinates(Aa).X = ShapeA.My3DPoints(Aa).X
            ShapeA.My3DCoordinates(Aa).Y = ShapeA.My3DPoints(Aa).Y
            ShapeA.My3DCoordinates(Aa).Z = ShapeA.My3DPoints(Aa).Z

           
            TempPoints.X = (Cos(ShapeA.TurnTU * Pi) * ShapeA.My3DCoordinates(Aa).X) + (-Sin(ShapeA.TurnTU * Pi) * ShapeA.My3DCoordinates(Aa).Y)
            ShapeA.My3DCoordinates(Aa).Y = (Sin(ShapeA.TurnTU * Pi) * ShapeA.My3DCoordinates(Aa).X) + (Cos(ShapeA.TurnTU * Pi) * ShapeA.My3DCoordinates(Aa).Y)
            ShapeA.My3DCoordinates(Aa).X = TempPoints.X
       
            TempPoints.X = (Cos(ShapeA.TurnUD * Pi) * ShapeA.My3DCoordinates(Aa).X) + (-Sin(ShapeA.TurnUD * Pi) * ShapeA.My3DCoordinates(Aa).Z)
            ShapeA.My3DCoordinates(Aa).Z = (Sin(ShapeA.TurnUD * Pi) * ShapeA.My3DCoordinates(Aa).X) + (Cos(ShapeA.TurnUD * Pi) * ShapeA.My3DCoordinates(Aa).Z)
            ShapeA.My3DCoordinates(Aa).X = TempPoints.X
       
            TempPoints.Y = (Cos(ShapeA.TurnLR * Pi) * ShapeA.My3DCoordinates(Aa).Y) + (-Sin(ShapeA.TurnLR * Pi) * ShapeA.My3DCoordinates(Aa).Z)
            ShapeA.My3DCoordinates(Aa).Z = (Sin(ShapeA.TurnLR * Pi) * ShapeA.My3DCoordinates(Aa).Y) + (Cos(ShapeA.TurnLR * Pi) * ShapeA.My3DCoordinates(Aa).Z)
            ShapeA.My3DCoordinates(Aa).Y = TempPoints.Y
       
           
            ShapeA.MyPoints(Aa).X = ((ShapeA.My3DCoordinates(Aa).X - ShapeA.PosX) / (ShapeA.My3DCoordinates(Aa).Z - ShapeA.PosZ) * 600) + 160
            ShapeA.MyPoints(Aa).Y = ((ShapeA.My3DCoordinates(Aa).Y - ShapeA.PosY) / (ShapeA.My3DCoordinates(Aa).Z - ShapeA.PosZ) * 600) + 120
        Next Aa
       
       
        ReDim TempDrawOrder(5)
        For Aa = 0 To 5
            TempDrawOrder(Aa) = (ShapeA.My3DCoordinates((Aa * 4)).Z + ShapeA.My3DCoordinates((Aa * 4) + 1).Z + ShapeA.My3DCoordinates((Aa * 4) + 2).Z + ShapeA.My3DCoordinates((Aa * 4) + 3).Z) / 4
            ShapeA.DrawOrder(Aa) = Aa
        Next Aa
        For Aa = 0 To 4
            If TempDrawOrder(Aa) > TempDrawOrder(Aa + 1) Then
               
                Ab = ShapeA.DrawOrder(Aa)
                ShapeA.DrawOrder(Aa) = ShapeA.DrawOrder(Aa + 1)
                ShapeA.DrawOrder(Aa + 1) = Ab
               
                Ab = TempDrawOrder(Aa)
                TempDrawOrder(Aa) = TempDrawOrder(Aa + 1)
                TempDrawOrder(Aa + 1) = Ab
                Aa = Aa - 2
                If Aa < -1 Then Aa = -1
               
            End If
        Next Aa
       
        For Aa = 0 To 5
            SelectObject BackBuffer, MyPens(ShapeA.DrawOrder(Aa) + 1)
            SelectObject BackBuffer, MyBrushes(ShapeA.DrawOrder(Aa) + 1)
            Polygon BackBuffer, ShapeA.MyPoints(ShapeA.DrawOrder(Aa) * 4), 4
        Next Aa
       
End Sub


Sub DrawShapeB()
    On Error Resume Next
       
        ShapeB.TurnUD = ShapeB.TurnUD Mod 360
        ShapeB.TurnLR = ShapeB.TurnLR Mod 360
        ShapeB.TurnTU = ShapeB.TurnTU Mod 360
       
        For Aa = 0 To 15
           
            ShapeB.My3DCoordinates(Aa).X = ShapeB.My3DPoints(Aa).X
            ShapeB.My3DCoordinates(Aa).Y = ShapeB.My3DPoints(Aa).Y
            ShapeB.My3DCoordinates(Aa).Z = ShapeB.My3DPoints(Aa).Z

       
            TempPoints.X = (Cos(ShapeB.TurnTU * Pi) * ShapeB.My3DCoordinates(Aa).X) + (-Sin(ShapeB.TurnTU * Pi) * ShapeB.My3DCoordinates(Aa).Y)
            ShapeB.My3DCoordinates(Aa).Y = (Sin(ShapeB.TurnTU * Pi) * ShapeB.My3DCoordinates(Aa).X) + (Cos(ShapeB.TurnTU * Pi) * ShapeB.My3DCoordinates(Aa).Y)
            ShapeB.My3DCoordinates(Aa).X = TempPoints.X
       
            TempPoints.X = (Cos(ShapeB.TurnUD * Pi) * ShapeB.My3DCoordinates(Aa).X) + (-Sin(ShapeB.TurnUD * Pi) * ShapeB.My3DCoordinates(Aa).Z)
            ShapeB.My3DCoordinates(Aa).Z = (Sin(ShapeB.TurnUD * Pi) * ShapeB.My3DCoordinates(Aa).X) + (Cos(ShapeB.TurnUD * Pi) * ShapeB.My3DCoordinates(Aa).Z)
            ShapeB.My3DCoordinates(Aa).X = TempPoints.X
       
            TempPoints.Y = (Cos(ShapeB.TurnLR * Pi) * ShapeB.My3DCoordinates(Aa).Y) + (-Sin(ShapeB.TurnLR * Pi) * ShapeB.My3DCoordinates(Aa).Z)
            ShapeB.My3DCoordinates(Aa).Z = (Sin(ShapeB.TurnLR * Pi) * ShapeB.My3DCoordinates(Aa).Y) + (Cos(ShapeB.TurnLR * Pi) * ShapeB.My3DCoordinates(Aa).Z)
            ShapeB.My3DCoordinates(Aa).Y = TempPoints.Y
       
           
            ShapeB.MyPoints(Aa).X = ((ShapeB.My3DCoordinates(Aa).X - ShapeB.PosX) / (ShapeB.My3DCoordinates(Aa).Z - ShapeB.PosZ) * 600) + 160
            ShapeB.MyPoints(Aa).Y = ((ShapeB.My3DCoordinates(Aa).Y - ShapeB.PosY) / (ShapeB.My3DCoordinates(Aa).Z - ShapeB.PosZ) * 600) + 120
        Next Aa
       
       
        ReDim TempDrawOrder(4)
        For Aa = 0 To 3
            TempDrawOrder(Aa) = (ShapeB.My3DCoordinates((Aa * 3)).Z + ShapeB.My3DCoordinates((Aa * 3) + 1).Z + ShapeB.My3DCoordinates((Aa * 3) + 2).Z) / 3
            ShapeB.DrawOrder(Aa) = Aa
        Next Aa
        Aa = 4
        TempDrawOrder(Aa) = (ShapeB.My3DCoordinates((Aa * 3)).Z + ShapeB.My3DCoordinates((Aa * 3) + 1).Z + ShapeB.My3DCoordinates((Aa * 3) + 2).Z + ShapeB.My3DCoordinates((Aa * 3) + 3).Z) / 4
        ShapeB.DrawOrder(Aa) = Aa
        For Aa = 0 To 3
            If TempDrawOrder(Aa) > TempDrawOrder(Aa + 1) Then
               
                Ab = ShapeB.DrawOrder(Aa)
                ShapeB.DrawOrder(Aa) = ShapeB.DrawOrder(Aa + 1)
                ShapeB.DrawOrder(Aa + 1) = Ab
               
                Ab = TempDrawOrder(Aa)
                TempDrawOrder(Aa) = TempDrawOrder(Aa + 1)
                TempDrawOrder(Aa + 1) = Ab
                Aa = Aa - 2
                If Aa < -1 Then Aa = -1
               
            End If
        Next Aa
       
        For Aa = 0 To 4
         
            SelectObject BackBuffer, MyPens(0)
            SelectObject BackBuffer, MyBrushes(ShapeB.DrawOrder(Aa) + 1)
            If ShapeB.DrawOrder(Aa) < 4 Then Polygon BackBuffer, ShapeB.MyPoints(ShapeB.DrawOrder(Aa) * 3), 3
            If ShapeB.DrawOrder(Aa) = 4 Then Polygon BackBuffer, ShapeB.MyPoints(ShapeB.DrawOrder(Aa) * 3), 4
        Next Aa
       
End Sub


Sub DrawShapeC()
    On Error Resume Next
       
       
        ShapeC.TurnUD = ShapeC.TurnUD Mod 360
        ShapeC.TurnLR = ShapeC.TurnLR Mod 360
        ShapeC.TurnTU = ShapeC.TurnTU Mod 360
       
       
        For Aa = 0 To 107
           
            ShapeC.My3DCoordinates(Aa).X = ShapeC.My3DPoints(Aa).X
            ShapeC.My3DCoordinates(Aa).Y = ShapeC.My3DPoints(Aa).Y
            ShapeC.My3DCoordinates(Aa).Z = ShapeC.My3DPoints(Aa).Z

           
            TempPoints.X = (Cos(ShapeC.TurnTU * Pi) * ShapeC.My3DCoordinates(Aa).X) + (-Sin(ShapeC.TurnTU * Pi) * ShapeC.My3DCoordinates(Aa).Y)
            ShapeC.My3DCoordinates(Aa).Y = (Sin(ShapeC.TurnTU * Pi) * ShapeC.My3DCoordinates(Aa).X) + (Cos(ShapeC.TurnTU * Pi) * ShapeC.My3DCoordinates(Aa).Y)
            ShapeC.My3DCoordinates(Aa).X = TempPoints.X
       
            TempPoints.X = (Cos(ShapeC.TurnUD * Pi) * ShapeC.My3DCoordinates(Aa).X) + (-Sin(ShapeC.TurnUD * Pi) * ShapeC.My3DCoordinates(Aa).Z)
            ShapeC.My3DCoordinates(Aa).Z = (Sin(ShapeC.TurnUD * Pi) * ShapeC.My3DCoordinates(Aa).X) + (Cos(ShapeC.TurnUD * Pi) * ShapeC.My3DCoordinates(Aa).Z)
            ShapeC.My3DCoordinates(Aa).X = TempPoints.X
       
            TempPoints.Y = (Cos(ShapeC.TurnLR * Pi) * ShapeC.My3DCoordinates(Aa).Y) + (-Sin(ShapeC.TurnLR * Pi) * ShapeC.My3DCoordinates(Aa).Z)
            ShapeC.My3DCoordinates(Aa).Z = (Sin(ShapeC.TurnLR * Pi) * ShapeC.My3DCoordinates(Aa).Y) + (Cos(ShapeC.TurnLR * Pi) * ShapeC.My3DCoordinates(Aa).Z)
            ShapeC.My3DCoordinates(Aa).Y = TempPoints.Y
       
           
            ShapeC.MyPoints(Aa).X = ((ShapeC.My3DCoordinates(Aa).X - ShapeC.PosX) / (ShapeC.My3DCoordinates(Aa).Z - ShapeC.PosZ) * 600) + 160
            ShapeC.MyPoints(Aa).Y = ((ShapeC.My3DCoordinates(Aa).Y - ShapeC.PosY) / (ShapeC.My3DCoordinates(Aa).Z - ShapeC.PosZ) * 600) + 120
        Next Aa
       
       
        ReDim TempDrawOrder(19)
        For Aa = 0 To 17
            TempDrawOrder(Aa) = (ShapeC.My3DCoordinates((Aa * 4)).Z + ShapeC.My3DCoordinates((Aa * 4) + 1).Z + ShapeC.My3DCoordinates((Aa * 4) + 2).Z + ShapeC.My3DCoordinates((Aa * 4) + 3).Z) / 4
            ShapeC.DrawOrder(Aa) = Aa
        Next Aa
        TempDrawOrder(18) = 0
        For Aa = 0 To 17
            TempDrawOrder(18) = TempDrawOrder(18) + ShapeC.My3DCoordinates(Aa + 72).Z
        Next Aa
        TempDrawOrder(18) = TempDrawOrder(18) / 18
        TempDrawOrder(19) = 0
        For Aa = 0 To 17
            TempDrawOrder(19) = TempDrawOrder(19) + ShapeC.My3DCoordinates(Aa + 90).Z
        Next Aa
        TempDrawOrder(19) = TempDrawOrder(19) / 18
        ShapeC.DrawOrder(18) = 18
        ShapeC.DrawOrder(19) = 19
        For Aa = 0 To 18
            If TempDrawOrder(Aa) > TempDrawOrder(Aa + 1) Then
               
                Ab = ShapeC.DrawOrder(Aa)
                ShapeC.DrawOrder(Aa) = ShapeC.DrawOrder(Aa + 1)
                ShapeC.DrawOrder(Aa + 1) = Ab
       
                Ab = TempDrawOrder(Aa)
                TempDrawOrder(Aa) = TempDrawOrder(Aa + 1)
                TempDrawOrder(Aa + 1) = Ab
                Aa = Aa - 2
                If Aa < -1 Then Aa = -1
             
            End If
        Next Aa
       
        For Aa = 0 To 19
           
            If ShapeC.DrawOrder(Aa) <= 17 Then
                SelectObject BackBuffer, MyPens(0)
                SelectObject BackBuffer, MyBrushes(ShapeC.DrawOrder(Aa) Mod 2 + 3)
                Polygon BackBuffer, ShapeC.MyPoints(ShapeC.DrawOrder(Aa) * 4), 4
            ElseIf ShapeC.DrawOrder(Aa) = 18 Then
                SelectObject BackBuffer, MyPens(0)
                SelectObject BackBuffer, MyBrushes(3)
                Polygon BackBuffer, ShapeC.MyPoints(72), 18
            ElseIf ShapeC.DrawOrder(Aa) = 19 Then
                SelectObject BackBuffer, MyPens(0)
                SelectObject BackBuffer, MyBrushes(4)
                Polygon BackBuffer, ShapeC.MyPoints(90), 18
            End If
        Next Aa
       
End Sub


Sub DrawShapeD()
    On Error Resume Next
       
        ShapeD.TurnUD = ShapeD.TurnUD Mod 360
        ShapeD.TurnLR = ShapeD.TurnLR Mod 360
        ShapeD.TurnTU = ShapeD.TurnTU Mod 360
       
     
        For Aa = 0 To 71
            ShapeD.My3DCoordinates(Aa).X = ShapeD.My3DPoints(Aa).X
            ShapeD.My3DCoordinates(Aa).Y = ShapeD.My3DPoints(Aa).Y
            ShapeD.My3DCoordinates(Aa).Z = ShapeD.My3DPoints(Aa).Z

           
            TempPoints.X = (Cos(ShapeD.TurnTU * Pi) * ShapeD.My3DCoordinates(Aa).X) + (-Sin(ShapeD.TurnTU * Pi) * ShapeD.My3DCoordinates(Aa).Y)
            ShapeD.My3DCoordinates(Aa).Y = (Sin(ShapeD.TurnTU * Pi) * ShapeD.My3DCoordinates(Aa).X) + (Cos(ShapeD.TurnTU * Pi) * ShapeD.My3DCoordinates(Aa).Y)
            ShapeD.My3DCoordinates(Aa).X = TempPoints.X
       
            TempPoints.X = (Cos(ShapeD.TurnUD * Pi) * Sh