أداة تصميم الفورم على شكل صورة مع الكود

I have nothing to do

take ur time

I'm waiting

i'm sure u are genius and able to do excelent work

good luck

It Seem That You didn't See My Last Write

Up

Good Luck

السلام عليكم و رحمة الله ز بركاته

ur right dear

i write my message during ur write ur message

اقتباس

till now u could'nt reach correct code

it must be as

trans1.picture=  loadPicture
OR
trans1.picture=image1.picture

and so

see my attached file and i think u can try to modify ur control to do

my best Regard dear

لا اعلم لماذا لا استطيع ارفاق المثال

علي كل حال الكود

موديول

Option Explicit
'picForm declaration
Public Declare Function CreateRectRgn Lib "gdi32" (ByVal x1 As Long, ByVal y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Public Declare Function CombineRgn Lib "gdi32" (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long
Public Declare Function SetWindowRgn Lib "user32" (ByVal hWnd As Long, ByVal hRgn As Long, ByVal bRedraw As Long) As Long
Public Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long

' For information on this module and other graphics
' programming, see the book "Visual Basic Graphics
' Programming, Second Edition." For more information,
' go to:
'
'       http://www.vb-helper.com/vbgp.htm

' DIB stuff.
Public Declare Function GetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Public Declare Function GetDIBits Lib "gdi32" (ByVal aHDC As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As BITMAPINFO, ByVal wUsage As Long) As Long
Public Type BITMAP '14 bytes
    bmType As Long
    bmWidth As Long
    bmHeight As Long
    bmWidthBytes As Long
    bmPlanes As Integer
    bmBitsPixel As Integer
    bmBits As Long
End Type
Public Type BITMAPINFOHEADER '40 bytes
    biSize As Long
    biWidth As Long
    biHeight As Long
    biPlanes As Integer
    biBitCount As Integer
    biCompression As Long
    biSizeImage As Long
    biXPelsPerMeter As Long
    biYPelsPerMeter As Long
    biClrUsed As Long
    biClrImportant As Long
End Type
Public Type RGBQUAD
    rgbBlue As Byte
    rgbGreen As Byte
    rgbRed As Byte
    rgbReserved As Byte
End Type
Public Type BITMAPINFO
    bmiHeader As BITMAPINFOHEADER
    bmiColors As RGBQUAD
End Type
Public Const DIB_RGB_COLORS = 0&
Public Const BI_RGB = 0&

Public Const pixR As Integer = 3
Public Const pixG As Integer = 2
Public Const pixB As Integer = 1
Public Sub UnRGB(ByRef color As Long, ByRef R As Byte, ByRef g As Byte, ByRef b As Byte)
    R = color And &HFF&
    g = (color And &HFF00&) \ &H100&
    b = (color And &HFF0000) \ &H10000
End Sub
' Fir the form to the pixels that don't match the color.
Public Sub ShapeForm(ByVal pic As PictureBox, ByVal transparent_color As Long)
    Const RGN_OR = 2
    Dim bytes_per_scanLine As Integer
    Dim wid As Long
    Dim hgt As Long
    Dim bitmap_info As BITMAPINFO
    Dim pixels() As Byte
    Dim buffer() As Byte
    Dim transparent_r As Byte
    Dim transparent_g As Byte
    Dim transparent_b As Byte
    Dim border_width As Single
    Dim title_height As Single
    Dim x0 As Long
    Dim y0 As Long
    Dim start_c As Integer
    Dim stop_c As Integer
    Dim R As Integer
    Dim C As Integer
    Dim combined_rgn As Long
    Dim new_rgn As Long

    Form1.ScaleMode = vbPixels
    pic.ScaleMode = vbPixels
    pic.AutoRedraw = True
    pic.Picture = pic.Image

    ' Prepare the bitmap description.
    wid = pic.ScaleWidth
    hgt = pic.ScaleHeight
    With bitmap_info.bmiHeader
        .biSize = 40
        .biWidth = wid
        ' Use negative height to scan top-down.
        .biHeight = -hgt
        .biPlanes = 1
        .biBitCount = 32
        .biCompression = BI_RGB
        bytes_per_scanLine = ((((.biWidth * .biBitCount) + 31) \ 32) * 4)
        .biSizeImage = bytes_per_scanLine * hgt
    End With

    ' Load the bitmap's data.
    ReDim pixels(1 To 4, 1 To wid, 1 To hgt)
    GetDIBits pic.hDC, pic.Image, _
            0, hgt, pixels(1, 1, 1), _
            bitmap_info, DIB_RGB_COLORS

    ' Process the pixels.
    ' Break the tansparent color apart.
    UnRGB transparent_color, transparent_r, transparent_g, transparent_b

    ' Find the form's corner.
    border_width = (Form1.ScaleX(Form1.Width, vbTwips, vbPixels) - Form1.ScaleWidth) / 2
    title_height = Form1.ScaleX(Form1.Height, vbTwips, vbPixels) - border_width - Form1.ScaleHeight

    ' Find the picture's corner.
    x0 = pic.Left + border_width
    y0 = pic.Top + title_height

    ' Create the form's regions.
    For R = 1 To hgt
        ' Create a region for this row.
        C = 1
        Do While C <= wid
            start_c = 1
            stop_c = 1

            ' Find the next non-white column.
            Do While C <= wid
                If pixels(pixR, C, R) <> transparent_r Or _
                        pixels(pixG, C, R) <> transparent_g Or _
                        pixels(pixB, C, R) <> transparent_b _
                        Then
                    Exit Do
                End If
                C = C + 1
            Loop
            start_c = C

            ' Find the next white column.
            Do While C <= wid
                If pixels(pixR, C, R) = transparent_r And _
                        pixels(pixG, C, R) = transparent_g And _
                        pixels(pixB, C, R) = transparent_b _
                        Then
                    Exit Do
                End If
                C = C + 1
            Loop
            stop_c = C

            ' Make a region from start_c to stop_c.
            If start_c <= wid Then
                If stop_c > wid Then stop_c = wid

                ' Create the region.
                new_rgn = CreateRectRgn( _
                        start_c + x0, R + y0, _
                        stop_c + x0, R + y0 + 1)

                ' Add it to what we have so far.
                If combined_rgn = 0 Then
                    combined_rgn = new_rgn
                Else
                    CombineRgn combined_rgn, _
                            combined_rgn, new_rgn, RGN_OR
                    DeleteObject new_rgn
                End If
            End If
        Loop
    Next R

    ' Restrict the form to the region.
    SetWindowRgn Form1.hWnd, combined_rgn, True
    DeleteObject combined_rgn
End Sub

موديول

Public Declare Function ReleaseCapture Lib "user32" () As Long
Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long

Public Const HTCAPTION = 2
Public Const WM_NCLBUTTONDOWN = &HA1

Public Const WM_SYSCOMMAND = &H112

موديول

Option Explicit
Private Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Long) As Long
'==================
Private Declare Function RegSetValueEx Lib "advapi32.dll" _
        Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName _
        As String, ByVal Reserved As Long, ByVal dwType As Long, _
        lpData As Any, ByVal cbData As Long) As Long
Private Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Private Declare Function RegDeleteValue Lib "advapi32.dll" Alias "RegDeleteValueA" (ByVal hKey As Long, ByVal lpValueName As String) As Long
Private Declare Function RegDeleteKey Lib "advapi32.dll" Alias "RegDeleteKeyA" (ByVal hKey As Long, ByVal lpSubKey As String) As Long
Private Declare Function RegCreateKeyEx Lib "advapi32.dll" Alias "RegCreateKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal Reserved As Long, ByVal lpClass As String, ByVal dwOptions As Long, ByVal samDesired As Long, lpSecurityAttributes As Any, phkResult As Long, lpdwDisposition As Long) As Long
Private Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal Reserved As Long, ByVal samDesired As Long, phkResult As Long) As Long
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Const KEY_WRITE = &H20006
Const REG_SZ = 1
Const HKEY_CURRENT_USER = &H80000001
Const STANDARD_RIGHTS_ALL = &H1F0000
Const KEY_QUERY_VALUE = &H1
Const KEY_SET_VALUE = &H2
Const KEY_CREATE_SUB_KEY = &H4
Const KEY_ENUMERATE_SUB_KEYS = &H8
Const KEY_NOTIFY = &H10
Const KEY_CREATE_LINK = &H20
Const SYNCHRONIZE = &H100000
Const KEY_ALL_ACCESS = ((STANDARD_RIGHTS_ALL Or KEY_QUERY_VALUE Or KEY_SET_VALUE Or KEY_CREATE_SUB_KEY Or KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY Or KEY_CREATE_LINK) And (Not SYNCHRONIZE))
Dim hregkey As Long
Dim subkey As String
Dim stringbuffer As String

Public Function OnLoadRun()
    Dim RegResult As Long
    Dim RegCreate As Long
    Dim isValue As Long
    Dim lValueType As Long
    Dim lDataBufSize As Long
    '====Added for Run at StartUp====
    'Check if the specified key exists
    RegOpenKeyEx HKEY_CURRENT_USER, "Software\Microsoft\Windows\CurrentVersion\Run", 0, KEY_ALL_ACCESS, RegResult
    If RegResult <> 0 Then
        isValue = RegQueryValueEx(RegResult, App.EXEName, 0, lValueType, ByVal 0, lDataBufSize)
        If isValue = 0 Then Form1.start.Checked = True
    Else
        'MsgBox "Unable to find Software\Microsoft\Windows\CurrentVersion\Run key"
        RegCreateKey HKEY_CURRENT_USER, "Software\Microsoft\Windows\CurrentVersion\Run", RegCreate
        RegCloseKey RegCreate

    End If
    'close the handle
    RegCloseKey RegResult

    '==========
End Function
Public Function OnClickRun()
    On Error GoTo errChk
    Dim RegResult As Long
    Dim retval
    If Form1.start.Checked = True Then                '====Add Reg entry
        SaveSetting App.Title, "Startup", "runstartup", "yes"
        subkey = "Software\Microsoft\Windows\CurrentVersion\Run"
        retval = RegOpenKeyEx(HKEY_CURRENT_USER, subkey, 0, _
                KEY_WRITE, hregkey)
        If retval <> 0 Then
            MsgBox "Can't open the subkey"
            Exit Function
        End If
        stringbuffer = """" & App.Path & "\" & App.EXEName & ".exe" & """" & vbNullChar
        retval = RegSetValueEx(hregkey, App.EXEName, 0, REG_SZ, _
                ByVal stringbuffer, Len(stringbuffer))
        RegCloseKey hregkey
    Else                                              '===Remove Reg entry
        SaveSetting App.Title, "Startup", "runstartup", "no"
        'Check if the specified key exists
        RegOpenKeyEx HKEY_CURRENT_USER, "Software\Microsoft\Windows\CurrentVersion\Run", 0, KEY_ALL_ACCESS, RegResult
        If RegResult <> 0 Then
            retval = RegDeleteValue(RegResult, App.EXEName)
            If retval <> 0 Then MsgBox "Unable to find value"
        Else
            MsgBox "Unable to find key"
        End If
        'close the handle
        RegCloseKey RegResult
    End If
    Exit Function
errChk:     MsgBox Err.Number & " " & Err.Description
End Function

في الفورم

Option Explicit

Private mlIndex As Long
'

'About decleration
Private Declare Function ShellAbout Lib "shell32.dll" Alias "ShellAboutA" (ByVal hWnd As Long, ByVal szApp As String, ByVal szOtherStuff As String, ByVal hIcon As Long) As Long
'=============================================

'=============================================
'declare Always on top decleratin
Private Declare Function SetWindowPos Lib "user32" (ByVal hWnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Private Const SWP_NOMOVE = &H2
Private Const SWP_NOSIZE = &H1
Private Const HWND_TOPMOST = -1
Private Const HWND_NOTOPMOST = -2
'=============================================

' Make the form topmost or not.
'function " topmost " form  always on top
Private Sub SetOnTop(Optional ByVal on_top As Boolean = True)
    If on_top Then
        SetWindowPos hWnd, _
                HWND_TOPMOST, 0, 0, 0, 0, _
                SWP_NOMOVE + SWP_NOSIZE
    Else
        SetWindowPos hWnd, _
                HWND_NOTOPMOST, 0, 0, 0, 0, _
                SWP_NOMOVE + SWP_NOSIZE
    End If
End Sub



Sub angela()
    Static count As Integer
    Image4(0).Picture = Image4(count).Picture
    count = count + 1
    If count = 6 Then count = 0
    p1.Picture = Image4(count).Picture
    '
    Call picStrech

    ' Fit the form to the picture.
    ShapeForm p1, &HFFFFFF
    '@    FitFormToPicture picShape, &HFFFFFF

End Sub
Sub baby()
    Static count As Integer
    Image1(0).Picture = Image1(count).Picture
    count = count + 1
    If count = 8 Then count = 0
    p1.Picture = Image1(count).Picture
    '
    Call picStrech

    ' Fit the form to the picture.
    ShapeForm p1, &HFFFFFF
    '@    FitFormToPicture picShape, &HFFFFFF

End Sub
Sub cootie()
    Static count As Integer
    Image3(0).Picture = Image3(count).Picture
    count = count + 1
    If count = 17 Then count = 0
    p1.Picture = Image3(count).Picture
    '
    Call picStrech

    ' Fit the form to the picture.
    ShapeForm p1, &HFFFFFF
    '@    FitFormToPicture picShape, &HFFFFFF

End Sub
Sub dream()
    Static count As Integer
    Image6(0).Picture = Image6(count).Picture
    count = count + 1
    If count = 8 Then count = 0
    p1.Picture = Image6(count).Picture
    '

    Call picStrech

    ' Fit the form to the picture.
    ShapeForm p1, &HFFFFFF
    '@    FitFormToPicture picShape, &HFFFFFF

End Sub
Sub gazelle()
    Static count As Integer
    Image2(0).Picture = Image2(count).Picture
    count = count + 1
    If count = 18 Then count = 0
    p1.Picture = Image2(count).Picture
    '
    Call picStrech

    ' Fit the form to the picture.
    ShapeForm p1, &HFFFFFF
    '@    FitFormToPicture picShape, &HFFFFFF

End Sub
Sub violin()
    Static count As Integer
    Image5(0).Picture = Image5(count).Picture
    count = count + 1
    If count = 12 Then count = 0
    p1.Picture = Image5(count).Picture
    '
    Call picStrech

    ' Fit the form to the picture.
    ShapeForm p1, &HFFFFFF
    '@    FitFormToPicture picShape, &HFFFFFF

End Sub

Sub picStrech()
    '(Picture)  áåÇ ÎÇÕíÉ ÇáÊãÏÏ
    'p1.Picture = Image1(0).Picture
    p1.ScaleMode = 3: p1.AutoRedraw = True
    p1.PaintPicture p1.Picture, 0, 0, p1.ScaleWidth, p1.ScaleHeight, 0, 0, p1.Picture.Width / 26.46, p1.Picture.Height / 26.46
    p1.Picture = p1.Image
End Sub

Private Sub a1_Click(Index As Integer)
    Select Case Index
        Case 0:
            a1(0).Checked = True
            a1(2).Checked = False
            a1(4).Checked = False
            a1(6).Checked = False
            a1(8).Checked = False
            a1(10).Checked = False
        Case 1:
            '
        Case 2:
            a1(0).Checked = False
            a1(2).Checked = True
            a1(4).Checked = False
            a1(6).Checked = False
            a1(8).Checked = False
            a1(10).Checked = False
        Case 3:
            '
        Case 4:
            a1(0).Checked = False
            a1(2).Checked = False
            a1(4).Checked = True
            a1(6).Checked = False
            a1(8).Checked = False
            a1(10).Checked = False
        Case 5:
            '
        Case 6:
            a1(0).Checked = False
            a1(2).Checked = False
            a1(4).Checked = False
            a1(6).Checked = True
            a1(8).Checked = False
            a1(10).Checked = False
        Case 7:
            '
        Case 8:
            a1(0).Checked = False
            a1(2).Checked = False
            a1(4).Checked = False
            a1(6).Checked = False
            a1(8).Checked = True
            a1(10).Checked = False
        Case 9:
            '
        Case 10:
            a1(0).Checked = False
            a1(2).Checked = False
            a1(4).Checked = False
            a1(6).Checked = False
            a1(8).Checked = False
            a1(10).Checked = True


    End Select
    mlIndex = Index

End Sub



Private Sub about_Click()
    Dim RRESULT
    RRESULT = ShellAbout(hWnd, " GAF58_4_FUN", " COMPILED BY Gamal Azim  - Aug-2004", Form1.Icon)

End Sub



Private Sub Form_KeyPress(KeyAscii As Integer)
    If KeyAscii = vbKeyEscape Then Call Go_Click      'Unload Me

End Sub

Private Sub Form_Load()
    'Call baby
    'Get menu choice setting
    'a1(GetSetting(App.Title, "Settings", "SaveValue")).Checked = True
    a1(Val(GetSetting(App.Title, "Settings", "SaveValue"))).Checked = True
    '
    '
    KeyPreview = True
    Move (Screen.Width - Width), 0                    '(Screen.Height - Height) / 12

    '===========================================
    ' call form on top
    Call SetOnTop
    '===========================================
    '
    'Call run on start if menu chicked
    OnLoadRun

End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
    'to save Menue choice
    'SaveSetting App.Title, "Settings", "SaveValue", Index
    SaveSetting App.Title, "Settings", "SaveValue", mlIndex

    '
    'Run on window start if menu start chicked
    OnClickRun

End Sub



Private Sub Go_Click()
    Timer4.Interval = 0
    Timer2.Interval = 1000
    Timer3.Interval = Timer2.Interval * 15
    'Unload Me
    'to save Menue choice
    'SaveSetting App.Title, "Settings", "SaveValue", Index
    SaveSetting App.Title, "Settings", "SaveValue", mlIndex

End Sub

Private Sub p1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Button = vbLeftButton Then
        ReleaseCapture
        SendMessage hWnd, WM_NCLBUTTONDOWN, _
                HTCAPTION, 0&
    End If

End Sub

Private Sub p1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Button = 2 Then PopupMenu menu

End Sub



Private Sub Timer1_Timer()
    If a1(0).Checked Then Call baby
    If a1(2).Checked Then Call gazelle
    If a1(4).Checked Then Call cootie
    If a1(6).Checked Then Call angela
    If a1(8).Checked Then Call violin
    If a1(10).Checked Then Call dream
    p1.Cls
    Me.Refresh

End Sub

Private Sub Timer2_Timer()
    Dim myleft As Integer
    Dim mytop As Long
    myleft = Int((Screen.Width - Me.Width) * Rnd)
    mytop = Int((Screen.Height - Me.Height) * Rnd)
    Form1.Top = mytop
    Form1.Left = myleft

End Sub

Private Sub Timer3_Timer()
    Timer2.Interval = 0
    'Unload Me
    End
End Sub

Private Sub Timer4_Timer()
    Dim mytop2 As Long
    mytop2 = Int(100 * Rnd)
    Form1.Top = mytop2

End Sub

المثال

example.zip

الرفع للفائدة

الرفع للفائدة

شكرا لك

Good idea mr belal go on god bless you

rasha

palestine

شكرا لبك ..وبجد فكره هايله

شكرا يا د/ بلال على الشغل الجامد دا

جزاك الله كل خير