QUICBASIC 4.5 Program now in QB64 - date

I took a QB45 application and produced a QB64 application from it over 100,000 lines of code. All the pricing was hard coded in the program so I started reading from CSV files but now I need the date from the CSV file without putting a directory to a text file and reading for the date. I found this code below
The problem when I run it is that the assembler is for 16 bit registers and I am using 32 or 64 with windows 7 and i5 core. Can anyone help me to figure out how the date will be returned in a longer int value from the register?
'===========================================================================
' Subject: GET/SET FILE DATE/TIME Date: Unknown Date (00:00)
' Author: Matt Hart Code: QB, PDS
' Keys: GET,SET,FILE,DATE,TIME Packet: DOS.ABC
'===========================================================================
' FILEDATE.BAS by Matt Hart
'
' Gets or sets a file date/time
'
' GetFileDateTime returns the Date in MM-DD-YYYY format
' and the Time in HH:MM:SS
' SetFileDateTime expects the Date and Time in the same formats
'$INCLUDE: 'QB.BI' ' Use your path to QB or QBX.BI
DEFINT A-Z
DECLARE SUB GetFileDateTime (F$, Dat$, Tim$, Ecode%)
DECLARE SUB SetFileDateTime (F$, Dat$, Tim$, Ecode%)
' ------------------------- Sample code
F$ = LTRIM$(RTRIM$(COMMAND$))
CALL GetFileDateTime(F$, Dat$, Tim$, Ecode)
IF NOT Ecode THEN
PRINT F$; " date is "; Dat$
PRINT F$; " time is "; Tim$
ELSE
PRINT "1 Error = "; Ecode
END
END IF
NewTim$ = "01:01:02"
NewDat$ = "02-02-1980"
CALL SetFileDateTime(F$, NewDat$, NewTim$, Ecode)
IF Ecode THEN
PRINT "2 Error = "; Ecode
END
END IF
CALL GetFileDateTime(F$, Dat$, Tim$, Ecode)
IF Ecode THEN
PRINT "3 Error = "; Ecode
END
END IF
PRINT F$; " new date is "; Dat$
PRINT F$; " new time is "; Tim$
CALL SetFileDateTime(F$, Dat$, Tim$, Ecode)
IF Ecode THEN
PRINT "4 Error = "; Ecode
END
END IF
END
' ------------------------------------
SUB GetFileDateTime (F$, Dat$, Tim$, Ecode)
Ecode = 0
DIM InRegs AS RegTypeX
DIM OutRegs AS RegTypeX
InRegs.ax = &H3D00 ' Open file function
DIM FileName AS STRING * 128 ' Use fixed length
FileName = F$ + CHR$(0) ' Must be ASCIIZ string
InRegs.ds = VARSEG(FileName) ' Fixed length makes these
InRegs.dx = VARPTR(FileName) ' come out right
CALL INTERRUPTX(&H21, InRegs, OutRegs) ' Open the file
IF NOT OutRegs.flags THEN ' No error
Handle = OutRegs.ax ' Save DOS file handle
InRegs.ax = &H5700 ' Get date/time function
InRegs.bx = Handle
CALL INTERRUPTX(&H21, InRegs, OutRegs)
HMS& = OutRegs.cx ' Use long integer for
IF HMS& < 0& THEN HMS& = 65536 + HMS& ' positive numbers
Hours = HMS& \ 2048& ' Hours is first 5 bits
Minutes = (HMS& AND 2047&) \ 31& ' Minutes is next 6 bits
Seconds = HMS& AND 31& ' Seconds is last 5 bits
H$ = LTRIM$(STR$(Hours))
M$ = LTRIM$(STR$(Minutes)): IF LEN(M$) = 1 THEN M$ = "0" + M$
S$ = LTRIM$(STR$(Seconds)): IF LEN(S$) = 1 THEN S$ = "0" + S$
Tim$ = H$ + ":" + M$ + ":" + S$
YMD& = OutRegs.dx ' Long int here too
IF YMD& < 0 THEN YMD& = 65536 + YMD& ' Convert to + if needed
Year = 1980& + YMD& \ 512& ' Year is first 7 bits
Month = (YMD& AND 511&) \ 31& ' Month is next 4 bits
Day = YMD& AND 31& ' Day is last 5 bits
Y$ = LTRIM$(STR$(Year))
M$ = LTRIM$(STR$(Month))
D$ = LTRIM$(STR$(Day)): IF LEN(D$) = 1 THEN D$ = "0" + D$
Dat$ = M$ + "-" + D$ + "-" + Y$
InRegs.ax = &H3E00 ' Close file function
InRegs.bx = Handle
CALL INTERRUPTX(&H21, InRegs, OutRegs) ' Close it
ELSE
Ecode = OutRegs.flags ' Otherwise return error flags
END IF
END SUB
SUB SetFileDateTime (F$, Dat$, Tim$, Ecode)
Ecode = 0
DIM InRegs AS RegTypeX
DIM OutRegs AS RegTypeX
InRegs.ax = &H3D00
DIM FileName AS STRING * 128
FileName = F$ + CHR$(0)
InRegs.ds = VARSEG(FileName)
InRegs.dx = VARPTR(FileName)
CALL INTERRUPTX(&H21, InRegs, OutRegs)
IF NOT OutRegs.flags THEN
Handle = OutRegs.ax
InRegs.ax = &H5701
InRegs.bx = Handle
Hours& = VAL(LEFT$(Tim$, 2)) * 2048&
Minutes& = VAL(MID$(Tim$, 4, 2)) * 32&
Seconds& = VAL(RIGHT$(Tim$, 2)) \ 2
HMS& = Hours& + Minutes& + Seconds&
IF HMS& > 65536 THEN
InRegs.cx = 65536 - HMS&
ELSE
InRegs.cx = HMS&
END IF
Year& = (VAL(RIGHT$(Dat$, 4)) - 1980&) * 512&
Month& = VAL(LEFT$(Dat$, 2)) * 32&
Day& = VAL(MID$(Dat$, 4, 2))
YMD& = Year& + Month& + Day&
IF YMD& > 65536 THEN
InRegs.dx = 65536 - YMD&
ELSE
InRegs.dx = YMD&
END IF
CALL INTERRUPTX(&H21, InRegs, OutRegs)
InRegs.ax = &H3E00
InRegs.bx = Handle
CALL INTERRUPTX(&H21, InRegs, OutRegs)
ELSE
Ecode = OutRegs.flags
END IF
END SUB

Related

How to split word files by the number of characters

Could you anybody help me how to split word file by character!
I can't find any way to split word files by the number of characters on the internet!
For example, to split a document into 500-character blocks:
Sub SplitDocument()
Application.ScreenUpdating = False
Dim Rng As Range, i As Long, j As Long
Const Char As Long = 500
With ActiveDocument
' Process each character block
For i = 1 To Int(.Characters.Count / Char)
j = j + 1
' Get the character block
Set Rng = .Range((i - 1) * Char, i * Char)
' Copy the character block
Rng.Copy
Rng.Collapse wdCollapseEnd
Call NewDoc(ActiveDocument, (i - 1) * Char + 1, j)
Next
If Rng.End < .Range.End Then
i = i + 1: j = j + 1
Rng.End = .Range.End
' Copy the range
Rng.Copy
Rng.Collapse wdCollapseEnd
Call NewDoc(ActiveDocument, (i - 1) * Char + 1, j)
End If
End With
Set Rng = Nothing
Application.ScreenUpdating = True
End Sub
Sub NewDoc(DocSrc As Document, i As Long, j As Long)
Dim DocTgt As Document, HdFt As HeaderFooter
' Create the output document
Set DocTgt = Documents.Add(Visible:=False)
With DocTgt
' Paste contents into the output document, preserving the formatting
.Range.PasteAndFormat (wdFormatOriginalFormatting)
' Replicate the headers & footers
For Each HdFt In DocSrc.Sections(DocSrc.Characters(i).Sections(1).Index).Headers
.Sections(1).Headers(HdFt.Index).Range.FormattedText = HdFt.Range.FormattedText
Next
For Each HdFt In DocSrc.Sections(DocSrc.Characters(i).Sections(1).Index).Footers
.Sections(1).Footers(HdFt.Index).Range.FormattedText = HdFt.Range.FormattedText
Next
' Save & close the output document
.SaveAs FileName:=Split(DocSrc.FullName, ".doc")(0) & "_" & j & ".docx", _
FileFormat:=wdFormatXMLDocument, AddToRecentFiles:=False
.Close SaveChanges:=False
End With
Set DocTgt = Nothing: Set DocSrc = Nothing
End Sub

How can I camelCase a phrase with Dragon NaturallySpeaking's advanced scripting?

From time to time, typically when coding, I would like to dictate a phrase so that it is camelCased a phrase. For example, when I dictate sentence generator I would like Dragon NaturallySpeaking to write sentenceGenerator.
How can I camelCase a phrase with Dragon NaturallySpeaking's advanced scripting?
Same question for Dragon Dictate: How can I convert a series of words into camel case in AppleScript?
You can use this function:
' CamelCases the previous <1to10> words:
' Voice command name: CamelCase <1to10>
' Author: Edgar
' URL: https://www.knowbrainer.com/forums/forum/messageview.cfm?FTVAR_FORUMVIEWTMP=Linear&catid=12&threadid=14634&discTab=true
' URL mirror: https://web.archive.org/web/20170606015010/https://www.knowbrainer.com/forums/forum/messageview.cfm?FTVAR_FORUMVIEWTMP=Linear&catid=12&threadid=14634&discTab=true
' Tested with Dragon NaturallySpeaking 12.5 with Windows 7 SP1 x64 Ultimate
Sub Main
Dim camelVariable, dictate, firstCharacter As String
Dim wasSpace, isLower, trailingSpace As Boolean
Dim dictationLength As Integer
For increment = 1 To Val (ListVar1)
SendKeys "+^{Left}", 1
Next increment
Wait 0.2
SendKeys "^c", 1
Wait 0.3
dictate = Clipboard
Wait 0.3
dictationLength = Len (dictate)
If Mid (dictate, dictationLength, 1) = " " Then trailingSpace = True
'Dim testing As String
'testing = "#" + Mid (dictate, 1, dictationLength) + "#"
'MsgBox testing
dictate = Trim (dictate)
firstCharacter = Mid (dictate, 1, 1)
firstCharacter = LCase (firstCharacter)
camelVariable = firstCharacter
dictationLength = Len (dictate)
If dictationLength > 1 Then
For increment = 2 To dictationLength
firstCharacter = Mid (dictate, increment, 1)
If firstCharacter = " " Then
wasSpace = True
Else
If wasSpace = True Then firstCharacter = UCase (firstCharacter)
camelVariable = camelVariable + firstCharacter
wasSpace = False
End If
Next increment
End If
If leadingSpace = True Then camelVariable = " " + camelVariable
If trailingSpace = True Then camelVariable = camelVariable + " "
SendKeys camelVariable
End Sub
or
' CamelCases the previous dictated words:
' Voice command name: CamelCase that
' Author: Heather
' URL: https://www.knowbrainer.com/forums/forum/messageview.cfm?FTVAR_FORUMVIEWTMP=Linear&catid=12&threadid=14634&discTab=true
' URL mirror: https://web.archive.org/web/20170606015010/https://www.knowbrainer.com/forums/forum/messageview.cfm?FTVAR_FORUMVIEWTMP=Linear&catid=12&threadid=14634&discTab=true
' Tested with Dragon NaturallySpeaking 12.5 with Windows 7 SP1 x64 Ultimate
Option Explicit
Sub Main
Dim engCtrl As New DgnEngineControl
Dim Text As String
Dim VarText As String
HeardWord "cut","that"
Text = Clipboard
SendDragonKeys "" & CamelCase(Text)
End Sub
Public Function CamelCase(strInput As String) As String
Dim i As Integer
Dim sMid As String
Dim foundSpace As Boolean
For i = 1 To Len(strInput)
sMid = Mid(strInput, i, 1)
Select Case Asc(sMid)
Case 32:
foundSpace = True
Case 65 To 90:
If i = 1 Then
CamelCase = CamelCase + LCase(sMid)
Else
CamelCase = CamelCase + sMid
End If
foundSpace = False
Case 97 To 122:
If foundSpace Then
CamelCase = CamelCase + UCase(sMid)
Else
CamelCase = CamelCase + sMid
End If
foundSpace = False
Case Else:
CamelCase = CamelCase + sMid
foundSpace = False
End Select
Next i
End Function
or
' CamelCases the next dictated words:
' Voice command name: CamelCase <dictation>
' Author: Edgar
' URL: https://www.knowbrainer.com/forums/forum/messageview.cfm?FTVAR_FORUMVIEWTMP=Linear&catid=12&threadid=14634&discTab=true
' URL mirror: https://web.archive.org/web/20170606015010/https://www.knowbrainer.com/forums/forum/messageview.cfm?FTVAR_FORUMVIEWTMP=Linear&catid=12&threadid=14634&discTab=true
' Requires Dragon NaturallySpeaking 13 Professional or higher, because the variable <dictation> was introduced in Dragon NaturallySpeaking 13 Professional.
Sub Main
Dim camelVariable, dictate, firstCharacter As String
Dim wasSpace, isLower As Boolean
Dim dictationLength As Integer
dictate = ListVar1
dictate = Trim (dictate)' probably unnecessary
firstCharacter = Mid (dictate, 1, 1)
firstCharacter = LCase (firstCharacter)
camelVariable = firstCharacter
dictationLength = Len (dictate)
If dictationLength > 1 Then
For increment = 2 To dictationLength
firstCharacter = Mid (dictate, increment, 1)
If firstCharacter = " " Then
wasSpace = True
Else
If wasSpace = True Then firstCharacter = UCase (firstCharacter)
camelVariable = camelVariable + firstCharacter
wasSpace = False
End If
Next increment
End If
SendKeys " " + camelVariable + " "
End Sub
(source) (mirror)
The answer from 2017 has syntax issues. I just coded and tested this for Dragon 15:
'#Language "WWB-COM"
' Command name: case camel <dictation>
'
' Description:
' Applies camel case to provided phrase.
'
' Usage:
' "case camel looks good to me" -> "looksGoodToMe"
Option Explicit
Sub Main
Dim phrase As String
Dim result As String
Dim wasSpace As Boolean
Dim i As Integer
phrase = ListVar1
phrase = Trim(phrase)
wasSpace = False
For i = 0 To Len(phrase) - 1
If i = 0 Then
result = LCase(Mid(phrase,i + 1,1))
ElseIf Mid(phrase,i + 1,1) = " " Then
wasSpace = True
ElseIf wasSpace Then
result += UCase(Mid(phrase,i + 1,1))
wasSpace = False
Else
result += LCase(Mid(phrase,i + 1,1))
End If
Next
SendKeys result
End Sub

QBASIC Decimal to Binary conversion

I have converted a decimal number to binary using STR$() in QBASIC. But I need a way to convert decimal number to binary without using string functions. Thanks.
My Code :
CLS
INPUT N
WHILE N <> 0
E = N MOD 2
B$ = STR$(E)
N = FIX(N / 2)
C$ = B$ + C$
WEND
PRINT "Output "; C$
END
This code sample converts a numeric value to a binary string in Basic.
PRINT "Enter value";
INPUT Temp#
Out3$ = ""
IF Temp# >= False THEN
Digits = False
DO
IF 2 ^ (Digits + 1) > Temp# THEN
EXIT DO
END IF
Digits = Digits + 1
LOOP
FOR Power = Digits TO 0 STEP -1
IF Temp# - 2 ^ Power >= False THEN
Temp# = Temp# - 2 ^ Power
Out3$ = Out3$ + "1"
ELSE
Out3$ = Out3$ + "0"
END IF
NEXT
END IF
PRINT Out3$
END
When you want to display an integer value as binary, it seems logical to me to store it in a string variable, because it's only for display. So I'm not really sure what you are trying to do here.
Maybe you were looking for LTRIM$ so you would get outputs like 11010 instead of 1 1 0 1 0 ?
You could store it in an integer value like in the code below. But, although the integer value will look the same as the string variable, it will in fact be a completely different value.
CLS
INPUT "Type a decimal number:", N
S$ = ""
I = 0
P = 1
WHILE (N <> 0)
' get right most bit and shift right
E = N AND 1
N = INT(N / 2) ' bit shift right
' format for dsplay
S$ = LTRIM$(STR$(E)) + S$
I = I + (E * P)
P = P * 10
WEND
PRINT "Binary as string="; S$
PRINT "Binary as int="; I
END

VB 6 failed send to email server

I am trying to write a program that will send email with an attachment in VB6. I'm using winsock and smtp.gmail.com as my mail server but it doesn't work. Failed to connect to mail server.The code works fine. My only problem is when I try to send message it doesn't connect please help me thanks in advance.
Here's the code
Dim objBase64 As New Base64
Dim bTrans As Boolean
Dim m_iStage As Integer
Dim Sock As Integer
Dim RC As Integer
Dim Bytes As Integer
Dim ResponseCode As Integer
Dim path As String
Private Type OPENFILENAME
lStructSize As Long
hwndOwner As Long
hInstance As Long
lpstrFilter As String
lpstrCustomFilter As String
nMaxCustFilter As Long
nFilterIndex As Long
lpstrFile As String
nMaxFile As Long
lpstrFileTitle As String
nMaxFileTitle As Long
lpstrInitialDir As String
lpstrTitle As String
flags As Long
nFileOffset As Integer
nFileExtension As Integer
lpstrDefExt As String
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type
Const OFN_READONLY = &H1
Const OFN_OVERWRITEPROMPT = &H2
Const OFN_HIDEREADONLY = &H4
Const OFN_NOCHANGEDIR = &H8
Const OFN_SHOWHELP = &H10
Const OFN_ENABLEHOOK = &H20
Const OFN_ENABLETEMPLATE = &H40
Const OFN_ENABLETEMPLATEHANDLE = &H80
Const OFN_NOVALIDATE = &H100
Const OFN_ALLOWMULTISELECT = &H200
Const OFN_EXTENSIONDIFFERENT = &H400
Const OFN_PATHMUSTEXIST = &H800
Const OFN_FILEMUSTEXIST = &H1000
Const OFN_CREATEPROMPT = &H2000
Const OFN_SHAREAWARE = &H4000
Const OFN_NOREADONLYRETURN = &H8000
Const OFN_NOTESTFILECREATE = &H10000
Const OFN_NONETWORKBUTTON = &H20000
Const OFN_NOLONGNAMES = &H40000
Const OFN_EXPLORER = &H80000
Const OFN_NODEREFERENCELINKS = &H100000
Const OFN_LONGNAMES = &H200000
Const OFN_SHAREFALLTHROUGH = 2
Const OFN_SHARENOWARN = 1
Const OFN_SHAREWARN = 0
Private Declare Function GetSaveFileName Lib "comdlg32" Alias "GetSaveFileNameA" (pOpenfilename As OPENFILENAME) As Long
Private Declare Function timeGetTime Lib "winmm.dll" () As Long
Private Declare Function GetSystemMenu Lib "user32" (ByVal hWnd As Long, ByVal bRevert As Long) As Long
Private Declare Function GetMenuItemCount Lib "user32" (ByVal hMenu As Long) As Long
Private Declare Function RemoveMenu Lib "user32" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long) As Long
Private Declare Function DrawMenuBar Lib "user32" (ByVal hWnd As Long) As Long
Const MF_BYPOSITION = &H400&
Const MF_REMOVE = &H1000&
Dim Mime As Boolean
Dim arrRecipients As Variant
Dim CurrentE As Integer
Private Sub Attachment_Click()
path = SaveDialog(Me, "*.*", "Attach File", App.path)
If path = "" Then Exit Sub
AttachmentList.AddItem path
Mime = True
AttachmentList.ListIndex = AttachmentList.ListCount - 1
End Sub
Private Sub AttachmentList_Click()
fSize = Int((FileLen(AttachmentList) / 1024) * 100 + 0.5) / 100
AttachmentList.ToolTipText = AttachmentList & " (" & fSize & " KB)"
End Sub
Private Sub AttachmentList_OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single)
For I = 1 To Data.Files.Count
If (GetAttr(Data.Files.Item(I)) And vbDirectory) = 0 Then AttachmentList.AddItem Data.Files.Item(I): Mime = True: AttachmentList.ListIndex = AttachmentList.ListCount - 1
Next I
End Sub
Private Sub DataArrival_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim MsgBuffer As String * 2048
On Error Resume Next
If Sock > 0 Then
Bytes = recv(Sock, ByVal MsgBuffer, 2048, 0)
If Bytes > 0 Then
ServerResponse = Mid$(MsgBuffer, 1, Bytes)
DataArrival = DataArrival & ServerResponse & vbCrLf
DataArrival.SelStart = Len(DataArrival)
If bTrans Then
If ResponseCode = Left$(MsgBuffer, 3) Then
m_iStage = m_iStage + 1
Transmit m_iStage
Else
closesocket (Sock)
Call EndWinsock
Sock = 0
Process = "The Server responds with an unexpected Response Code!"
Exit Sub
End If
End If
ElseIf WSAGetLastError() <> WSAEWOULDBLOCK Then
closesocket (Sock)
Call EndWinsock
Sock = 0
End If
End If
Refresh
End Sub
Private Sub delattach_Click()
If AttachmentList.ListCount = 0 Or AttachmentList.ListIndex = -1 Then Exit Sub
tmpIndex = AttachmentList.ListIndex
AttachmentList.RemoveItem (AttachmentList.ListIndex)
If AttachmentList.ListCount = 0 Then Mime = False: Attachment.ToolTipText = "Drag & Drop your attachments here" Else If AttachmentList.ListIndex = 0 Then AttachmentList.ListIndex = tmpIndex Else AttachmentList.ListIndex = tmpIndex - 1
End Sub
Sub DisableX(frm As Form)
Dim hMenu As Long
Dim nCount As Long
hMenu = GetSystemMenu(frm.hWnd, 0)
nCount = GetMenuItemCount(hMenu)
Call RemoveMenu(hMenu, nCount - 1, MF_REMOVE Or MF_BYPOSITION)
Call RemoveMenu(hMenu, nCount - 2, MF_REMOVE Or MF_BYPOSITION)
DrawMenuBar frm.hWnd
End Sub
Private Sub Exit_Click()
On Error Resume Next
Call Startrek
closesocket Sock
Call EndWinsock
End
End Sub
Private Sub Form_Load()
Call DisableX(Me)
End Sub
Function IsConnected2Internet() As Boolean
On Error Resume Next
If MyIP = "127.0.0.1" Or MyIP = "" Then IsConnected2Internet = False Else IsConnected2Internet = True
End Function
Function SaveDialog(Form1 As Form, Filter As String, Title As String, InitDir As String) As String
Dim ofn As OPENFILENAME
Dim A As Long
ofn.lStructSize = Len(ofn)
ofn.hwndOwner = Form1.hWnd
ofn.hInstance = App.hInstance
If Right$(Filter, 1) <> "|" Then Filter = Filter & "|"
For A = 1 To Len(Filter)
If Mid$(Filter, A, 1) = "|" Then Mid$(Filter, A, 1) = Chr$(0)
Next A
ofn.lpstrFilter = Filter
ofn.lpstrFile = Space$(254)
ofn.nMaxFile = 255
ofn.lpstrFileTitle = Space$(254)
ofn.nMaxFileTitle = 255
ofn.lpstrInitialDir = InitDir
ofn.lpstrTitle = Title
ofn.flags = OFN_HIDEREADONLY Or OFN_CREATEPROMPT
A = GetSaveFileName(ofn)
If (A) Then
SaveDialog = Left$(Trim$(ofn.lpstrFile), Len(Trim$(ofn.lpstrFile)) - 1)
Else
SaveDialog = ""
End If
End Function
Private Sub SendMimeAttachment()
Dim FileIn As Long
Dim temp As Variant
Dim s As Variant
Dim TempArray() As Byte
Dim Encoded() As Byte
Dim strFile As String
Dim strFile1 As String * 32768
For IAT = 0 To AttachmentList.ListCount - 1
path = AttachmentList.List(IAT)
Mimefilename = Trim$(Right$(path, Len(path) - InStrRev(path, "\")))
FileIn = FreeFile
r
temp = vbCrLf & "--NextMimePart" & vbCrLf
temp = temp & "Content-Type: application/octet-stream; name=Mimefilename" & vbCrLf
temp = temp & "Content-Transfer-Encoding: base64" & vbCrLf
temp = temp & "Content-Disposition: attachment; filename=" & Chr$(34) & Mimefilename & Chr$(34) & vbCrLf
WinsockSendData (temp & vbCrLf)
Open path For Binary Access Read As FileIn
If GetSetting(App.Title, "Settings", "Too big", "") <> "True" Then
If LOF(FileIn) > 2097152 Then
fSize = Int((LOF(FileIn) / 1048576) * 100 + 0.5) / 100
Setu = MsgBox("The current file is " & fSize & " MB of size, extracting from it could take a few minutes, Click Yes to go ahead, No to skip it or Cancel if you don't want to get this message again", vbYesNoCancel)
If Setu = vbYes Then GoTo Cont
If Setu = vbNo Then Close (FileIn): GoTo Anoth Else SaveSetting App.Title, "Settings", "Too big", "True"
End If
End If
Cont:
frm2.Visible = True
Process = "Loading """ & AttachmentList.List(IAT) & """"
Do While Not EOF(FileIn)
If LOF(FileIn) = 0 Then GoTo Anoth
Get FileIn, , strFile1
strFile = strFile & Mid$(strFile1, 1, Len(strFile1) - (Loc(FileIn) - LOF(FileIn)))
strFile1 = ""
DoEvents
frm2.Width = (3300 / 100) * (Len(strFile) * 50 / LOF(FileIn))
lblpcent = Int(Len(strFile) * 50 / LOF(FileIn)) & "%"
If Cancelflag Then Close FileIn: Exit Sub
Loop
Close FileIn
If strFile = "" Then Exit Sub
objBase64.Str2ByteArray strFile, TempArray
objBase64.EncodeB64 TempArray, Encoded
objBase64.Span 76, Encoded, TempArray
strFile = ""
s = StrConv(TempArray, vbUnicode)
For I = 1 To Len(s) Step 8192
ss = Trim$(Mid$(s, I, 8192))
tmpServerSpeed = 150
Start = timeGetTime
Do
DoEvents
Loop Until timeGetTime >= Start + tmpServerSpeed * 20
WinsockSendData (ss)
frm2.Width = 1650 + (3300 / 100) * ((I + Len(ss)) * 50 / Len(s))
lblpcent = 50 + Int((I + Len(ss)) * 50 / Len(s)) & "%"
Process = "Sending " & Mimefilename & "... " & I + Len(ss) & " Bytes from " & Len(s)
DoEvents
Next I
Anoth:
s = ""
Next IAT
WinsockSendData (vbCrLf & "--NextMimePart--" & vbCrLf)
WinsockSendData (vbCrLf & "." & vbCrLf)
End Sub
Private Sub SendMimeConnect_Click()
If Tobox = "" Or InStr(Tobox, "#") = 0 Then
MsgBox "To: Is not correct!"
Exit Sub
End If
If IsConnected = False Then
If MsgBox("No Internet connection has been detected, check for Update anyway?", vbYesNo) = vbNo Then Exit Sub
End If
Sock = ConnectSock(MailServer, 25, DataArrival.hWnd)
If Sock = SOCKET_ERROR Then
Process = "Cannot Connect to " & MailServer & GetWSAErrorString(WSAGetLastError())
closesocket Sock
Call EndWinsock
Exit Sub
End If
Process = "Connected to " & MailServer
bTrans = True
m_iStage = 0
DataArrival = ""
ResponseCode = 220
Call WaitForResponse
End Sub
Sub SendMimetxt(txtFrom, txtTo, txtSubjekt, txtMail)
Dim strToSend As String
Dim strDataToSend As String
If Mime Then
strDataToSend = "From: " & txtFrom & vbCrLf
strDataToSend = strDataToSend & "To: " & txtTo & vbCrLf
strDataToSend = strDataToSend & "Date: " & Format$(Now, "DDDD , dd Mmm YYYY hh:mm:ss AM/PM") & vbCrLf
strDataToSend = strDataToSend & "Subject: " & txtSubjekt & vbCrLf
strDataToSend = strDataToSend & "X-Mailer: " & App.CompanyName & " - " & App.Title & vbCrLf
strDataToSend = strDataToSend & "Mime-Version: 1.0" & vbCrLf
strDataToSend = strDataToSend & "Content-Type: multipart/mixed; boundary=NextMimePart" & vbCrLf
strDataToSend = strDataToSend & "Content-Transfer-Encoding: 7bit" & vbCrLf
strDataToSend = strDataToSend & "This is a multi-part message in MIME format." & vbCrLf & vbCrLf
strDataToSend = strDataToSend & "--NextMimePart" & vbCrLf & vbCrLf
strDataToSend = strDataToSend & Trim$(Mailtxt)
strDataToSend = Replace$(strDataToSend, vbCrLf & "." & vbCrLf, vbCrLf & "." & Chr$(0) & vbCrLf)
For I = 1 To Len(strDataToSend) Step 8192
strToSend = Trim$(Mid$(strDataToSend, I, 8192))
WinsockSendData (strToSend)
frm2.Width = (2400 / 100) * ((I + Len(strToSend)) * 100 / Len(strDataToSend))
lblpcent = Int((I + Len(strToSend)) * 100 / Len(strDataToSend)) & "%"
If Cancelflag Then Exit For
Process = "Sending message body... " & I + Len(strToSend) & " Bytes from " & Len(strDataToSend)
DoEvents
Next I
SendMimeAttachment
Else
strDataToSend = "From: " & txtFrom & vbCrLf
strDataToSend = strDataToSend & "To: " & txtTo & vbCrLf
strDataToSend = strDataToSend & "Date: " & Format$(Now, "DDDD , dd Mmm YYYY hh:mm:ss AM/PM") & vbCrLf
strDataToSend = strDataToSend & "Subject: " & txtSubjekt & vbCrLf
strDataToSend = strDataToSend & "X-Mailer: " & App.CompanyName & " - " & App.Title & vbCrLf & vbCrLf
strDataToSend = strDataToSend & Trim$(txtMail)
strDataToSend = Replace$(strDataToSend, vbCrLf & "." & vbCrLf, vbCrLf & "." & Chr$(0) & vbCrLf)
For I = 1 To Len(strDataToSend) Step 8192
strToSend = Trim$(Mid$(strDataToSend, I, 8192))
WinsockSendData (strToSend)
frm2.Width = (2400 / 100) * ((I + Len(strToSend)) * 100 / Len(strDataToSend))
lblpcent = Int((I + Len(strToSend)) * 100 / Len(strDataToSend)) & "%"
If Cancelflag Then Exit For
Process = "Sending message body... " & I + Len(strToSend) & " Bytes from " & Len(strDataToSend)
DoEvents
Next I
WinsockSendData (vbCrLf & "." & vbCrLf)
End If
End Sub
Sub Startrek()
On Error Resume Next
Dim Rate As Integer
Dim Rate2 As Integer
If WindowState <> 0 Then Exit Sub
Caption = "End Transmission"
GotoVal = (Height / 12)
Rate = 50
For Gointo = 1 To GotoVal
Spd = Timer
Rate2 = Rate / 2
Height = Height - Rate
Top = Top + Rate2
DoEvents
Width = Width - Rate
Left = Left + Rate2
DoEvents
If Width <= 2000 Then Exit For
Rate = (Timer - Spd) * 10000
Next Gointo
WindowState = 1
End Sub
Private Sub Tobox_Change()
arrRecipients = Split(Tobox, ",")
End Sub
Private Sub Transmit(iStage As Integer)
Dim Helo As String
Dim pos As Integer
Select Case m_iStage
Case 1
Helo = Frombox
pos = Len(Helo) - InStr(Helo, "#")
Helo = Right$(Helo, pos)
ResponseCode = 250
WinsockSendData ("HELO " & Helo & vbCrLf)
Call WaitForResponse
Case 2
ResponseCode = 250
WinsockSendData ("MAIL FROM: <" & Trim$(Frombox) & ">" & vbCrLf)
Call WaitForResponse
Case 3
ResponseCode = 250
WinsockSendData ("RCPT TO: <" & Trim$(arrRecipients(CurrentE)) & ">" & vbCrLf)
Call WaitForResponse
Case 4
ResponseCode = 354
WinsockSendData ("DATA" & vbCrLf)
Call WaitForResponse
Case 5
ResponseCode = 250
Call SendMimetxt(Frombox, Trim$(arrRecipients(CurrentE)), Subjekt, Mailtxt)
Call WaitForResponse
Case 6
ResponseCode = 221
WinsockSendData ("QUIT" & vbCrLf)
Call WaitForResponse
Process = "Email has been sent!"
frm2.Width = 3300
lblpcent = "100%"
DataArrival = ""
m_iStage = 0
If arrRecipients(CurrentE + 1) <> "" Then
CurrentE = CurrentE + 1
SendMimeConnect_Click
Else
bTrans = False
CurrentE = 0
End If
End Select
End Sub
Private Sub WaitForResponse()
Dim Start As Long
Dim Tmr As Long
Start = timeGetTime
While Bytes > 0
Tmr = timeGetTime - Start
DoEvents '
If Tmr > 20000 Then
Process = "SMTP service error, timed out while waiting for response"
End If
Wend
End Sub
Private Sub WinsockSendData(DatatoSend As String)
Dim RC As Integer
Dim MsgBuffer As String * 8192
MsgBuffer = DatatoSend
RC = send(Sock, ByVal MsgBuffer, Len(DatatoSend), 0)
If RC = SOCKET_ERROR Then
Process = "Cannot Send Request." & Str$(WSAGetLastError()) & _
GetWSAErrorString(WSAGetLastError())
closesocket Sock
Call EndWinsock
Exit Sub
End If
End Sub
I didn't bother to read your code. Too hard. Here's how to do it easily.
Set emailObj = CreateObject("CDO.Message")
emailObj.From = "dc#gail.com"
emailObj.To = "dc#gail.com"
emailObj.Subject = "Test CDO"
emailObj.TextBody = "Test CDO"
emailObj.AddAttachment "c:\windows\win.ini"
Set emailConfig = emailObj.Configuration
emailConfig.Fields("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.gmail.com"
emailConfig.Fields("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 465
emailConfig.Fields("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
emailConfig.Fields("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
emailConfig.Fields("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = true
emailConfig.Fields("http://schemas.microsoft.com/cdo/configuration/sendusername") = "YourUserName"
emailConfig.Fields("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "Password1"
emailConfig.Fields.Update
emailObj.Send
If err.number = 0 then Msgbox "Done"
Here's how to get files from internet with a high level object. You must use the exact name with http:// as there no helper for incorrect addresses.
Set File = WScript.CreateObject("Microsoft.XMLHTTP")
File.Open "GET", "http://www.microsoft.com", False
File.setRequestHeader "User-Agent", "Mozilla/4.0 (compatible; MSIE 8.0; Windows NT 6.0; Trident/4.0; SLCC1; .NET CLR 2.0.50727; Media Center PC 5.0; .NET CLR 1.1.4322; .NET CLR 3.5.30729; .NET CLR 3.0.30618; .NET4.0C; .NET4.0E; BCD2000; BCD2000)"
File.Send
txt=File.ResponseText
Also for binary files use ado stream. To create a database in memory use adodb recordset (better than a dictionary, array, or a collection), makes sorting a one line command.

Align series by value in DevExpress XtraCharts

I have a DevExpress XtraChart object with several series, all of type: line.
I have a requirement from a client to align the series by the max value of each series. This is without regard to the attached axis, has anyone done this before?
Although I was interested in displaying this on the chart element, the 'work' was done on the underlying DataSet.
I was able to achieve this by looping through the series collection, deriving the max value of the first series, through a SQL query, and then each subsequent series, and noting the difference, and then adding or subtracting the difference at the DataSet level.
Here's the code:
Private Sub cbAlignPeaks_CheckedChanged(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles cbAlignPeaks.CheckedChanged
Dim dt As DataTable = chart.DataSource
Dim Row() As Data.DataRow
Dim s As Series = Nothing
Dim dtr As DataTableReader = Nothing
Dim maxTimeGet, maxTimeSet, diff As Decimal
Me.Cursor = Cursors.WaitCursor
If cbAlignPeaksPre.Checked Then
For i As Integer = 0 To chartPreTim.Series.Count - 1
s = chartPreTim.Series(i)
If _offsets.Count = chartPreTim.Series.Count - 1 Then
If i > 0 Then
diff = _offsets(s.DataFilters(0).Value)
Row = dt.Select("BORING_NAME = '" & s.Name & "'")
For k As Integer = 0 To Row.Count - 1
Row(k)("TIME_SEC") = Row(k)("TIME_SEC") + diff
Next
End If
Else
If i = 0 Then 'get adjustment info
dtr = getDetectorMax(s.DataFilters(0).Value, cbDetectors.Text, timType.PRE) ' <-- getDetectorMax runs a SQL query returning the max value
If dtr.Read Then
maxTimeGet = dtr("TIME_SEC")
End If
Else 'set adjustment info
dtr = Nothing
dtr = getDetectorMax(s.DataFilters(0).Value, cbDetectors.Text, timType.PRE)
If dtr.Read Then
maxTimeSet = dtr("TIME_SEC")
End If
If maxTimeGet > maxTimeSet Then
diff = maxTimeGet - maxTimeSet
_offsets.Add(s.DataFilters(0).Value, diff)
Row = dt.Select("BORING_NAME = '" & s.DataFilters(0).Value & "'")
For k As Integer = 0 To Row.Count - 1
Row(k)("TIME_SEC") = Row(k)("TIME_SEC") + diff
Next
Else
diff = maxTimeSet - maxTimeGet
_offsets.Add(s.DataFilters(0).Value, diff * -1)
Row = dt.Select("BORING_NAME = '" & s.DataFilters(0).Value & "'")
For k As Integer = 0 To Row.Count - 1
Row(k)("TIME_SEC") = Row(k)("TIME_SEC") - diff
Next
End If
End If
End If
Next
Else
For i As Integer = 1 To chartPreTim.Series.Count - 1 ' We skip item 0 as that's the baseline
s = chartPreTim.Series(i)
diff = _offsets(s.DataFilters(0).Value)
Row = dt.Select("BORING_NAME = '" & s.DataFilters(0).Value & "'")
For k As Integer = 0 To Row.Count - 1
Row(k)("TIME_SEC") = Row(k)("TIME_SEC") - diff
Next
Next
End If
chartPreTim.RefreshData()
chartPreTim.Refresh()
Me.Cursor = Cursors.Default
End Sub