♥♥ راسلنا لوضع اعلانك او من خلال شراء خدماتنا من خمسات وستحصل على مميزات اعلانية خيالية ♥♥
♥♥ ادعوا اصدقائك للاشتراك معنا لتصل جميع اعلانات التوظيف واخر الاخبار والمواضيع الى بريدكم الالكترونى مباشرة ♥♥
♥♥ ضع إعلانك معنا مجانا * وبدون تسجيل * ( نحقق لك الاشهار والانتشار وزيادة الاعضاء والزوار لدينا باك لينك عالي وارشفة عالية ومشاركات عبر التواصل الاجتماعي ) ♥♥
♥♥ ( لمتابعة آخر الاعلانات والوظائف والمواضيع والاخبار أولا بأول يرجى مراجعة موقعنا من كل حين لآخر حيث يتم النشر وبشكل مستمر لكافة المواضيع المتنوعة والهامة ) ♥♥
* منتديات هندسة بلا حدود * يتم تفعيل الحساب خلال 24 ساعة من قبل ادارة المنتدى او من خلال ايميل تسجيل العضو مباشرة *
الموضوع منقول للفائدة من منتداى خارجي للفائدة والتعلم ============== **************************** نبيل الدم ============== ***************************** [ اعضاء الظيوف الكرام ] كيفكم يا ابطال ان شاء الله بخير ؟ اليوم جيبلكم سورس برنامج تغيير الايقونات صنعي حيث لا تحتاج إلى ملف bsicon.dll رايت الكثير من الأعضاء يبحثون عن هذا الملف مو معدل لذا بحثت و وجدت الكود هذا حيث تكتفي بوضع الكود 1 في الفورم (Form) و الثاني في الموديل (Module)
Form كود: Private Sub Command1_Click() With dlg .DialogTitle = "Select Exe File..." .Filter = "Executable Files (*.exe)|*.exe" .ShowOpen End With
txtExe.Text = dlg.FileName End Sub
Private Sub Command2_Click() With dlg .DialogTitle = "Select Icon File..." .Filter = "Icons (*.ico)|*.ico" .ShowOpen End With
txtIco.Text = dlg.FileName End Sub
Private Sub Command3_Click() If ChangeIcon(txtExe.Text, txtIco.Text) Then MsgBox "Done" Else MsgBox "Error Occurred." End If End Sub
Module
كود: Option Explicit
Private Const OPEN_EXISTING As Long = &H3 Private Const INVALID_HANDLE_VALUE As Long = -1 Private Const GENERIC_READ As Long = &H80000000 Private Const FILE_ATTRIBUTE_NORMAL As Long = &H80 Private Const FILE_BEGIN As Long = &H0 Private Const RT_ICON As Long = &H3 Private Const RT_GROUP_ICON As Long = &HE
Private Type ICONDIRENTRY bWidth As Byte bHeight As Byte bColorCount As Byte bReserved As Byte wPlanes As Integer wBitCount As Integer dwBytesInRes As Long dwImageOffset As Long End Type
Private Type ICONDIR idReserved As Integer idType As Integer idCount As Integer End Type
Private Type GRPICONDIRENTRY bWidth As Byte bHeight As Byte bColorCount As Byte bReserved As Byte wPlanes As Integer wBitCount As Integer dwBytesInRes As Long nID As Integer End Type
Private Type GRPICONDIR idReserved As Integer idType As Integer idCount As Integer idEntries() As GRPICONDIRENTRY End Type
Private Declare Function CreateFile Lib "kernel32" Alias "CreateFileA" (ByVal lpFileName As String, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, lpSecurityAttributes As Any, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) As Long Private Declare Function ReadFile Lib "kernel32" (ByVal lFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToRead As Long, lpNumberOfBytesRead As Long, lpOverlapped As Any) As Long Private Declare Function SetFilePointer Lib "kernel32" (ByVal lFile As Long, ByVal lDistanceToMove As Long, lpDistanceToMoveHigh As Long, ByVal dwMoveMethod As Long) As Long Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long Private Declare Function BeginUpdateResource Lib "kernel32" Alias "BeginUpdateResourceA" (ByVal pFileName As String, ByVal bDeleteExistingResources As Long) As Long Private Declare Function UpdateResource Lib "kernel32" Alias "UpdateResourceA" (ByVal lUpdate As Long, ByVal lpType As Long, ByVal lpName As Long, ByVal wLanguage As Long, lpData As Any, ByVal cbData As Long) As Long Private Declare Function EndUpdateResource Lib "kernel32" Alias "EndUpdateResourceA" (ByVal lUpdate As Long, ByVal fDiscard As Long) As Long Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Public Function ChangeIcon(ByVal strExePath As String, ByVal strIcoPath As String) As Boolean Dim lFile As Long Dim lUpdate As Long Dim lRet As Long Dim i As Integer Dim tICONDIR As ICONDIR Dim tGRPICONDIR As GRPICONDIR Dim tICONDIRENTRY() As ICONDIRENTRY
Dim bIconData() As Byte Dim bGroupIconData() As Byte
For i = 0 To tGRPICONDIR.idCount - 1 tGRPICONDIR.idEntries(i).bWidth = tICONDIRENTRY(i).bWidth tGRPICONDIR.idEntries(i).bHeight = tICONDIRENTRY(i).bHeight tGRPICONDIR.idEntries(i).bColorCount = tICONDIRENTRY(i).bColorCount tGRPICONDIR.idEntries(i).bReserved = tICONDIRENTRY(i).bReserved tGRPICONDIR.idEntries(i).wPlanes = tICONDIRENTRY(i).wPlanes tGRPICONDIR.idEntries(i).wBitCount = tICONDIRENTRY(i).wBitCount tGRPICONDIR.idEntries(i).dwBytesInRes = tICONDIRENTRY(i).dwBytesInRes tGRPICONDIR.idEntries(i).nID = i + 1 Next i
lUpdate = BeginUpdateResource(strExePath, False) For i = 0 To tICONDIR.idCount - 1 ReDim bIconData(tICONDIRENTRY(i).dwBytesInRes) SetFilePointer lFile, tICONDIRENTRY(i).dwImageOffset, ByVal 0&, FILE_BEGIN Call ReadFile(lFile, bIconData(0), tICONDIRENTRY(i).dwBytesInRes, lRet, ByVal 0&)
If UpdateResource(lUpdate, RT_ICON, tGRPICONDIR.idEntries(i).nID, 0, bIconData(0), tICONDIRENTRY(i).dwBytesInRes) = False Then ChangeIcon = False CloseHandle (lFile) Exit Function End If
For i = 0 To tGRPICONDIR.idCount - 1 CopyMemory ByVal VarPtr(bGroupIconData(6 + 14 * i)), ByVal VarPtr(tGRPICONDIR.idEntries(i).bWidth), 14& Next
If UpdateResource(lUpdate, RT_GROUP_ICON, 1, 0, ByVal VarPtr(bGroupIconData(0)), UBound(bGroupIconData)) = False Then ChangeIcon = False CloseHandle (lFile) Exit Function End If
If EndUpdateResource(lUpdate, False) = False Then ChangeIcon = False CloseHandle (lFile) End If
Call CloseHandle(lFile) ChangeIcon = True End Function Public Function ExtractIcon(ByVal strExePath As String, ByVal strIcoPath As String) As Boolean 'In Progress End Function
مع العلم :
Command1 :جلب الملف الذي سنغير أيقونته Command2 :جلب الأيقونة Command3 : تغيير الأيقونة عند إضافة CommonDialog1 نعوضها ب dlg في (Name)
يعتبر موقع منتديات هندسة بلا حدود من المنتديات المشهورة والمهمة ومن المواقع الهندسية العربية على الانترنت ،وحتى الآن عدد الأعضاء المنتسبين له في المنتديات كأكبر تجمع هندسي عربي حتى الآن.
زيادة متابعين تيك توك
[url=https://estaql.com]خبير سيو
اعلانات سناب
محامي في الرياض
محاسب قانوني
شركة سيو
زيادة المتابعين
خدمات المحاسبة في الأردن
] إصنع برنامجك لتغيير الأيقونات بدون ملف ببرنامج v.b.6
هام جداً: قوانين المساهمة في المواضيع. انقر هنا للمعاينة
احترم مواضيع الآخرين ليحترم الآخرون مواضيعك لا تحتكر ال موضوع لنفسك بإرسال عدة مساهماتمتتالية عند طرح موضوع يجب أن تتأكد أن عنوان الموضوع مناسب او لا تحل بحسن الخلق و بأدب الحوار و النقاش < لا تنس أن اختلاف الرأي لا يفسد للود قضية, فلاتتهجم على عضو بدعوى أنه لا يشاطرك الرأي < ان قطعت عهدآ مع عضو فأوفي بوعدك لأنه دين عليك إن حصل خلاف بينك و بين عضو حول مسألة ما فلا تناقشا المشكله على العام بل على الخاص ان احترمت هذه الشروط البسيطة, ضمنت حقوقك و عرفت واجباتك. و هذه افضل طريقة تضمن بها لنفسك ثم لمساهماتك و مواضيعك البقاء و لمنتداك الإزدهار في موقعنا إدارة موقع ومنتديات هندسة بلا حدود للاعلانات والسيو
![] إصنع برنامجك لتغيير الأيقونات بدون ملف ببرنامج v.b.6 Images21](https://i.servimg.com/u/f55/17/67/07/80/tm/images21.jpg)
البلد
الاوسمة الخاصة
الجنس : 
عدد المساهمات : 
![] إصنع برنامجك لتغيير الأيقونات بدون ملف ببرنامج v.b.6 I_icon_minitime](https://2img.net/s/t/20/65/45/i_icon_minitime.gif){kind=icon}
الثلاثاء 22 يناير 2013, 11:17 pm
۩ஜ(نبيل الدم)ஜ۩
هام جداً: قوانين المساهمة في المواضيع. انقر هنا للمعاينة 
