1 mayo, 2009 – Leandro Ascierto

DrawGrìp

May 012009

Esta es una función simple para dibujar puntos sobre un Formulario, Picture Box o hdc, la función es rápida.

Draw Grip

Option Explicit

'=========GDI32 Api========
Private Declare Function CreateSolidBrush Lib "gdi32.dll" (ByVal crColor As Long) As Long
Private Declare Function GetDC Lib "user32.dll" (ByVal hwnd As Long) As Long
Private Declare Function SetRect Lib "user32.dll" (ByRef lpRect As RECT, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function SelectObject Lib "gdi32.dll" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32.dll" (ByVal hObject As Long) As Long
Private Declare Function GetDCBrushColor Lib "gdi32.dll" (ByVal hdc As Long) As Long
Private Declare Function GetBkColor Lib "gdi32.dll" (ByVal hdc As Long) As Long
Private Declare Function SetPixelV Lib "gdi32.dll" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal crColor As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32.dll" (ByVal hdc As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32.dll" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function CreatePatternBrush Lib "gdi32.dll" (ByVal hBitmap As Long) As Long
Private Declare Function DeleteDC Lib "gdi32.dll" (ByVal hdc As Long) As Long
Private Declare Function GdiTransparentBlt Lib "gdi32.dll" (ByVal hdc 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 nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal crTransparent As Long) As Boolean

'============User32 Api===========
Private Declare Function FillRect Lib "user32.dll" (ByVal hdc As Long, ByRef lpRect As RECT, ByVal hBrush As Long) As Long

'============Estructura Rect========
Private Type RECT
    Left                        As Long
    Top                         As Long
    Right                       As Long
    Bottom                      As Long
End Type

Public Function ShiftColor(ByVal clr As Long, ByVal d As Long) As Long
  Dim R As Long, B As Long, G As Long
    R = (clr And &HFF) + d
    G = ((clr \ &H100) Mod &H100) + d
    B = ((clr \ &H10000) Mod &H100) + d
    
    If (d > 0) Then
        If (R > &HFF) Then R = &HFF
        If (G > &HFF) Then G = &HFF
        If (B > &HFF) Then B = &HFF
    ElseIf (d < 0) Then
        If (R < 0) Then R = 0
        If (G < 0) Then G = 0
        If (B < 0) Then B = 0
    End If
    ShiftColor = R + &H100& * G + &H10000 * B
End Function

Public Sub DrawGrip(DestDC As Long, DestX As Long, DestY As Long, DestWidth As Long, DestHeight As Long)
    Dim DC                      As Long
    Dim hDCMemory               As Long
    Dim hBmp                    As Long
    Dim hOldBmp                 As Long
    Dim hBrush                  As Long
    Dim Rec                     As RECT
    Dim lOriginalColor          As Long
    Dim clrHighLight            As Long
    Dim clrShadow               As Long

    lOriginalColor = GetBkColor(DestDC)
    clrHighLight = ShiftColor(lOriginalColor, &H40)
    clrShadow = ShiftColor(lOriginalColor, -&H40)
    
    DC = GetDC(0)
    hDCMemory = CreateCompatibleDC(0)
    hBmp = CreateCompatibleBitmap(DC, 6, 6)
    hOldBmp = SelectObject(hDCMemory, hBmp)
          
    hBrush = CreateSolidBrush(lOriginalColor)
    SetRect Rec, 0, 0, 6, 6
    FillRect hDCMemory, Rec, hBrush
    DeleteObject hBrush
    
    SetPixelV hDCMemory, 2, 1, clrShadow
    SetPixelV hDCMemory, 1, 2, clrShadow
    SetPixelV hDCMemory, 2, 2, clrShadow
    
    SetPixelV hDCMemory, 0, 0, clrHighLight
    SetPixelV hDCMemory, 1, 0, clrHighLight
    SetPixelV hDCMemory, 0, 1, clrHighLight
    SetPixelV hDCMemory, 1, 1, clrHighLight
    
    SetPixelV hDCMemory, 5, 4, clrShadow
    SetPixelV hDCMemory, 4, 5, clrShadow
    SetPixelV hDCMemory, 5, 5, clrShadow
    
    SetPixelV hDCMemory, 3, 3, clrHighLight
    SetPixelV hDCMemory, 4, 3, clrHighLight
    SetPixelV hDCMemory, 3, 4, clrHighLight
    SetPixelV hDCMemory, 4, 4, clrHighLight
    
    hBrush = CreatePatternBrush(hBmp)
    SelectObject hDCMemory, hOldBmp
    DeleteObject hBmp
    hBmp = CreateCompatibleBitmap(DC, DestWidth, DestHeight)
    hOldBmp = SelectObject(hDCMemory, hBmp)
    SetRect Rec, 0, 0, DestWidth, DestHeight
    FillRect hDCMemory, Rec, hBrush
    
    GdiTransparentBlt DestDC, DestX, DestY, DestWidth, DestHeight, hDCMemory, 0, 0, DestWidth, DestHeight, lOriginalColor

    DeleteObject hBrush
    SelectObject hDCMemory, hOldBmp
    DeleteObject hBmp
    DeleteDC DC
    DeleteDC hDCMemory    
End Sub

Private Sub Form_Paint()
    DrawGrip Me.hdc, 0, 50, Me.ScaleWidth / Screen.TwipsPerPixelX, 9
    DrawGrip Me.hdc, 100, 59, 16, Me.ScaleHeight / Screen.TwipsPerPixelY - 59
End Sub

Este proyecto es algo similar al Widget del Tiempo pero mucho más sencillo, lo que hace es poner un ícono con el estado del tiempo de la localidad seleccionada en la Barra de Tareas y al pasar el mouse sobre éste se despliega una ventana tipo ToolTip con una información más detallada, tal como se aprecia en la imágen.
En este proyecto utilicé una clase (ClsXML) para parsear un XML que descarga de accuweather.com con la información del clima, agradezco a xKiz por ayudarme con este paso, no utilicé la referencia de Microsoft ya que éste aumentaba mucho más el tamaño de la memoria en el ejecutable.
Para cambiar de localidad sólo basta con hacer doble click sobre el ícono y se abrirá una ventana con las opciones de búsqueda, si hacen click derecho se despliega un menú con otras opciones.

Corrector Ortográfico Google

Módulos Sin comentarios »

May 012009

En realidad este no es un módulo, sino un formulario, el cual utiliza las Apis de Google SpellCheck, cuenta con varios idiomas y su uso es muy sencillo, sólo basta con una línea de código, en este proyecto/código no utilicé ninguna api, sólo la creación de algunos objetos (estos objetos ya están por defecto en Windows, por lo tanto no hay dependencias), obviamente requerimos de conexión a internet para que funcione.
Básicamente lo que hace es crear un XML y dentro del contenido de éste, el texto a corregir, se lo envía a Google en una petición de tipo POST y éste nos devuelve otro XML con las posibles sugerencias, del resto se encarga este formulario que va listando las sugerencias, reemplazando u omitiendo.
También cuenta con la posibilidad de agregar palabras a un diccionario, este no es más que un archivo de texto plano en el que se irán almacenando todas las palabras que agreguemos.

Corrector Ortográfico Google

DrawAlphaSelection

Gráficos 1 Comentario »

May 012009

Esta es una función para dibujar una selección al estilo Windows XP.

Draw Alpha Selection


Option Explicit
 
'=========Gdi32 Api========
Private Declare Function Rectangle Lib "gdi32" (ByVal hdc As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32.dll" (ByVal hdc As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32.dll" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function DeleteObject Lib "gdi32.dll" (ByVal hObject As Long) As Long
Private Declare Function DeleteDC Lib "gdi32.dll" (ByVal hdc As Long) As Long
Private Declare Function GdiAlphaBlend Lib "gdi32.dll" (ByVal hdc As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal hdc As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal BLENDFUNCT As Long) As Long
Private Declare Function CreatePen Lib "gdi32.dll" (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As Long
Private Declare Function CreateSolidBrush Lib "gdi32.dll" (ByVal crColor As Long) As Long
'=========user32 Api========
Private Declare Function GetDC Lib "user32.dll" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32.dll" (ByVal hwnd As Long, ByVal hdc As Long) As Long
 
'=========Oleaut32 Api========
Private Declare Function OleTranslateColor Lib "oleaut32.dll" (ByVal lOleColor As Long, ByVal lHPalette As Long, ByVal lColorRef As Long) As Long
 
'=========Kernel32 Api========
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByVal Destination As Long, ByVal Source As Long, ByVal Length As Long)
Private Declare Function SelectObject Lib "gdi32.dll" (ByVal hdc As Long, ByVal hObject As Long) As Long
 
Private Type UcsRgbQuad
    R                       As Byte
    G                       As Byte
    B                       As Byte
    a                       As Byte
End Type
 
Private Type BLENDFUNCTION
    BlendOp                 As Byte
    BlendFlags              As Byte
    SourceConstantAlpha     As Byte
    AlphaFormat             As Byte
End Type
 
Private Sub DrawAlphaSelection(hdc As Long, ByVal X As Long, ByVal y As Long, ByVal Width As Long, ByVal Height As Long, ByVal Color As OLE_COLOR)
 
    Dim BF                  As BLENDFUNCTION
    Dim hDCMemory           As Long
    Dim hBmp                As Long
    Dim hOldBmp             As Long
    Dim DC                  As Long
    Dim lColor              As Long
    Dim hPen                As Long
    Dim hBrush              As Long
    Dim lBF                 As Long
 
    BF.SourceConstantAlpha = 128
 
    DC = GetDC(0)
    hDCMemory = CreateCompatibleDC(0)
    hBmp = CreateCompatibleBitmap(DC, Width, Height)
    hOldBmp = SelectObject(hDCMemory, hBmp)
 
    hPen = CreatePen(0, 1, Color)
    hBrush = CreateSolidBrush(pvAlphaBlend(Color, vbWhite, 120))
    DeleteObject SelectObject(hDCMemory, hBrush)
    DeleteObject SelectObject(hDCMemory, hPen)
    Rectangle hDCMemory, 0, 0, Width, Height
 
    CopyMemory VarPtr(lBF), VarPtr(BF), 4
    GdiAlphaBlend hdc, X, y, Width, Height, hDCMemory, 0, 0, Width, Height, lBF
 
    SelectObject hDCMemory, hOldBmp
    DeleteObject hBmp
    ReleaseDC 0&, DC
    DeleteDC hDCMemory
    DeleteObject hPen
    DeleteObject hBrush
 
End Sub
 
Private Function pvAlphaBlend(ByVal clrFirst As Long, ByVal clrSecond As Long, ByVal lAlpha As Long) As Long
 
    Dim clrFore             As UcsRgbQuad
    Dim clrBack             As UcsRgbQuad
 
    OleTranslateColor clrFirst, 0, VarPtr(clrFore)
    OleTranslateColor clrSecond, 0, VarPtr(clrBack)
    With clrFore
        .R = (.R * lAlpha + clrBack.R * (255 - lAlpha)) / 255
        .G = (.G * lAlpha + clrBack.G * (255 - lAlpha)) / 255
        .B = (.B * lAlpha + clrBack.B * (255 - lAlpha)) / 255
    End With
    CopyMemory VarPtr(pvAlphaBlend), VarPtr(clrFore), 4
 
End Function
 
Private Sub Form_Paint()
    Cls
    DrawAlphaSelection Me.hdc, 10, 50, 100, 200, vbRed
    DrawAlphaSelection Me.hdc, 50, 30, 200, 100, vbBlue
    DrawAlphaSelection Me.hdc, 200, 80, 100, 100, vbGreen
    DrawAlphaSelection Me.hdc, 80, 200, 200, 30, vbYellow
    DrawAlphaSelection Me.hdc, 130, 70, 50, 200, vbMagenta
End Sub

L	M	X	J	V	S	D
				1	2	3
4	5	6	7	8	9	10
11	12	13	14	15	16	17
18	19	20	21	22	23	24
25	26	27	28	29	30	31