+- منتدى فيجوال بيسك لكل العرب | منتدى المبرمجين العرب (http://vb4arb.com/vb)
+-- قسم : قسم لغة الفيجوال بيسك VB.NET (http://vb4arb.com/vb/forumdisplay.php?fid=182)
+--- قسم : قسم اسئلة VB.NET (http://vb4arb.com/vb/forumdisplay.php?fid=183)
+--- الموضوع : طلب تحويل كود من vb6 إلى vb.net (/showthread.php?tid=44083)
طلب تحويل كود من vb6 إلى vb.net - Alhootti1 - 16-10-22
كود :
Option Explicit Event Click() Private Declare Function ExtFloodFill& Lib "gdi32" (ByVal HDc&, ByVal x&, ByVal y&, Optional ByVal CrColor& = vbWhite, Optional ByVal FillType& = 1) Private Declare Function TextOutW& Lib "gdi32" (ByVal HDc&, ByVal x&, ByVal y&, ByVal lpString&, ByVal nCount&) Private Declare Function GetTextExtentPoint32W Lib "gdi32" (ByVal HDc&, ByVal lpUniCode&, ByVal CharCount&, lpSize As Any) As Long Public Enum UniBoxSymbols 'a definition of the "Box"-Unicode-Points as "speaking Enum-Values" symNone = 32 'the Space-Char-Value (to render nothing per default) symHorz = &H2500 symDownAndRight = &H250C symDownAndLeft = &H2510 symUpAndRight = &H2514 symUpAndLeft = &H2518 End Enum 'the Public Properties of a given Tooth (each Section as "center, left, top etc." can be filled with a differing Color) Public Nr&, BorderColor&, CrCenter&, CrLeft&, CrTop&, CrRight&, CrBottom& Public BraceSymbol As UniBoxSymbols, CenterSymbol As String Private Sub UserControl_Initialize() ScaleMode = vbPixels: AutoRedraw = True: DrawWidth = 2: FillStyle = 0 FontName = "Arial": FontSize = 10: FontBold = True ResetAllFillColorsToWhite 'initialize all "Section-Colors" to white End Sub Private Sub UserControl_Resize() Refresh End Sub Private Sub UserControl_Click() RaiseEvent Click End Sub Public Sub ResetAllFillColorsToWhite() 'a Public Method which resets all FillColors to their default (white) CrCenter = vbWhite: CrLeft = vbWhite: CrTop = vbWhite: CrRight = vbWhite: CrBottom = vbWhite End Sub Public Sub Refresh() 'and a Public Refresh-Method, to reflect the "current state" of a given Tooth in the Controls Render-Output Cls Dim Size As Long: Size = ScaleWidth Dim Offs As Long: Offs = Size \ 4 + 1 FillColor = vbWhite: ForeColor = BorderColor Line (1, 1)-(Size - 1, Size - 1), , B 'Background with Border Line (1, 1)-(Size - 1, Size - 1): Line (1, Size - 1)-(Size - 1, 1) 'Diagonals FillColor = CrCenter: Line (Offs, Offs)-(Size - Offs, Size - Offs), , B 'CenterSquare FillColor = CrLeft: ExtFloodFill HDc, Offs \ 2, Size \ 2 FillColor = CrTop: ExtFloodFill HDc, Size \ 2, Offs \ 2 FillColor = CrRight: ExtFloodFill HDc, Size - Offs \ 2, Size \ 2 FillColor = CrBottom: ExtFloodFill HDc, Size \ 2, Size - Offs \ 2 TextOutCentered Nr, 10, vbBlack, Size \ 2 + 10 'print the Tooth-Nr-Caption at the bottom TextOutCentered ChrW(BraceSymbol), 20 * Size / 31, vbBlue 'print the BraceSymbolChar (a ChrW translation of the Enums UnicodePoint) TextOutCentered CenterSymbol, 20 * Size / 31, vbMagenta 'print the CenterSymbolChar UserControl.Refresh End Sub Private Sub TextOutCentered(ByVal S$, FontSize, FontColor, Optional ByVal yOffs&) ForeColor = FontColor: Font.Size = FontSize If S = ChrW(symHorz) Then S = String(2, S) 'double the Horz-Char (to cover the entire width) Dim x As Long, y As Long, TW As Long, TH As Long CalcTextExtent S, TW, TH 'we also need to use a matching unicode-capable TextExtent-measuring x = (ScaleWidth - TW) \ 2 y = yOffs + (ScaleWidth - TH) \ 2 TextOutW HDc, x, y, StrPtr(S), Len(S) 'use TextOutW instead of Print, to be Unicode-Aware End Sub Private Sub CalcTextExtent(S$, dx, dy) Dim Ext&(1): GetTextExtentPoint32W HDc, StrPtr(S), Len(S), Ext(0) dx = Ext(0): dy = Ext(1)
End Subكود :
Option Explicit Private SelTooth As ucTooth, T As ucTooth, i As Long Private Sub Form_Load() ScaleMode = vbPixels For i = 11 To 85 Select Case i Case 11 To 18, 21 To 28, 31 To 38, 41 To 48, 51 To 55, 61 To 65, 71 To 75, 81 To 85 If i > 11 Then Load ucT(i) 'instantiate the yet missing tooth-control ucT(i).Nr = i: ucT(i).Visible = True End Select Next ucT(11).CrCenter = vbGreen: ucT(12).CrCenter = vbRed ucT(21).CrCenter = vbGreen: ucT(22).CrCenter = vbRed ucT(31).CenterSymbol = "#" ucT(41).CenterSymbol = "$" ucT(51).BraceSymbol = symDownAndLeft For i = 52 To 54: ucT(i).BraceSymbol = symHorz: Next ucT(55).BraceSymbol = symDownAndRight ucT(61).BraceSymbol = symUpAndRight For i = 62 To 64: ucT(i).BraceSymbol = symHorz: Next ucT(65).BraceSymbol = symUpAndLeft SetBraceColorEdges 85, 81, vbCyan, False 'we use a little Helper-Function to "format a range" SetBraceColorEdges 71, 75, vbCyan, True 'we use a little Helper-Function to "format a range" RefreshAllTeeth 'refresh the state of all teeth we have changed the State-Variables for (above) End Sub Private Sub SetBraceColorEdges(idxFrom, idxTo, Color, ByVal Top As Boolean) ucT(idxFrom).CrLeft = Color For i = idxFrom To idxTo Step IIf(idxFrom < idxTo, 1, -1) If Top Then ucT(i).CrTop = Color Else ucT(i).CrBottom = Color Next ucT(idxTo).CrRight = Color End Sub Public Sub RefreshAllTeeth() For Each T In ucT: T.Refresh: Next End Sub Private Sub Form_Resize() Const TopOffs = 40 For Each T In ucT Dim dx: dx = ScaleWidth \ 19 'calculate the width of a single tooth Dim dy: dy = dx + 20 'set the height of the tooth (it's higher because of the Caption) Dim cx: cx = (ScaleWidth - dx) \ 2 'calc the horizontal center-offset on our Form Dim sc: sc = Choose(T.Nr \ 10, -1, 1, 1, -1, -1, 1, 1, -1) 'scale-factor in x-direction Dim x0: x0 = cx + sc * (8 + dx \ 2 + ((T.Nr Mod 10) - 1) * (dx + 4)) 'x-Offset Dim y0: y0 = TopOffs + Choose((T.Nr + 10) \ 20, 0, 3, 1, 2) * (dy + 12) 'y-Offset ucT(T.Nr).Move x0, y0, dx, dy Next RefreshAllTeeth End Sub Private Sub ucT_Click(Index As Integer) If Not SelTooth Is Nothing Then SelTooth.BorderColor = vbBlack 'reset the BorderColor of the last selected Tooth Set SelTooth = ucT(Index) SelTooth.BorderColor = vbBlue 'mark the currently selected Tooth with a blue Border RefreshAllTeeth Caption = "Currently selected Tooth: " & SelTooth.Nr
End SubRE: طلب تحويل كود من vb6 إلى vb.net - anes - 16-10-22
ضع الكود في مثال بالفيجول 6 واعد رفهه
RE: طلب تحويل كود من vb6 إلى vb.net - Alhootti1 - 16-10-22
تمام ان شاء الله
RE: طلب تحويل كود من vb6 إلى vb.net - Alhootti1 - 17-10-22
السلام عليكم
تفضل يا أخي Anes
وضعت الكود في مثال
2.12.0.0
RE: طلب تحويل كود من vb6 إلى vb.net - anes - 17-10-22
(17-10-22, 01:07 AM)Alhootti1 كتب : السلام عليكم
تفضل يا أخي Anes
وضعت الكود في مثال
2.12.0.0
كود :
Partial Friend Class ucTooth
Inherits System.Windows.Forms.UserControl
Shadows Event Click(ByVal Sender As Object, ByVal e As EventArgs)
Public Enum UniBoxSymbols
symNone = 32
symHorz = &H2500S
symDownAndRight = &H250CS
symDownAndLeft = &H2510S
symUpAndRight = &H2514S
symUpAndLeft = &H2518S
End Enum
Public BorderColor As Color
Public CrTop As Color
Public CrRight, CrCenter, Nr, CrLeft, CrBottom As Integer
Public BraceSymbol As UniBoxSymbols
Public CenterSymbol As String = ""
Public Sub New()
MyBase.New()
InitializeComponent()
ReLoadForm(False)
End Sub
Private _scaleMode As ScaleModeConstants = ScaleModeConstants.VbTwips
Public Enum ScaleModeConstants : int16
VbCentimeters = 7
VbCharacters = 4
VbContainerPosition = 9
VbContainerSize = 10
VbHimetric = 8
VbInches = 5
VbMilimeters = 6
VbPixels = 3
VbPoints = 2
VbTwips = 1
VbUser = 0
End Enum
Private Sub UserControl_Initialize()
Me.setAutoRedraw(True)
Me.setDrawWidth(2)
Me.setFillStyle(btnSupport.UpgradeStubs.VBRUN_FillStyleConstants.getvbFSSolid())
Font = Font.Clone(name:="Arial") : Font = Font.Clone(size:=10) : Font = Font.Clone(bold:=True)
ResetAllFillColorsToWhite()
End Sub
Private Sub UserControl_Resize(ByVal eventSender As Object, ByVal eventArgs As EventArgs) Handles MyBase.Resize
Refresh()
End Sub
Private Sub UserControl_Click(ByVal eventSender As Object, ByVal eventArgs As EventArgs) Handles MyBase.Click
RaiseEvent Click(Me, Nothing)
End Sub
Public Sub ResetAllFillColorsToWhite()
CrCenter = ColorTranslator.ToOle(Color.White) : CrLeft = ColorTranslator.ToOle(Color.White) : CrTop = Color.White : CrRight = ColorTranslator.ToOle(Color.White) : CrBottom = ColorTranslator.ToOle(Color.White)
End Sub
Public Overrides Sub Refresh()
Refresh() : Dim Size_Renamed As Integer = ClientRectangle.Width * 15 : Dim Offs As Integer = Size_Renamed \ 4 + 1
Me.setFillColor(Color.White) : ForeColor = BorderColor
Using g As Graphics = Me.CreateGraphics()
Dim p As Pen = New Pen(Color.Black)
p.DashStyle = DashStyle.Solid
g.DrawRectangle(p, 0, 0, CInt((Size_Renamed - 2) / 15), CInt((Size_Renamed - 2) / 15))
End Using
Using g2 As Graphics = Me.CreateGraphics()
Dim p2 As Pen = New Pen(Color.Black)
p2.DashStyle = DashStyle.Solid
g2.DrawLine(p2, 0, 0, CInt((Size_Renamed - 1) / 15), CInt((Size_Renamed - 1) / 15))
End Using
Using g3 As Graphics = Me.CreateGraphics()
Dim p3 As Pen = New Pen(Color.Black)
p3.DashStyle = DashStyle.Solid
g3.DrawLine(p3, 0, CInt((Size_Renamed - 1) / 15), CInt((Size_Renamed - 1) / 15), 0)
End Using 'Diagonals
Me.setFillColor(ColorTranslator.FromOle(CrCenter))
Using g4 As Graphics = Me.CreateGraphics()
Dim p4 As Pen = New Pen(Color.Black)
p4.DashStyle = DashStyle.Solid
g4.DrawRectangle(p4, CInt(Offs / 15), CInt(Offs / 15), CInt((Size_Renamed - Offs - Offs) / 15), CInt((Size_Renamed - Offs - Offs) / 15))
End Using 'CenterSquare
Me.setFillColor(ColorTranslator.FromOle(CrLeft)) : Using g5 As Graphics = CreateGraphics()
g5.ReleaseHdc()
End Using
Me.setFillColor(CrTop) : Using g6 As Graphics = CreateGraphics()
g6.ReleaseHdc()
End Using
Me.setFillColor(ColorTranslator.FromOle(CrRight)) : Using g7 As Graphics = CreateGraphics()
g7.ReleaseHdc()
End Using
Me.setFillColor(ColorTranslator.FromOle(CrBottom)) : Using g8 As Graphics = CreateGraphics()
g8.ReleaseHdc()
End Using
TextOutCentered(CStr(Nr), 10, Color.Black, Size_Renamed \ 2 + 10) 'print the Tooth-Nr-Caption at the bottom
TextOutCentered(Strings.ChrW(BraceSymbol).ToString(), 20 * Size_Renamed / 31, Color.Blue) 'print the BraceSymbolChar (a ChrW translation of the Enums UnicodePoint)
TextOutCentered(CenterSymbol, 20 * Size_Renamed / 31, Color.Magenta) 'print the CenterSymbolChar
MyBase.Refresh()
End Sub
Private Sub TextOutCentered(ByVal S As String, ByVal FontSize As Double, ByVal FontColor As Color, Optional ByVal yOffs As Integer = 0)
ForeColor = FontColor : Font = Font.Clone(size:=FontSize)
If S = Strings.ChrW(UniBoxSymbols.symHorz).ToString() Then S = New String(S, 2) 'double the Horz-Char (to cover the entire width)
Dim TW, TH As Integer
CalcTextExtent(S, TW, TH) 'we also need to use a matching unicode-capable TextExtent-measuring
Dim x As Integer = (ClientRectangle.Width * 15 - TW) \ 2
Dim y As Integer = yOffs + (ClientRectangle.Width * 15 - TH) \ 2
Using g As Graphics = CreateGraphics()
Dim gh As GCHandle = GCHandle.Alloc(S, GCHandleType.Pinned)
Dim tmpPtr As IntPtr = gh.AddrOfPinnedObject()
btnSupport.SafeNative.gdi32.TextOutW(g.GetHdc().ToInt32(), x, y, tmpPtr.ToInt32(), Strings.Len(S))
gh.Free()
g.ReleaseHdc()
End Using 'use TextOutW instead of Print, to be Unicode-Aware
End Sub
Private Sub CalcTextExtent(ByVal S As String, ByRef dx As Integer, ByRef dy As Integer)
Dim Ext(1) As Integer : Using g As Graphics = CreateGraphics()
Dim gh As GCHandle = GCHandle.Alloc(S, GCHandleType.Pinned)
Dim tmpPtr As IntPtr = gh.AddrOfPinnedObject()
btnSupport.SafeNative.gdi32.GetTextExtentPoint32W(g.GetHdc().ToInt32(), tmpPtr.ToInt32(), Strings.Len(S), Ext(0))
gh.Free()
g.ReleaseHdc()
End Using
dx = Ext(0) : dy = Ext(1)
End Sub
End Classكود :
Partial Friend Class Form1
Inherits System.Windows.Forms.Form
Public Sub New()
MyBase.New()
Dim mustCallFormLoad As Boolean = False
If m_vb6FormDefInstance Is Nothing Then
If m_InitializingDefInstance Then
m_vb6FormDefInstance = Me
Else
Try
If Not (System.Reflection.Assembly.GetExecutingAssembly().EntryPoint Is Nothing) AndAlso System.Reflection.Assembly.GetExecutingAssembly().EntryPoint.DeclaringType Is Me.GetType() Then
m_vb6FormDefInstance = Me
End If
Finally
mustCallFormLoad = True
End Try
End If
End If
isInitializingComponent = True
InitializeComponent()
isInitializingComponent = False
ReLoadForm(False)
If mustCallFormLoad And Not (m_vb6FormDefInstance Is Nothing) Then
m_vb6FormDefInstance.Form_Load()
End If
End Sub
Public Shared myActiveForm As Form
Private Sub Form1_Activated(ByVal eventSender As System.Object, ByVal eventArgs As System.EventArgs) Handles MyBase.Activated
If Not (myActiveForm Is eventSender) Then
myActiveForm = eventSender
End If
End Sub
Private SelTooth, T As ucTooth
Private i As Integer
Private Shared Function FindBaseObject(ByVal controlArray As Array) As Object
For Each obj As Object In controlArray
If obj IsNot Nothing AndAlso Not (TypeOf obj Is ToolStripSeparator) Then
Return obj
End If
Next
Return Nothing
End Function
Public Shared Sub LoadControl(ByVal controlContainer As Control, ByVal controlName As String, ByVal index As Integer)
Dim fieldInfo As FieldInfo = controlContainer.[GetType]().GetField(controlName)
If (fieldInfo IsNot Nothing) AndAlso fieldInfo.FieldType.IsArray Then
Dim controlArray As Array = CType(fieldInfo.GetValue(controlContainer), Array)
Dim baseControl As Object = FindBaseObject(controlArray)
If baseControl IsNot Nothing Then
If index > controlArray.Length - 1 Then
Dim redimAux As Array = Array.CreateInstance(controlArray.[GetType]().GetElementType(), index + 1)
Array.Copy(controlArray, redimAux, Math.Min(controlArray.Length, redimAux.Length))
controlArray = redimAux
End If
If controlArray.GetValue(index) IsNot Nothing Then
Throw New Exception("Object already loaded")
End If
fieldInfo.SetValue(controlContainer, controlArray)
End If
Else
Throw New Exception("Cannot load this component")
End If
End Sub
Private Sub Form_Load()
For i = 11 To 85
Select Case i
Case 11 To 18, 21 To 28, 31 To 38, 41 To 48, 51 To 55, 61 To 65, 71 To 75, 81 To 85
If i > 11 Then LoadControl(Me, "ucT", i)
ucT(i).Nr = i : ucT(i).Visible = True
End Select
Next
ucT(11).CrCenter = ColorTranslator.ToOle(Color.Lime) : ucT(12).CrCenter = ColorTranslator.ToOle(Color.Red)
ucT(21).CrCenter = ColorTranslator.ToOle(Color.Lime) : ucT(22).CrCenter = ColorTranslator.ToOle(Color.Red)
ucT(21).CrLeft = ColorTranslator.ToOle(Color.Lime) : ucT(22).CrLeft = ColorTranslator.ToOle(Color.Red)
ucT(31).CenterSymbol = "X"
ucT(41).CenterSymbol = "$"
ucT(51).BraceSymbol = ucTooth.UniBoxSymbols.symDownAndLeft
For i = 52 To 54 : ucT(i).BraceSymbol = ucTooth.UniBoxSymbols.symHorz : Next
ucT(55).BraceSymbol = ucTooth.UniBoxSymbols.symDownAndRight
ucT(61).BraceSymbol = ucTooth.UniBoxSymbols.symUpAndRight
For i = 62 To 64 : ucT(i).BraceSymbol = ucTooth.UniBoxSymbols.symHorz : Next
ucT(65).BraceSymbol = ucTooth.UniBoxSymbols.symUpAndLeft
SetBraceColorEdges(85, 81, Color.Cyan, False)
SetBraceColorEdges(71, 75, Color.Cyan, True)
RefreshAllTeeth()
End Sub
Private Sub SetBraceColorEdges(ByVal idxFrom As Integer, ByVal idxTo As Integer, ByVal Color As Color, ByVal Top_Renamed As Boolean)
ucT(idxFrom).CrLeft = ColorTranslator.ToOle(Color)
For i = idxFrom To idxTo Step IIf(idxFrom < idxTo, 1, -1)
If Top_Renamed Then ucT(i).CrTop = Color Else ucT(i).CrBottom = ColorTranslator.ToOle(Color)
Next
ucT(idxTo).CrRight = ColorTranslator.ToOle(Color)
End Sub
Public Sub RefreshAllTeeth()
For i_2 As Integer = 0 To ucT.Length - 1
If Not (ucT(i_2) Is Nothing) Then : ucT(i_2).Refresh() : End If
Next
End Sub
Private isInitializingComponent As Boolean
Private Sub Form_Resize(ByVal eventSender As Object, ByVal eventArgs As EventArgs) Handles MyBase.Resize
If isInitializingComponent Then
Exit Sub
End If
Dim y0, x0, sc As Double
Dim dy As Integer
Dim dx, cx As Integer
Const TopOffs As Integer = 40
For i_2 As Integer = 0 To ucT.Length - 1
If Not (ucT(i_2) Is Nothing) Then : dx = ClientRectangle.Width * 15 \ 19
ucT(ucT(i_2).Nr).SetBounds(x0 / 15, y0 / 15, dx / 15, dy / 15)
End If
Next
RefreshAllTeeth()
End Sub
Private Sub ucT_Click(ByVal Sender As Object, ByVal e As EventArgs) Handles _ucT_11.Click
Dim Index As Integer = Array.IndexOf(Me.ucT, Sender)
If Not (SelTooth Is Nothing) Then SelTooth.BorderColor = Color.Black
SelTooth = ucT(Index)
SelTooth.BorderColor = Color.Blue
'Setup Textboxes:
Text1(0).Text = ucT(Index).CenterSymbol
Text1(1).Text = CStr(ucT(Index).CrCenter)
Text1(2).Text = CStr(ucT(Index).CrBottom)
Text1(3).Text = CStr(ucT(Index).CrLeft)
Text1(4).Text = CStr(ucT(Index).CrRight)
Text1(5).Text = CStr(ucT(Index).Nr)
RefreshAllTeeth()
Text = "Currently selected Tooth: " & SelTooth.Nr
Dim Menue As String = "", PopUp As String = ""
With SelTooth
PopUp = PopUp & "CrLeft Blue,1;"
PopUp = PopUp & "Top Blue,2;"
PopUp = PopUp & "Top Green,3;"
PopUp = PopUp & "Top X,4;"
PopUp = PopUp & "Center Symbol #,5;"
PopUp = PopUp & "Center Symbol $,6"
PopUp = PopUp & "Center Symbol $,7"
'add more
Menue = CStr(mnuTooth(Me.Handle.ToInt32(), PopUp))
Select Case Menue
Case 1
Text1(1).Text = CStr(255) 'Top Red
Case 2
Text1(1).Text = ColorTranslator.ToOle(Color.Blue).ToString() 'Top Blue
Case 3
Text1(1).Text = ColorTranslator.ToOle(Color.Lime).ToString() 'Top Green
Case 4
' '-----------------------
Case 5
Text1(0).Text = "#"
Case 6
Text1(0).Text = "$"
End Select
End With
'now pass the Color from the Textbox...
ucT(Index).CrCenter = CInt(Text1(1).Text)
ucT(Index).CenterSymbol = Text1(0).Text
'Update the selected Tooth with selected color(s) / Symbols
RefreshAllTeeth()
End Sub
End ClassRE: طلب تحويل كود من vb6 إلى vb.net - Alhootti1 - 17-10-22
جزاك الله خيرا يا أخي
لكن تظهر عندي عدة أخطاء في الكود
فياليت تسوي لي مثال و ترفقه هنا أكون شاكر لك
RE: طلب تحويل كود من vb6 إلى vb.net - Alhootti1 - 18-10-22
السلام عليكم
ارجو من الإخوة تصحيح الأخطاء الموجودة في المثال المرفق
2.12.0.0