'Inserts the picture at the current insertion point
Public Function InsertPicture(RTB As RichTextBox, pic As StdPicture)
Dim strRTFall As String
Dim lStart As Long
With RTB
.SelText = Chr(&H9D) & .SelText & Chr(&H81)
strRTFall = .TextRTF
strRTFall = Replace(strRTFall, "\'9d", PictureToRTF(pic))
.TextRTF = strRTFall
'position cursor past new insertion
lStart = .Find(Chr(&H81))
strRTFall = Replace(strRTFall, "\'81", "")
.TextRTF = strRTFall
.SelStart = lStart
End With
End Function
'returns the RTF string representation of our picture
Public Function PictureToRTF(pic As StdPicture) As String
Dim hMetaDC As Long, hMeta As Long, hPicDC As Long, hOldBmp As Long
Dim Bmp As BITMAP, Sz As Size, Pt As POINTAPI
Dim sTempFile As String, screenDC As Long
Dim headerStr As String, retStr As String, byteStr As String
Dim ByteArr() As Byte, nBytes As Long
Dim fn As Long, i As Long, j As Long
sTempFile = App.Path & "\~pic" & ((Rnd * 1000000) + 1000000) \ 1 & ".tmp" 'some temprory file
If Dir(sTempFile) <> "" Then Kill sTempFile
'Create a metafile which is a collection of structures that store a
'picture in a device-independent format.
hMetaDC = CreateMetaFile(sTempFile)
'set size of Metafile window
SetMapMode hMetaDC, MM_ANISOTROPIC
SetWindowOrgEx hMetaDC, 0, 0, Pt
GetObject pic.Handle, Len(Bmp), Bmp
SetWindowExtEx hMetaDC, Bmp.Width, Bmp.Height, Sz
'save sate for later retrieval
SaveDC hMetaDC
'get DC compatible to screen
screenDC = GetDC(0)
hPicDC = CreateCompatibleDC(screenDC)
ReleaseDC 0, screenDC
'set out picture as new DC picture
hOldBmp = SelectObject(hPicDC, pic.Handle)
'copy our picture to metafile
BitBlt hMetaDC, 0, 0, Bmp.Width, Bmp.Height, hPicDC, 0, 0, vbSrcCopy
'TransparentBlt hMetaDC, 0, 0, Bmp.Width, Bmp.Height, hPicDC, 0, 0, Bmp.Width, Bmp.Height, vbBlack
'cleanup - close metafile
SelectObject hPicDC, hOldBmp
DeleteDC hPicDC
DeleteObject hOldBmp
'retrieve saved state
RestoreDC hMetaDC, True
hMeta = CloseMetaFile(hMetaDC)
DeleteMetaFile hMeta
'header to string we want to insert
headerStr = "{\pict\wmetafile8" & _
"\picw" & pic.Width & "\pich" & pic.Height & _
"\picwgoal" & Bmp.Width * Screen.TwipsPerPixelX & _
"\pichgoal" & Bmp.Height * Screen.TwipsPerPixelY & _
" "
'read metafile from disk into byte array
nBytes = FileLen(sTempFile)
ReDim ByteArr(1 To nBytes)
fn = FreeFile()
Open sTempFile For Binary Access Read As #fn
Get #fn, , ByteArr
Close #fn
Dim nlines As Long
'turn each byte into two char hex value
i = 0
byteStr = ""
Do
byteStr = byteStr & vbCrLf
For j = 1 To 39
i = i + 1
If i > nBytes Then Exit For
byteStr = byteStr & Hex00(ByteArr(i))
Next j
Loop While i < nBytes
'string we will be inserting
retStr = headerStr & LCase(byteStr) & vbCrLf & "}"
PictureToRTF = retStr
'remove temp metafile
Kill sTempFile
End Function
'adds leading zero to hex value if needed.
Public Function Hex00(icolor As Byte) As String
Hex00 = Right("0" & Hex(icolor), 2)
End FunctionPublic Function imageToHex(img As Image) As String
Dim ms As New MemoryStream
img.Save(ms, ImageFormat.Png)
Dim bytes() As Byte = ms.ToArray()
Dim hex As String = BitConverter.ToString(bytes)
Return hex.Replace("-", "")
End Function
Public Sub InsertImageRTF(ByVal strImage As String)
Dim btFileStream() As Byte
btFileStream = My.Computer.FileSystem.ReadAllBytes(strImage)
'RichTextBox1.Text = System.Text.Encoding.UTF7.GetString(btFileStream)
Dim s As Image = Image.FromFile(strImage)
Dim strRTF As String = ""
strRTF = "{\rtf1\ansi\ansicpg1252\deff0\deflang1033{\fonttbl{\f0\fnil\fcharset0 Calibri;}}{\*\generator Msftedit 5.41.21.2510;}\viewkind4\uc1\pard\sa200\sl276\slmult1\lang9\f0\fs22 testing\par\par\pard\sa200\sl240\slmult1{\pict\wmetafile8\" + s.Width.ToString + "\pich" + s.Height.ToString + "\picwgoal5924\pichgoal1860 hex " + imageToHex(s) + "}}"
Me.Rtf = strRTF
Debug.Print(Me.Rtf)
End SubPrivate Sub iPartColor(ByRef R As Long, ByRef G As Long, ByRef B As Long, myCAT As Object)
' //// Define object selection
Dim oSel As INFITF.Selection
oSel = myCAT.ActiveDocument.Selection
'//// Search and save all surfaces in active document in oSelection collection
oSel.Search("Topology.Face.Color = *, All")
Dim DefaultVisProperties '//// As VisProperty
DefaultVisProperties = myCAT.ActiveDocument.Selection.visProperties
Dim colorArray As Long() = {R, G, B}
'//// Get PartBody's default color
DefaultVisProperties.GetRealColor(colorArray) '// Error is right on this line " Type mis-matched"
End SubALTER PROCEDURE [dbo].[Get_Prices_Item_By_ID]
@ItemID int
as
begin
Select ItemID,FirstUnitWholeSalePrice,FirstUnitShopperPrice,FirstUnitDemotionsPrice,FirstUnitPriceDefult,SecondUnitWholeSalePrice,SecondUnitShopperPrice,SecondUnitDemotionsPrice,SecondUnitPriceDefult,ThirdUnitWholeSalePrice,ThirdUnitShopperPrice,ThirdUnitDemotionsPrice,ThirdUnitPriceDefult,DefultPrice from ItemsPricesTbl Where ItemID=@ItemID
EndPrivate Function exeReader(ByRef cmd As SqlCommand, ByRef dr As SqlDataReader) As Integer
Dim retval As Integer = -1
cmd.Connection = Me.Connection
Try
If cmd.CommandType = CommandType.StoredProcedure Then
Dim pr As New SqlParameter("@retval", SqlDbType.Int)
pr.Direction = ParameterDirection.ReturnValue
cmd.Parameters.Add(pr)
End If
If cmd.Connection.State = ConnectionState.Closed Then cmd.Connection.Open()
dr = cmd.ExecuteReader()
If cmd.CommandType = CommandType.StoredProcedure Then retval = cmd.Parameters("@retval").Value
Catch ex As Exception
Throw New Exception(ex.Message)
Finally
Me.close()
End Try
Return retval
End FunctionFriend Function Get_Prices_Item_By_ID(ByRef cmd As SqlCommand, ByRef dr As SqlDataReader, ByVal ItemID As Integer) As Integer
Dim retval As String
cmd = New SqlCommand("Get_Prices_Item_By_ID")
daa.SelectCommand.Parameters.AddWithValue("@FirstUnitWholeSalePrice", SqlDbType.Decimal)
daa.SelectCommand.Parameters.AddWithValue("@FirstUnitShopperPrice", SqlDbType.Decimal)
daa.SelectCommand.Parameters.AddWithValue("@FirstUnitDemotionsPrice", SqlDbType.Decimal)
daa.SelectCommand.Parameters.AddWithValue("@FirstUnitPriceDefult", SqlDbType.Bit)
daa.SelectCommand.Parameters.AddWithValue("@SecondUnitWholeSalePrice", SqlDbType.Decimal)
daa.SelectCommand.Parameters.AddWithValue("@SecondUnitShopperPrice", SqlDbType.Decimal)
daa.SelectCommand.Parameters.AddWithValue("@SecondUnitDemotionsPrice", SqlDbType.Decimal)
daa.SelectCommand.Parameters.AddWithValue("@SecondUnitPriceDefult", SqlDbType.Bit)
daa.SelectCommand.Parameters.AddWithValue("@ThirdUnitWholeSalePrice", SqlDbType.Decimal)
daa.SelectCommand.Parameters.AddWithValue("@ThirdUnitShopperPrice", SqlDbType.Decimal)
daa.SelectCommand.Parameters.AddWithValue("@ThirdUnitDemotionsPrice", SqlDbType.Decimal)
daa.SelectCommand.Parameters.AddWithValue("@ThirdUnitPriceDefult", SqlDbType.Bit)
daa.SelectCommand.Parameters.AddWithValue("@DefultPrice", SqlDbType.Int)
dr = cmd.ExecuteReader()
Return retval
End FunctionPublic Function Get_Prices_Item_By_ID(ByVal ItemID As Integer) As DataTable
Dim dt As New DataTable
p.Get_Prices_Item_By_ID(dt)
Return dt
End FunctionModule Module1
Private Sub callTEST()
TEST()
End Sub
End Module
'------------------------
Module Module2
Public Sub TEST()
MsgBox("HERE")
End Sub
End Module Private Sub Picturebox1_MouseMove(sender As Object, e As MouseEventArgs) Handles Picturebox1.MouseMove
On Error Resume Next
Dim img As Bitmap
img = Picturebox1.BackgroundImage
Dim iY, iX
iX = (MousePosition.X - Me.Left - Me.pcbBarve.Left) * (img.Width / Me.pcbBarve.Width)
iY = (MousePosition.Y - Me.Top - Me.pcbBarve.Top) * (img.Height / Me.pcbBarve.Height)
Dim c As Color = img.GetPixel(iX, iY)
'Im displying RGB values of color picked in Textboxes
If ShowRGB = True Then
TextBox2.Text = c.R
TextBox1.Text = c.G
TextBox3.Text = c.B
End If
End Sub DGVScadaEquipmentGeneration.DataSource = Nothing
DGVScadaEquipmentGeneration.Rows.Clear()
DGVScadaEquipmentGeneration.Refresh()
DGVScadaEquipmentGeneration.DataSource = TbEquipmentScadaBindingSource
DsProjectData.AcceptChanges()
<Add New List Here .....>Dim Content As HttpContent = New StringContent("test test test")
Using http As New HttpClient()
Using response As HttpResponseMessage = Await http.PostAsync("http://192.168.1.103/api/posttest", Content)
Dim result = Await response.Content.ReadAsStringAsync()
Using ms = New MemoryStream(Encoding.UTF8.GetBytes(result))
End Using
End Using
End Using'Form
Dim LDMS As New List(Of DMS)
If cGeneral.FillDMS(DtSet, LDMS, Me, iexcelcount) = False Then
Me.Close()
Exit Sub
End If Friend Function FillDMS(ByVal ds As DataSet, ByRef DMSList As List(Of DMS), ByRef frm As Form2, i As Integer) As Boolean
Dim Dt As New DateTime
Dim strDateFrom As String
Dim dc As Double
frm.ProgressBarExcelLoad.Visible = True
frm.ProgressBarExcelLoad.Minimum = 1
frm.ProgressBarExcelLoad.Maximum = i
frm.ProgressBarExcelLoad.Value = 1
frm.ProgressBarExcelLoad.Step = 1
Try
For Each row As DataRow In ds.Tables("Voucher").Rows
''etc
DMSList.Add(cl)
frm.ProgressBarExcelLoad.PerformStep() ' step +
next
return
