قابل توجع علاقه مندان به بازي نويسي و گرافيك
چطور يك كهكشان با هزاران ستاره را ايجاد كنيم كه ستارگان به طرف ما در حركت باشند
خوب شروع مي كنيم اول ابزار زير را روي فرم بگزاريد
Picture1 = pb
يك picturebox روي فرم بگزاريد و نام ان را به pb تغيير دهيد
حالا يك ماجول ايجاد كنيد Module1 و كد هاي زير را به ان كپي كنيد
Public Type POINTAPI
X As Integer
Y As Integer
End Type
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 StretchBlt Lib "gdi32" (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 dwRop As Long) As Long
Public Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long) As Long
Public Declare Function MoveToEx Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, lpPoint As POINTAPI) As Long
Public Declare Function LineTo Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long) As Long
Public Type t3DVector
X As Integer
Y As Integer
z As Integer
End Type
Public Type tSpaceship
zm As Integer
RollAngle As Integer
TurnAngle As Integer
PitchAngle As Integer
End Type
Public NUMSTARS As Integer
Public CometsOn As Boolean
Public Const VIEWWIDTH = 200
Public Const VIEWHEIGHT = 150
Public Const VIEWDEPTH = 300
Public Star() As t3DVector
Public Ship As tSpaceship
Public i As Integer
Public i2 As Integer
Public X As Integer
Public Y As Integer
Public z As Integer
Public Const LENS = VIEWDEPTH
Public LensDivDist As Single
Public DispWidth As Integer
Public DispHeight As Integer
Public Const PBWIDTH = 600
Public Const PBHEIGHT = 450
Public Const CX = 300
Public Const CY = 225
Public Sine(0 To 359) As Single
Public Cosine(0 To 359) As Single
Public lpPoint As POINTAPI
Public Sub BuildTrigTable()
For i = 0 To 359
Sine(i) = Sin(i * PIdiv180)
Cosine(i) = Cos(i * PIdiv180)
Next
End Sub
بعد از كپي كردن كد ها به ماژول كد هاي زير را به فرم تان كپي كنيد
Private Sub Form_Load()
Me.BackColor = vbBlack
Me.ScaleMode = 3
pb.ForeColor = vbRed
pb.BackColor = vbBlack
NUMSTARS = 2000
CometsOn = 1
SortLayout
Show
BuildTrigTable
CreateStars
Ship.zm = 1
If CometsOn Then
DoStarsAndComets
Else
End If
End Sub
Private Sub SortLayout()
Move 0, 0, Screen.Width, Screen.Height
pb.Move 0, 0, 600, 450
DispWidth = Screen.Height * 1.36 / Screen.TwipsPerPixelY
DispHeight = Screen.Height * 0.977 / Screen.TwipsPerPixelY
End Sub
Private Sub CreateStars()
ReDim Star(1 To NUMSTARS)
For i = 1 To NUMSTARS
Star(i).X = Rnd * VIEWWIDTH - VIEWWIDTH \ 2
Star(i).Y = Rnd * VIEWHEIGHT - VIEWHEIGHT \ 2
Star(i).z = Rnd * VIEWDEPTH
Next
End Sub
Private Sub DoStarsAndComets()
On Error Resume Next
Do
DoEvents
pb.Cls
For i = 1 To NUMSTARS
'move them
If Star(i).z <= 0 Then
Star(i).z = VIEWDEPTH
Else
LensDivDist = LENS / Star(i).z
X = CX + Star(i).X * LensDivDist
Y = CY - Star(i).Y * LensDivDist
Select Case X
Case 0 To PBWIDTH
Select Case Y
Case 0 To PBHEIGHT
MoveToEx pb.hdc, X, Y, lpPoint
Case Else
Star(i).z = Star(i).z - Ship.zm
GoTo NextOne
End Select
Case Else
Star(i).z = Star(i).z - Ship.zm
GoTo NextOne
End Select
Star(i).z = Star(i).z - Ship.zm
'draw them
LensDivDist = LENS / Star(i).z
X = CX + Star(i).X * LensDivDist
Y = CY - Star(i).Y * LensDivDist
Select Case X
Case 0 To PBWIDTH
Select Case Y
Case 0 To PBHEIGHT
Select Case i Mod 100
Case 0
pb.DrawWidth = 2
pb.ForeColor = vbYellow
LineTo pb.hdc, X, Y
pb.ForeColor = vbWhite
pb.DrawWidth = 1
Case 50
pb.DrawWidth = 2
pb.ForeColor = vbCyan
LineTo pb.hdc, X, Y
pb.ForeColor = vbWhite
pb.DrawWidth = 1
Case Else
LineTo pb.hdc, X, Y
End Select
End Select
End Select
End If
NextOne:
Next
StretchBlt hdc, 0, 0, DispWidth, DispHeight, pb.hdc, 0, 0, PBWIDTH, PBHEIGHT, vbSrcCopy
Loop
End Sub
خوب كد ها تمام شده برنامه را اجرا كنيد باحاله نهههههههههههههههههههههههههههههههههههههههههه
با كوچك ترين تغيير در متغيير هاي كد ها بالا مي توانيد چيز هاي حرفه اي تري ايجاد كنيد
پايان
تبديل عدد به حروف انگليسي مثلا اگه 1 نوشتيم براي ما كلمه one را برگرداند
برنامه اي كه روي حروف فارسي كار ميكنه رو قبلا فكر كنم گفته باشم ولي اين برنامه براي تبديل
عداد انگليسي به حروف انگليسي است
براي اين كار ابزار زير را به فرم اضافه كنيد
Command1
Text1
Text2
و يك فرم از نوع ClassModule ايجاد كنيد به نام Class1
و كد هاي زير را به ان كپي كنيد
Private Data(9, 3) As String
Private Sub Class_Initialize()
'Data for conversion
Data(0, 0) = "one": Data(1, 0) = "two": Data(2, 0) = "three"
Data(3, 0) = "four": Data(4, 0) = "five": Data(5, 0) = "six"
Data(6, 0) = "seven": Data(7, 0) = "eight": Data(8, 0) = "nine"
Data(9, 0) = "ten"
Data(0, 1) = "hundred": Data(1, 1) = "ten": Data(2, 1) = "twenty"
Data(3, 1) = "thirty": Data(4, 1) = "fourty": Data(5, 1) = "fifty"
Data(6, 1) = "sixty": Data(7, 1) = "seventy": Data(8, 1) = "eighty"
Data(9, 1) = "ninety"
Data(0, 3) = "ten": Data(1, 3) = "eleven": Data(2, 3) = "twelve"
Data(3, 3) = "thirteen": Data(4, 3) = "fourteen": Data(5, 3) = "fifteen"
Data(6, 3) = "sixteen": Data(7, 3) = "seventeen": Data(8, 3) = "eighteen"
Data(9, 3) = "nineteen"
End Sub
Public Function ToWords(ByVal NumberStr As String) As String
Dim z As String, x As String, Temp As String, c As String
Dim a As Integer, b As Integer, i As Integer
Dim iPos As Integer
'remove redundant spaces
NumberStr = Trim(Replace(NumberStr, ",", ""))
a = Len(NumberStr)
Temp = NumberStr
If Val(NumberStr) = 0 Then
ToWords = "zero!"
Exit Function
End If
'get rid of any decimals
iPos = InStr(Temp, ".")
If iPos > 0 Then Temp = Left(Temp, iPos - 1)
While ((a Mod 3) <> 0)
Temp = "0" & Temp
a = Len(Temp)
Wend
NumberStr = Temp
For i = a - 2 To 1 Step -3
b = b + 1
Temp = Mid(NumberStr, i, 3)
z = ""
' "Intelligent" routines
'------------------------
If Temp <> "000" Then
c = Left(Temp, 1)
If c <> "0" Then z = " " & Data(Val(c) - 1, 0) & " hundred"
c = Mid(Temp, 2, 1)
If c <> "0" Then
If c <> "1" Then
z = z & " " & Data(Val(c), 1)
Else
z = z & " " & Data(Val(Right(Temp, 2)) - 10, 3)
End If
End If
If Right(Temp, 1) <> "0" And Mid(Temp, 2, 1) <> "1" Then z = z & " " & Data(Val(Right(Temp, 1)) - 1, 0)
End If
'------------------------
If z <> "" Then
Select Case b
Case 1:
x = z
Case 2:
x = z & " thousand" & x
Case 3:
x = z & " million" & x
Case 4:
x = z & " billion" & x
Case 5:
x = z & " trillion" & x
Case Else:
Exit Function
'you can easily add more range
'like Case 6: can be "zillion"? :) (whatever)
End Select
End If
Next
ToWords = x
End Function
Private Function Replace(ByVal sInput As String, _
sFind As String, sReplace As String) As String
Dim lPos As Long
Dim sAns As String
Dim sWkg As String
sAns = ""
sWkg = sInput
lPos = InStr(sWkg, sFind)
If lPos <> 0 Then
Do
If lPos >= Len(sWkg) Then
sAns = sAns & Left(sWkg, Len(sWkg) - 1) & sReplace
Else
sAns = sAns & Left(sWkg, lPos - 1) & sReplace
End If
sWkg = Mid(sWkg, lPos + 1)
lPos = InStr(sWkg, sFind)
DoEvents
Loop While lPos > 0
sAns = sAns & sWkg
Else
sAns = sInput
End If
Replace = sAns
End Function
بعد از اين كه كد هاي بالا را به كلاس كپي كردين حالا نوبت به كد هاي فرم است
كدهاي زير را به فرم اضافه كنيد
Dim convert As Class1
Private Sub Command1_Click()
Text2 = convert.ToWords(Text1.Text)
End Sub
Private Sub Form_Load()
Set convert = New Class1
End Sub
كد ها تمام شد حالا برنامه را اجرا كرده و در تكست 1 ان يك شماره را بنويسيد ميبينيد كه
در تكست دوم عدد تكست اول به صورت حروف تبديل شده
پايان
چطور يك بازي ساده گرافيكي بنويسيم
حتما اين برنامه را بنويسيد چون در اينده به شما كمك زيادي خاهد كرد
براي شروع يك تايمر روي فرم قرار داده و سرعت ان را 1 قرار دهيد
Timer1
حالا كد زير را به فرم كپي كنيد
Dim dr As Integer
Dim posx As Integer, posy As Integer
Dim score As Integer
Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
dr = KeyCode
End Sub
Private Sub Form_Load()
Me.ScaleMode = 3
Me.AutoRedraw = True
score = 0
posx = 0: posy = 0
dr = 0
Timer1.Enabled = True
Cls
Caption = "abbas"
ScaleMode = 3
ForeColor = vbWhite
BackColor = vbBlack
Line (0, 0)-(400, 400), vbCyan, B
Line (1, 1)-(399, 399), vbCyan, B
For i = 1 To 25
Randomize (Timer)
x = Int(Rnd * 368) + 16
y = Int(Rnd * 368) + 16
Line (x, y)-(x + 15, y + 15), vbRed, BF
Next
setpoint: x = Int(Rnd * 368) + 16
y = Int(Rnd * 368) + 16
If Point(x, y) = vbRed Then GoTo setpoint
PSet (x, y), vbMagenta
posx = x
posy = y
End Sub
Private Sub Timer1_timer()
If dr = 0 Then Exit Sub
If dr = 37 Then x = posx - 2: y = posy
If dr = 39 Then x = posx + 2: y = posy
If dr = 40 Then x = posx: y = posy + 2
If dr = 38 Then x = posx: y = posy - 2
If Point(x, y) <> vbBlack Then
Timer1.Enabled = False
Line (posx, posy)-(x, y), vbMagenta
ans = MsgBox("پايان بازي", vbInformation, "صوتي زياد مي ديها")
ans = MsgBox(" ايا مي خاهيد دوباره بازي كنيد?", vbYesNo + vbExclamation, "جواب بده")
If ans = vbYes Then Form_Load Else Unload Me
Form_Load
Exit Sub
End If
Line (posx, posy)-(x, y), vbMagenta
score = score + 1
Caption = "شما بازي را باختي" + Str(score)
posx = x
posy = y
End Sub
كد ها به پايان رسيد شما براي بازي كردن بايد از كليد هاي جهت نما استفاده كنيد بازي باحاليه نهههههه
پايان
چطور دكمه استارت منو را برداريم براي برداشتن دكمه استارت اول از همه دو تا كامند باتون روي
فرم بگزاريد
Command1
Command2
و يك Module1 ايجاد كنيد و كد زير را به ماجول اضافه كنيد
Private 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
Private Declare Function GetDesktopWindow Lib "user32" () As Long
Private Declare Function GetWindow Lib "user32" (ByVal hwnd As Long, ByVal wCmd As Long) As Long
Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
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 Declare Function SetParent Lib "user32" (ByVal hWndChild As Long, ByVal hWndNewParent As Long) As Long
Private Declare Function GetParent Lib "user32" (ByVal hWndChild As Long) As Long
Private Const GW_NEXT = 2
Private Const GW_CHILD = 5
Private Const BM_SETIMAGE = &HF7
Property Get hwnd() As Long
Dim CHwnd1 As Long, CHwnd2 As Long
Dim CLS_NM As String * 7
CHwnd1 = GetDesktopWindow
CHwnd1 = GetWindow(CHwnd1, GW_CHILD)
Do While CHwnd1 <> 0
CHwnd2 = GetWindow(CHwnd1, GW_CHILD)
Do While CHwnd2 <> 0
GetClassName CHwnd2, CLS_NM, 7
If Left(CLS_NM, 6) = "Button" Then
hwnd = CHwnd2
Exit Property
End If
CHwnd2 = GetWindow(CHwnd2, GW_NEXT)
Loop
CHwnd1 = GetWindow(CHwnd1, GW_NEXT)
Loop
End Property
Property Let hPic(ByVal hPicture As Long)
PostMessage hwnd, BM_SETIMAGE, 0, hPicture
End Property
Property Let Width(ByVal sWidth As Long)
SetWindowPos hwnd, 0, 0, 0, sWidth / 15, Height / 15, 2
End Property
Property Get Width() As Long
Dim tmpRECT As RECT
GetWindowRect hwnd, tmpRECT
Width = (tmpRECT.Right - tmpRECT.Left) * 15
End Property
Property Let Height(ByVal sHeight As Long)
SetWindowPos hwnd, 0, 0, 0, Width / 15, sHeight / 15, 2
End Property
Property Get Height() As Long
Dim tmpRECT As RECT
GetWindowRect hwnd, tmpRECT
Height = (tmpRECT.Bottom - tmpRECT.Top) * 15
End Property
Property Let Left(ByVal lX As Long)
SetWindowPos hwnd, 0, lX / 15, Top / 15, 0, 0, 1
End Property
Property Get Left() As Long
Dim tmpPLC As WINDOWPLACEMENT
tmpPLC.Length = Len(tmpPLC)
GetWindowPlacement Start.hwnd, tmpPLC
Left = tmpPLC.rcNormalPosition.Left * 15
End Property
Property Let Top(ByVal lY As Long)
SetWindowPos hwnd, 0, Left / 15, lY / 15, 0, 0, 1
End Property
Property Get Top() As Long
Dim tmpPLC As WINDOWPLACEMENT
tmpPLC.Length = Len(tmpPLC)
GetWindowPlacement Start.hwnd, tmpPLC
Top = tmpPLC.rcNormalPosition.Top * 15
End Property
Property Let Parent(ByVal hParent As Long)
SetParent hwnd, hParent
End Property
Property Get Parent() As Long
Parent = GetParent(hwnd)
End Property
حالا كد هاي زير را به فرم كپي كنيد
Dim hParent As Long
Private Sub Command1_Click()
Module1.Parent = Me.hwnd
End Sub
Private Sub Command2_Click()
Module1.Parent = hParent
End Sub
Private Sub Command3_Click()
End Sub
Private Sub Form_Load()
hParent = Module1.Parent
End Sub
حالا اگر روي دكمه اول كليك كنيد دكمه استارت روي فرم شما ترسيم شده و از جاش كنده مي شه
و دكمه دوم دكمه استارت را از فرم شما برمي دارد و در جاي خودش مي گزارد
پايان
گزاشتن دو عكس رويه هم
يكي از افكت هاي فتوشاپ كه مي توانيد عكس تان را روي اب يا اسمان
بندازيد در كل افكت حرفه اي است
قبلا در وب لاگ كدي شبيه به اين كد گزاشته بودم كه البته اين كد فرق داره بهتر بگم كه امتحانش مي ارزه
ابزار زير را روي فرم بگزاريد
Picture1
Picture2
Picture3
Command1
3 تا پيكچر باكس يك اندازه و يك دكمه يا باتون روي فرم بگزاريد
در پيكچر 1 و پيكچر 2 عكس هاي متفاوت قرار دهيد ولي در پيكچر 3 چيزي قرار ندهيد
حالا كد زير را به فرك كپي كنيد
Private Declare Function SetPixel Lib "gdi32" (ByVal hDC As Long, ByVal x As Long, ByVal y As Long, ByVal crColor As Long) As Long
Private Declare Function GetPixel Lib "gdi32" (ByVal hDC As Long, ByVal x As Long, ByVal y As Long) As Long
Dim x, y As Integer
Dim color1, color2 As Long
Dim r, g, b As Integer
Dim r2, g2, b2 As Integer
Dim percent As Integer
Private Sub Command1_Click()
percent = 50
Picture3.Width = Picture1.Width
Picture3.Height = Picture1.Height
For x = 0 To Picture1.ScaleWidth - 1
For y = 0 To Picture1.ScaleHeight - 1
color1 = GetPixel(Picture1.hDC, x, y)
r = color1 Mod 256
b = Int(color1 / 65536)
g = (color1 - (b * 65536) - r) / 256
color2 = GetPixel(Picture2.hDC, x, y)
r2 = color2 Mod 256
b2 = Int(color2 / 65536)
g2 = (color2 - (b2 * 65536) - r2) / 256
r = (((100 - percent) * r) + (percent * r2)) / 100
g = (((100 - percent) * g) + (percent * g2)) / 100
b = (((100 - percent) * b) + (percent * b2)) / 100
SetPixel Picture3.hDC, x, y, RGB(r, g, b)
Next y
If x Mod 10 = 0 Then Picture3.Refresh
Next x
Picture3.Refresh
End Sub
Private Sub Form_Load()
Picture1.ScaleMode = 3
Picture2.ScaleMode = 3
Picture3.ScaleMode = 3
End Sub
حالا روي كامند باتون كليد كنيد كنيد در پيكچر 3 چي مي بينيد زياد حال نكنيد
پايان
چطور عكس بگروند دكستاپ را عوض كنيم
خوب براي اين كار ابزار زير را روي فرم بگزاريد
Picture1
Command1
در پيكچر بوكس عكسي قرار دهيد و حالا كد زير را توي فرم كپي كنيد
Private Declare Function SystemParametersInfo Lib "user32" _
Alias "SystemParametersInfoA" ( _
ByVal uAction As Long, _
ByVal uParam As Long, _
ByRef lpvParam As Any, _
ByVal fuWinIni As Long) _
As Long
Private Const SPI_SETDESKWALLPAPER As Long = 20&
Private Const SPIF_UPDATEINIFILE As Long = &H1&
Private Declare Function SetPixelV Lib "gdi32" ( _
ByVal hDC As Long, _
ByVal X As Long, _
ByVal Y As Long, _
ByVal crColor As Long) _
As Long
Private Sub Command1_Click()
Dim lRet As Long
Dim sFile As String
sFile = App.Path & _
IIf(Right$(App.Path, 1) = "\", _
"", "\") & "SimplePlasma.bmp"
SavePicture Picture1.Picture, sFile
lRet = SystemParametersInfo(SPI_SETDESKWALLPAPER, _
0&, _
ByVal sFile, _
SPIF_UPDATEINIFILE)
Debug.Assert lRet <> 0
End Sub
خوب بعد از اجراي برنامه روي دكمه يا كامند باتون كليد كنيد مي بينيد كه عكس بگروند دكستاپ
عوض شد
پايان
ساخت فرم چند رنگ البته من مي دونم منظورم نگرفتين پس امتحان كنيد
خوب كد زير را به فرم تان كپي كنيد
Private Sub Form_Load()
Me.ScaleMode = 3
End Sub
Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim VR, VG, VB As Single
Dim Color1, Color2 As Long
Dim R, G, B, R2, G2, B2 As Integer
Dim temp As Long
Color1 = QBColor(Rnd * 15)
Color2 = vbBlue
temp = (Color1 And 255)
R = temp And 255
temp = Int(Color1 / 256)
G = temp And 255
temp = Int(Color1 / 65536)
B = temp And 255
temp = (Color2 And 255)
R2 = temp And 255
temp = Int(Color2 / 256)
G2 = temp And 255
temp = Int(Color2 / 65536)
B2 = temp And 255
VR = Abs(R - R2) / Form1.ScaleHeight
VG = Abs(G - G2) / Form1.ScaleHeight
VB = Abs(B - B2) / Form1.ScaleHeight
If R2 < R Then VR = -VR
If G2 < G Then VG = -VG
If B2 < B Then VB = -VB
For Y = 0 To Form1.ScaleHeight
R2 = R + VR * Y
G2 = G + VG * Y
B2 = B + VB * Y
Form1.Line (0, Y)-(Form1.ScaleWidth, Y), RGB(R2, G2, B2)
Next Y
VR = Abs(R - R2) / Form1.ScaleWidth
VG = Abs(G - G2) / Form1.ScaleWidth
VB = Abs(B - B2) / Form1.ScaleWidth
For X = 0 To Form1.ScaleWidth
R2 = R + VR * X
G2 = G + VG * X
B2 = B + VB * X
'draw the line and continue through the loop
Form1.Line (X, 0)-(X, Form1.ScaleHeight), RGB(R2, G2, B2)
Next X
End Sub
حالا برنامه را اجرا كنيد و روي فرم با موس كليك كنيد
پايان
خوب حتما با ابزار سطل رنگ در نرم افزار هاي مثل فتوشاپ كار كرده ايد كه مي توانستيد قسمتي از نقاشي
تان را رنگ كنيد بدون اين كه به قسمت هاي ديگر رنگ تا ثير بگزارد اصلا راحت تر بگم بريد ابزار
پاينت يا نقاشي و يندوز را اجرا كنيد و يك دايره بسته بكشيد و با سطل رنگ رنگ داخل دايره را عوض
كنيد ما مي خاهيم يكي مثل اين رو درست كنيم
با با خسته شدم اين قدر در بالا توضيح دادم تو عمرم در باره هيچ موضوعي اين قدر توضيح ننوشته بودم
خوب بريم سر وقت كار خودما ابزار زير را روي فرم بگزاريد
Picture1
خوب حالا كد ها زير را به فرك كپي كنيد
Private Declare Function ExtFloodFill Lib "Gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal crColor As Long, ByVal wFillType As Long) As Long
Dim X1, Y1
Dim draw
Dim temp
Private Sub Form_Load()
Picture1.ScaleMode = 3
Me.ScaleMode = 3
End Sub
Private Sub Picture1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
draw = 1
If Button = 1 Then
X1 = X
Y1 = Y
ElseIf Button = 2 Then
Randomize
Picture1.FillColor = RGB(Int(Rnd * 255), Int(Rnd * 255), Int(Rnd * 255))
ExtFloodFill Picture1.hdc, X, Y, Picture1.Point(X, Y), 1
End If
End Sub
Private Sub Picture1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button = 1 Then
If draw = 1 Then
Picture1.Line (X1, Y1)-(X, Y)
X1 = X
Y1 = Y
End If
End If
End Sub
Private Sub Picture1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
draw = 0
End Sub
حالا برنامه را اجرا كرده و با كليد چپ موس دايره يا هر چيز ديگري را روي پيكچر باكس
نقاشي كنيد و با كليد راست رنگ داخل ان را عوض كنيد
پايان
توجع : من قبلا تو تاپيك هاي قبل گفته بودم مي خوام اموزش ساخت بانك هاي اطلاعاتي با ويژال بيسيك
به وسيله اكسس و فاكس پرو و اكسل را بهتون بدم كه انگاري اسقبالي نشد چون در نظرات من هيچ
استقبالي از اين موضوع نديدم و حتي گفته بودم مي خواهم بهتون بگم كه چگونه مي شه با ويژال بيسيك
نرم افزار رس هك (ResHacke ) را ساخت نرم افزار رس هك براي باز كردن dll ها و فايل هاي اجراي كه
مي شه با اون نرم افزار ها رو فارسي كرد و يا روي برنامه ها كرم برزيد كه اون هم انگار استقبالي نشد
من اينارو گفتم كه ديگه يكي نگه پس چرا به قولت عمل نكرد .........................
باز هم مي گم اگه مي خا هيد برنامه نويسي رو حرفه ياد بگريد اول ريجستري ويندوز رو ياد بگريد
يك خاهش ديگم دارم البته خاهش نيست حرف بايد گوش كنيد اصلا زوريه اونم اين كه ديگه تو نظرات
البته 4 تا نظر بيشتر نيست تو همون 4 تا نظر در باره پول در اوردن از اينتر نت و اين جور كس شرا
نزاريد درباره تبادل وب لاگ هم بگم من حس تبادل وب لاگ ندارم نمودم چرا يك چيز ديگه شما چقدر
بيكاريد كه نوشته ها مو خونديد حتي خود من هم حاظر نيستم چيزاي كه مي نويسم رو بخونم واقعا كه شما
(سانسر ---سانسر --- سانسر -- ) هستيد ..
با تشكر عباس كوتر
باز هم يك كار گرافيكي ديگه اگه از من ميشنويد اين كار گرافيكي رو انجام دهيد مطمعنا به شما در
اينده كمك بسيار زياد مي كنه
خوب ما مي خواهيم يك كره طراحي كنيم كه بشه با موس اونو بچر خونيد البته كاملا گرافيكي
ابزار زير را روي فرم بگزاريد
Picture1
خوب بريم سر كد ها
كد هاي زير را به فرم كپي كنيد
DefInt A-Q
DefSng R-Z
Dim grxhi, gryhi
Dim svrx(), svry(), svrz()
Dim rx(), ry(), rz()
Dim xs(), zs()
Dim xT, yT
Dim zrad
Dim pp As POINTAPI
Dim culgreen&, culcyan&
Const zpi# = 3.1415927
Const dtr# = zpi# / 180
Const rtd# = 180 / zpi#
Private Sub Form_Load()
Picture1.AutoRedraw = True
grxhi = (1 + 360 / 18): gryhi = (1 + 360 / 18)
ReDim svrx(21, 21), svry(21, 21), svrz(21, 21)
ReDim rx(21, 21), ry(21, 21), rz(21, 21)
ReDim xs(21, 21), zs(21, 21)
culgreen& = QBColor(10)
culcyan& = QBColor(11)
zrad = 100
FillArrays
End Sub
Private Sub FillArrays()
ye = Val(1000)
zaspect = Val(8) / 10
j = 0
For ztheta = 0 To 360 Step 18
i = 0
j = j + 1
zt = ztheta * dtr#
For zphi = 0 To 360 Step 18
i = i + 1
zp = zphi * dtr#
X = zrad * Sin(zt) * Cos(zp)
Y = zrad * Sin(zt) * Sin(zp)
Z = zaspect * zrad * Cos(zt)
svrx(i, j) = X
svry(i, j) = Y
svrz(i, j) = Z
Next zphi
Next ztheta
xT = 0: yT = 0
picDisplay_MouseMove 1, 0, xT, yY
End Sub
Private Sub picDisplay_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
End Sub
Public Sub CalculateScreenPoints(X, Y)
xcen = Picture1.ScaleWidth / 2
ycen = Picture1.ScaleHeight / 2
zang = (zpi# / 2) * ((X - xcen) / xcen)
xang = -(zpi# / 2) * ((Y - ycen) / ycen)
For j = 1 To gryhi
For i = 1 To grxhi
rx(i, j) = svrx(i, j) * Cos(zang) + svry(i, j) * Sin(zang)
ry(i, j) = svry(i, j) * Cos(zang) - svrx(i, j) * Sin(zang)
rz(i, j) = svrz(i, j)
Next i
Next j
For j = 1 To gryhi
For i = 1 To grxhi
ryy = ry(i, j) * Cos(xang) - rz(i, j) * Sin(xang)
rz(i, j) = ry(i, j) * Sin(xang) + rz(i, j) * Cos(xang)
ry(i, j) = ryy
Next i
Next j
scfx = 1
xoff = Picture1.Width / 2
xmin = 0
scfz = 1
zoff = Picture1.Height / 2
zmin = 0
For j = 1 To gryhi
For i = 1 To grxhi
xs(i, j) = scfx * (rx(i, j) - xmin) + xoff
zs(i, j) = scfz * (rz(i, j) - zmin) + zoff
Next i
Next j
End Sub
Private Sub Picture1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
CalculateScreenPoints X, Y
Picture1.Cls
phdc& = Picture1.hdc
Picture1.ForeColor = culgreen&
For j = 1 To gryhi
res& = MoveToEx(phdc&, xs(1, j), zs(1, j), pp)
For i = 1 + 1 To grxhi
res& = LineTo(phdc&, xs(i, j), zs(i, j))
Next i
Next j
Picture1.ForeColor = culcyan&
For i = 1 To grxhi
res& = MoveToEx(phdc&, xs(i, 1), zs(i, 1), pp)
For j = 1 + 1 To gryhi
res& = LineTo(phdc&, xs(i, j), zs(i, j))
Next j
Next i
End Sub
تذكر براي كيفيت بيشتر و گرافيك بهتر بگروند پيكچر باكس را به رنگ سياه تغيير دهيد
حالا برنامه را اجرا كرده و با موس روي پيكچر باكس برويد اين نه دايركس نه اوپن جي ال
فقط كمي فكره
پايان
گيم تولز يك برنامه ساده در باره تغييب و گربز خوب اين پروژه كاربردي و در حد مبتدي
ابزار زير را روي فرم بگزاريد
Label1
Label2
Timer1
حالا كد زير را به فرم كپي كنيد
Dim a As Integer
Private Sub Form_Load()
Timer1.Interval = 1
Me.BackColor = vbBlack
Label1.FontSize = 24
Label2.FontSize = 24
Label1.ForeColor = vbRed
Label2.ForeColor = vbRed
Label1.Caption = "abbas"
Label2.Caption = "<0>"
End Sub
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Label1.Left = X
Label1.Top = Y
a = a + 1
End Sub
Private Sub Timer1_Timer()
If Label1.Left > Label2.Left - (Label1.Width) Then Label2.Left = Label2.Left + 30
If Label1.Left < Label2.Left + (Label1.Width / 2) Then Label2.Left = Label2.Left - 30
If Label1.Top > Label2.Top - (Label1.Height / 2) Then Label2.Top = Label2.Top + 30
If Label1.Top < Label2.Top + (Label1.Height / 2) Then Label2.Top = Label2.Top - 30
End Sub
حلا با موس از دست ليبل دو فرار كنيد
پايان
سلا م الان ساعت 12:26 شب .امروز چهارشنبه بود . امشب باشگاه بودم خيلي خستم اصلا نمودنم چي
مي خوام بنويسم حس كد نوشتن ندارم اصلا حس ندارم پس خدا فظ ما كه رفتيم بخوابيم
خر پف ... خرپف ... خرپف .. خر پف
For i:=1 to 10000000 step 2
"خر پف" print
Next
نظرتون در باره حلقه بالا چيه !
انگار خواب ندارم گفتم اخرين كد رو بنويسم بعد بگيرم بخوابم
اين كدي كه پايين ميزارم واقعا عاليه پس حتما انجامش بدين پشيمون نمي شين كه هيچ منو دعا هم مي كننين
نمودونم در باره كار برنامه چي بگم فقط مي تونم بگم خيلي باحاله فقط همين
ابزار زير را روي فرم بگزاريد
Picture1
Picture2
اول از همه 2picture را روي فرم گزاشته به هما ه اندازه ي كه فرم است picture2 را بزرك كنيد
حالا picture1 را درون picture2 قرار دهيد براي picture2 عكسي بر گزينيد
حالا كد هاي زير را به فرم كپي كنيد
Dim X1 As Single, Y1 As Single
Dim a As Integer, b As Integer
Private Sub Form_Activate()
Picture2.Visible = False
Me.BackColor = vbBlack
Picture1.PaintPicture Picture2.Image, 0, 0, Picture1.Width, Picture1.Height, Picture1.Left, Picture1.Top, Picture1.Width, Picture1.Height
Picture1.Line (1, 1)-(Picture1.Width - 1, Picture1.Height - 1), , B
End Sub
Private Sub Form_Load()
a = 10
b = 10
End Sub
Private Sub Picture1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
X1 = X
Y1 = Y
Picture1.AutoRedraw = False
End Sub
Private Sub Picture1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button = 1 Then
Picture1.Left = IIf(X < X1, Picture1.Left - (X1 - X), Picture1.Left + (X - X1))
Picture1.Top = IIf(Y < Y1, Picture1.Top - (Y1 - Y), Picture1.Top + (Y - Y1))
Picture1.PaintPicture Picture2.Image, 0, 0, Picture1.Width, Picture1.Height, Picture1.Left, Picture1.Top, Picture1.Width, Picture1.Height
Picture1.Line (1, 1)-(Picture1.Width - 1, Picture1.Height - 1), , B
End If
End Sub
Private Sub Picture1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
Picture1.AutoRedraw = True
End Sub
Private Sub Picture1_Validate(Cancel As Boolean)
Picture1.Left = IIf(X < X1, Picture1.Left - (X1 - X), Picture1.Left + (X - X1))
Picture1.Top = IIf(Y < Y1, Picture1.Top - (Y1 - Y), Picture1.Top + (Y - Y1))
Picture1.PaintPicture Picture2.Image, 0, 0, Picture1.Width, Picture1.Height, Picture1.Left, Picture1.Top, Picture1.Width, Picture1.Height
Picture1.Line (1, 1)-(Picture1.Width - 1, Picture1.Height - 1), , B
End Sub
حالا برنامه را اجرا كرده و روي picture1 كليك كرده و با موس اون رو بكشيد چي مي بينيد
پايان
چشام داره سياهي ميره ----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
shut down